| ︙ | | | ︙ | |
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
|
;; get runs by list of criteria
;; register a test run with the db
;;
;; Use: (db-get-value-by-header (db:get-header runinfo)(db:get-row runinfo))
;; to extract info from the structure returned
;;
(define (mt:get-runs-by-patt keys runnamepatt targpatt)
(let loop ((runsdat (cdb:remote-run db:get-runs-by-patt #f keys runnamepatt targpatt 0 500))
(res '())
(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 "header: " header " runslst: " runslst " have-more: " have-more)
(if have-more
(let ((new-offset (+ offset limit))
(next-batch (cdb:remote-run db:get-runs-by-patt #f keys runnamepatt targpatt offset limit)))
(debug:print-info 4 "More than " limit " runs, have " (length full-list) " runs so far.")
(debug:print-info 0 "next-batch: " next-batch)
(loop next-batch
full-list
new-offset
limit))
(vector header full-list)))))
|
|
|
|
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
|
;; get runs by list of criteria
;; register a test run with the db
;;
;; Use: (db-get-value-by-header (db:get-header runinfo)(db:get-row runinfo))
;; to extract info from the structure returned
;;
(define (mt:get-runs-by-patt keys runnamepatt targpatt)
(let loop ((runsdat (rmt:get-runs-by-patt keys runnamepatt targpatt 0 500))
(res '())
(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 "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)))
(debug:print-info 4 "More than " limit " runs, have " (length full-list) " runs so far.")
(debug:print-info 0 "next-batch: " next-batch)
(loop next-batch
full-list
new-offset
limit))
(vector header full-list)))))
|
| ︙ | | | ︙ | |
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
|
(debug:print-info 4 "More than " limit " tests, have " (length full-list) " tests so far.")
(loop (rmt:get-tests-for-run run-id testpatt states status new-offset limit not-in sort-by sort-order qryvals)
full-list
new-offset
limit))
full-list))))
(define (mt:get-prereqs-not-met run-id waitons ref-item-path #!key (mode 'normal))
(db:get-prereqs-not-met run-id waitons ref-item-path mode: mode))
(let ((newres (db: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)
(cdb:remote-run db:get-run-stats #f))
(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))
|
<
<
<
|
>
|
|
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
|
(debug:print-info 4 "More than " limit " tests, have " (length full-list) " tests so far.")
(loop (rmt:get-tests-for-run run-id testpatt states status new-offset limit not-in sort-by sort-order qryvals)
full-list
new-offset
limit))
full-list))))
(define (mt:lazy-get-prereqs-not-met run-id waitons ref-item-path #!key (mode 'normal))
(let* ((key (list run-id waitons ref-item-path mode))
(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 "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))
(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))
|
| ︙ | | | ︙ | |
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
|
(cons testn res)))))))))
;;======================================================================
;; T R I G G E R S
;;======================================================================
(define (mt:process-triggers test-id newstate newstatus)
(let* ((test-dat (mt:lazy-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)
(directory? test-rundir))
|
|
|
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
|
(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)
(directory? test-rundir))
|
| ︙ | | | ︙ | |
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
|
(conc state "/")
(conc "/" status)))))))
;;======================================================================
;; S T A T E A N D S T A T U S F O R T E S T S
;;======================================================================
(define (mt:roll-up-pass-fail-counts run-id test-name item-path status)
(if (and (not (equal? item-path ""))
(member status '("PASS" "WARN" "FAIL" "WAIVED" "RUNNING" "CHECK" "SKIP")))
(begin
(cdb:update-pass-fail-counts *runremote* run-id test-name)
(if (equal? status "RUNNING")
(cdb:top-test-set-running *runremote* run-id test-name)
(cdb:top-test-set-per-pf-counts *runremote* run-id test-name))
#f)
#f))
|
<
<
<
<
<
<
<
<
<
<
<
|
153
154
155
156
157
158
159
160
161
162
163
164
165
166
|
(conc state "/")
(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)
(cdb:client-call *runremote* 'state-status-msg #t *default-numtries* newstate newstatus newcomment test-id))
((and newstate newstatus)
(cdb:client-call *runremote* 'state-status #t *default-numtries* newstate newstatus test-id))
|
| ︙ | | | ︙ | |