| ︙ | | | ︙ | |
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
|
;; PURPOSE.
;;======================================================================
;;======================================================================
;; Tests
;;======================================================================
(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking tcp rpc)
(import (prefix sqlite3 sqlite3:))
(import (prefix rpc rpc:))
(let* ((keys (db:get-keys db))
(selstr (string-intersperse (map (lambda (x)(vector-ref x 0)) keys) ","))
(qrystr (string-intersperse (map (lambda (x)(conc (vector-ref x 0) "=?")) keys) " AND "))
(keyvals #f))
;; first look up the key values from the run selected by run-id
(sqlite3:for-each-row
(lambda (a . b)
(set! keyvals (cons a b)))
|
|
<
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
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
|
;; PURPOSE.
;;======================================================================
;;======================================================================
;; Tests
;;======================================================================
(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking tcp)
(import (prefix sqlite3 sqlite3:))
(declare (unit tests))
(declare (uses db))
(declare (uses common))
(declare (uses items))
(declare (uses runconfig))
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "test_records.scm")
(define (tests:get-valid-tests testsdir test-patts) ;; #!key (test-names '()))
(let ((tests (glob (conc testsdir "/tests/*")))) ;; " (string-translate patt "%" "*")))))
(set! tests (filter (lambda (test)(file-exists? (conc test "/testconfig"))) tests))
(delete-duplicates
(filter (lambda (testname)
(tests:match test-patts testname #f))
(map (lambda (testp)
(last (string-split testp "/")))
tests)))))
;; tests:glob-like-match
(define (tests:glob-like-match patt str)
(let ((like (substring-index "%" patt)))
(let* ((notpatt (equal? (substring-index "~" patt) 0))
(newpatt (if notpatt (substring patt 1) patt))
(finpatt (if like
(string-substitute (regexp "%") ".*" newpatt)
(string-substitute (regexp "\\*") ".*" newpatt)))
(res #f))
;; (print "tests:glob-like-match => notpatt: " notpatt ", newpatt: " newpatt ", finpatt: " finpatt)
(set! res (string-match (regexp finpatt (if like #t #f)) str))
(if notpatt (not res) res))))
;; if itempath is #f then look only at the testname part
;;
(define (tests:match patterns testname itempath)
(if (string? patterns)
(let ((patts (string-split patterns ",")))
(if (null? patts) ;;; no pattern(s) means no match
#f
(let loop ((patt (car patts))
(tal (cdr patts)))
;; (print "loop: patt: " patt ", tal " tal)
(if (string=? patt "")
#f ;; nothing ever matches empty string - policy
(let* ((patt-parts (string-match (regexp "^([^\\/]*)(\\/(.*)|)$") patt))
(test-patt (cadr patt-parts))
(item-patt (cadddr patt-parts)))
;; special case: test vs. test/
;; test => "test" "%"
;; test/ => "test" ""
(if (and (not (substring-index "/" patt)) ;; no slash in the original
(or (not item-patt)
(equal? item-patt ""))) ;; should always be true that item-patt is ""
(set! item-patt "%"))
;; (print "tests:match => patt-parts: " patt-parts ", test-patt: " test-patt ", item-patt: " item-patt)
(if (and (tests:glob-like-match test-patt testname)
(or (not itempath)
(tests:glob-like-match (if item-patt item-patt "") itempath)))
#t
(if (null? tal)
#f
(loop (car tal)(cdr tal)))))))))))
;; if itempath is #f then look only at the testname part
;;
(define (tests:match->sqlqry patterns)
(if (string? patterns)
(let ((patts (string-split patterns ",")))
(if (null? patts) ;;; no pattern(s) means no match, we will do no query
#f
(let loop ((patt (car patts))
(tal (cdr patts))
(res '()))
;; (print "loop: patt: " patt ", tal " tal)
(let* ((patt-parts (string-match (regexp "^([^\\/]*)(\\/(.*)|)$") patt))
(test-patt (cadr patt-parts))
(item-patt (cadddr patt-parts))
(test-qry (db:patt->like "testname" test-patt))
(item-qry (db:patt->like "item_path" item-patt))
(qry (conc "(" test-qry " AND " item-qry ")")))
;; (print "tests:match => patt-parts: " patt-parts ", test-patt: " test-patt ", item-patt: " item-patt)
(if (null? tal)
(string-intersperse (append (reverse res)(list qry)) " OR ")
(loop (car tal)(cdr tal)(cons qry res)))))))
#f))
;; get the previous record for when this test was run where all keys match but runname
;; returns #f if no such test found, returns a single test record if found
(define (test:get-previous-test-run-record db run-id test-name item-path)
(let* ((keys (cdb:remote-run db:get-keys #f))
(selstr (string-intersperse (map (lambda (x)(vector-ref x 0)) keys) ","))
(qrystr (string-intersperse (map (lambda (x)(conc (vector-ref x 0) "=?")) keys) " AND "))
(keyvals #f))
;; first look up the key values from the run selected by run-id
(sqlite3:for-each-row
(lambda (a . b)
(set! keyvals (cons a b)))
|
| ︙ | | | ︙ | |
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
|
(conc "SELECT id FROM runs WHERE " qrystr " AND id != ?;") (append keyvals (list run-id)))
;; for each run starting with the most recent look to see if there is a matching test
;; if found then return that matching test record
(debug:print 4 "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals ", previous run ids found: " prev-run-ids)
(if (null? prev-run-ids) #f
(let loop ((hed (car prev-run-ids))
(tal (cdr prev-run-ids)))
(let ((results (db:get-tests-for-run db hed test-name item-path '() '())))
(debug:print 4 "Got tests for run-id " run-id ", test-name " test-name ", item-path " item-path ": " results)
(if (and (null? results)
(not (null? tal)))
(loop (car tal)(cdr tal))
(if (null? results) #f
(car results))))))))))
;; get the previous records for when these tests were run where all keys match but runname
;; NB// Merge this with test:get-previous-test-run-records? This one looks for all matching tests
;; can use wildcards. Also can likely be factored in with get test paths?
(define (test:get-matching-previous-test-run-records db run-id test-name item-path)
(let* ((keys (db:get-keys db))
(selstr (string-intersperse (map (lambda (x)(vector-ref x 0)) keys) ","))
(qrystr (string-intersperse (map (lambda (x)(conc (vector-ref x 0) "=?")) keys) " AND "))
(keyvals #f)
(tests-hash (make-hash-table)))
;; first look up the key values from the run selected by run-id
(sqlite3:for-each-row
(lambda (a . b)
|
|
|
|
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
|
(conc "SELECT id FROM runs WHERE " qrystr " AND id != ?;") (append keyvals (list run-id)))
;; for each run starting with the most recent look to see if there is a matching test
;; if found then return that matching test record
(debug:print 4 "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals ", previous run ids found: " prev-run-ids)
(if (null? prev-run-ids) #f
(let loop ((hed (car prev-run-ids))
(tal (cdr prev-run-ids)))
(let ((results (cdb:remote-run db:get-tests-for-run #f hed (conc test-name "/" item-path)'() '())))
(debug:print 4 "Got tests for run-id " run-id ", test-name " test-name ", item-path " item-path ": " results)
(if (and (null? results)
(not (null? tal)))
(loop (car tal)(cdr tal))
(if (null? results) #f
(car results))))))))))
;; get the previous records for when these tests were run where all keys match but runname
;; NB// Merge this with test:get-previous-test-run-records? This one looks for all matching tests
;; can use wildcards. Also can likely be factored in with get test paths?
(define (test:get-matching-previous-test-run-records db run-id test-name item-path)
(let* ((keys (cdb:remote-run db:get-keys #f))
(selstr (string-intersperse (map (lambda (x)(vector-ref x 0)) keys) ","))
(qrystr (string-intersperse (map (lambda (x)(conc (vector-ref x 0) "=?")) keys) " AND "))
(keyvals #f)
(tests-hash (make-hash-table)))
;; first look up the key values from the run selected by run-id
(sqlite3:for-each-row
(lambda (a . b)
|
| ︙ | | | ︙ | |
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
|
;; collect all matching tests for the runs then
;; extract the most recent test and return that.
(debug:print 4 "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals
", previous run ids found: " prev-run-ids)
(if (null? prev-run-ids) '() ;; no previous runs? return null
(let loop ((hed (car prev-run-ids))
(tal (cdr prev-run-ids)))
(let ((results (db:get-tests-for-run db hed test-name item-path '() '())))
(debug:print 4 "Got tests for run-id " run-id ", test-name " test-name
", item-path " item-path " results: " (intersperse results "\n"))
;; Keep only the youngest of any test/item combination
(for-each
(lambda (testdat)
(let* ((full-testname (conc (db:test-get-testname testdat) "/" (db:test-get-item-path testdat)))
(stored-test (hash-table-ref/default tests-hash full-testname #f)))
(if (or (not stored-test)
(and stored-test
(> (db:test-get-event_time testdat)(db:test-get-event_time stored-test))))
;; this test is younger, store it in the hash
(hash-table-set! tests-hash full-testname testdat))))
results)
(if (null? tal)
(map cdr (hash-table->alist tests-hash)) ;; return a list of the most recent tests
(loop (car tal)(cdr tal))))))))))
;; Do not rpc this one, do the underlying calls!!!
(define (tests:test-set-status! test-id state status comment dat)
(debug:print 4 "INFO: tests:test-set-status! test-id=" test-id ", state=" state ", status=" status ", dat=" dat)
(let* ((db #f)
(real-status status)
(otherdat (if dat dat (make-hash-table)))
(testdat (open-run-close db:get-test-info-by-id db test-id))
(run-id (db:test-get-run_id testdat))
(test-name (db:test-get-testname testdat))
(item-path (db:test-get-item-path testdat))
;; before proceeding we must find out if the previous test (where all keys matched except runname)
;; was WAIVED if this test is FAIL
(waived (if (equal? status "FAIL")
(let ((prev-test (open-run-close test:get-previous-test-run-record db run-id test-name item-path)))
|
|
|
|
|
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
|
;; collect all matching tests for the runs then
;; extract the most recent test and return that.
(debug:print 4 "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals
", previous run ids found: " prev-run-ids)
(if (null? prev-run-ids) '() ;; no previous runs? return null
(let loop ((hed (car prev-run-ids))
(tal (cdr prev-run-ids)))
(let ((results (cdb:remote-run db:get-tests-for-run #f hed (conc test-name "/" item-path) '() '())))
(debug:print 4 "Got tests for run-id " run-id ", test-name " test-name
", item-path " item-path " results: " (intersperse results "\n"))
;; Keep only the youngest of any test/item combination
(for-each
(lambda (testdat)
(let* ((full-testname (conc (db:test-get-testname testdat) "/" (db:test-get-item-path testdat)))
(stored-test (hash-table-ref/default tests-hash full-testname #f)))
(if (or (not stored-test)
(and stored-test
(> (db:test-get-event_time testdat)(db:test-get-event_time stored-test))))
;; this test is younger, store it in the hash
(hash-table-set! tests-hash full-testname testdat))))
results)
(if (null? tal)
(map cdr (hash-table->alist tests-hash)) ;; return a list of the most recent tests
(loop (car tal)(cdr tal))))))))))
;; Do not rpc this one, do the underlying calls!!!
(define (tests:test-set-status! test-id state status comment dat)
(debug:print-info 4 "tests:test-set-status! test-id=" test-id ", state=" state ", status=" status ", dat=" dat)
(let* ((db #f)
(real-status status)
(otherdat (if dat dat (make-hash-table)))
(testdat (cdb:get-test-info-by-id *runremote* test-id))
(run-id (db:test-get-run_id testdat))
(test-name (db:test-get-testname testdat))
(item-path (db:test-get-item-path testdat))
;; before proceeding we must find out if the previous test (where all keys matched except runname)
;; was WAIVED if this test is FAIL
(waived (if (equal? status "FAIL")
(let ((prev-test (open-run-close test:get-previous-test-run-record db run-id test-name item-path)))
|
| ︙ | | | ︙ | |
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
|
#f))
#f)))
(if waived (set! real-status "WAIVED"))
(debug:print 4 "real-status " real-status ", waived " waived ", status " status)
;; update the primary record IF state AND status are defined
(if (and state status)
(rdb:test-set-status-state test-id real-status state #f))
;; if status is "AUTO" then call rollup (note, this one modifies data in test
;; run area, do not rpc it (yet)
(if (and test-id state status (equal? status "AUTO"))
(db:test-data-rollup #f test-id status))
;; add metadata (need to do this way to avoid SQL injection issues)
;; :first_err
;; (let ((val (hash-table-ref/default otherdat ":first_err" #f)))
|
|
|
|
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
|
#f))
#f)))
(if waived (set! real-status "WAIVED"))
(debug:print 4 "real-status " real-status ", waived " waived ", status " status)
;; update the primary record IF state AND status are defined
(if (and state status)
(cdb:test-set-status-state *runremote* test-id real-status state #f))
;; if status is "AUTO" then call rollup (note, this one modifies data in test
;; run area, it does remote calls under the hood.
(if (and test-id state status (equal? status "AUTO"))
(db:test-data-rollup #f test-id status))
;; add metadata (need to do this way to avoid SQL injection issues)
;; :first_err
;; (let ((val (hash-table-ref/default otherdat ":first_err" #f)))
|
| ︙ | | | ︙ | |
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
|
variable ","
value ","
expected ","
tol ","
units ","
dcomment ",," ;; extra comma for status
type )))
(open-run-close db:csv->test-data db test-id
dat))))
;; need to update the top test record if PASS or FAIL and this is a subtest
(open-run-close db:roll-up-pass-fail-counts db run-id test-name item-path status)
(open-run-close db:test-set-comment db test-id cmt)))
))
(define (tests:test-set-toplog! db run-id test-name logf)
(sqlite3:execute db "UPDATE tests SET final_logf=? WHERE run_id=? AND testname=? AND item_path='';"
logf run-id test-name))
(let ((outputfilename (conc "megatest-rollup-" test-name ".html"))
(orig-dir (current-directory))
(logf #f))
;; This query finds the path and changes the directory to it for the test
(sqlite3:for-each-row
(lambda (path final_logf)
(set! logf final_logf)
(if (directory? path)
(begin
(print "Found path: " path)
(change-directory path))
;; (set! outputfilename (conc path "/" outputfilename)))
(print "No such path: " path)))
db
"SELECT rundir,final_logf FROM tests WHERE run_id=? AND testname=? AND item_path='';"
run-id test-name)
(print "summarize-items with logf " logf)
(tot 0))
(with-output-to-port
oup
(lambda ()
(set! outtxt (conc outtxt "<html><title>Summary: " test-name
"</title><body><h2>Summary for " test-name "</h2>"))
(sqlite3:for-each-row
(lambda (id itempath state status run_duration logf comment)
(hash-table-set! counts status (+ 1 (hash-table-ref/default counts status 0)))
(hash-table-set! statecounts state (+ 1 (hash-table-ref/default statecounts state 0)))
(set! outtxt (conc outtxt "<tr>"
"<td><a href=\"" itempath "/" logf "\"> " itempath "</a></td>"
"<td>" state "</td>"
"<td><font color=" (common:get-color-from-status status)
">" status "</font></td>"
"<td>" (if (equal? comment "")
" "
comment) "</td>"
"</tr>")))
db
"SELECT id,item_path,state,status,run_duration,final_logf,comment FROM tests WHERE run_id=? AND testname=? AND item_path != '';"
run-id test-name)
(print "<table><tr><td valign=\"top\">")
;; Print out stats for status
(set! tot 0)
(print "<table cellspacing=\"0\" border=\"1\"><tr><td colspan=\"2\"><h2>State stats</h2></td></tr>")
(for-each (lambda (state)
(set! tot (+ tot (hash-table-ref statecounts state)))
(print "<tr><td>" state "</td><td>" (hash-table-ref statecounts state) "</td></tr>"))
|
|
>
|
|
>
<
|
|
|
>
|
>
<
<
|
|
|
|
|
|
|
<
<
<
|
|
>
|
>
>
>
>
>
|
>
>
|
|
|
|
|
|
|
|
|
|
|
<
<
|
<
|
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
|
variable ","
value ","
expected ","
tol ","
units ","
dcomment ",," ;; extra comma for status
type )))
(cdb:remote-run db:csv->test-data #f test-id
dat))))
;; need to update the top test record if PASS or FAIL and this is a subtest
(if (not (equal? item-path ""))
(cdb:roll-up-pass-fail-counts *runremote* run-id test-name item-path status))
(if (or (and (string? comment)
(string-match (regexp "\\S+") comment))
waived)
(let ((cmt (if waived waived comment)))
(cdb:remote-run db:test-set-comment #f test-id cmt)))
))
(define (tests:test-set-toplog! db run-id test-name logf)
(cdb:client-call *runremote* 'tests:test-set-toplog #t 2 logf run-id test-name))
(define (tests:summarize-items db run-id test-name force)
;; if not force then only update the record if one of these is true:
;; 1. logf is "log/final.log
;; 2. logf is same as outputfilename
(let* ((outputfilename (conc "megatest-rollup-" test-name ".html"))
(orig-dir (current-directory))
(logf-info (cdb:remote-run db:test-get-logfile-info #f run-id test-name))
(logf (if logf-info (cadr logf-info) #f))
(path (if logf-info (car logf-info) #f)))
;; This query finds the path and changes the directory to it for the test
(set! logf (car logf-info))
(if (directory? path)
(begin
(debug:print 4 "Found path: " path)
(change-directory path))
;; (set! outputfilename (conc path "/" outputfilename)))
(print "No such path: " path))
(debug:print 1 "summarize-items with logf " logf)
(if (or (equal? logf "logs/final.log")
(equal? logf outputfilename)
force)
(begin
(if (obtain-dot-lock outputfilename 1 20 30) ;; retry every second for 20 seconds, call it dead after 30 seconds and steal the lock
(print "Obtained lock for " outputfilename)
(print "Failed to obtain lock for " outputfilename))
(let ((oup (open-output-file outputfilename))
(counts (make-hash-table))
(statecounts (make-hash-table))
(outtxt "")
(tot 0)
(testdat (cdb:remote-run db:test-get-records-for-index-file #f run-id test-name)))
(with-output-to-port
oup
(lambda ()
(set! outtxt (conc outtxt "<html><title>Summary: " test-name
"</title><body><h2>Summary for " test-name "</h2>"))
(for-each
(lambda (testrecord)
(let ((id (vector-ref testrecord 0))
(itempath (vector-ref testrecord 1))
(state (vector-ref testrecord 2))
(status (vector-ref testrecord 3))
(run_duration (vector-ref testrecord 4))
(logf (vector-ref testrecord 5))
(comment (vector-ref testrecord 6)))
(hash-table-set! counts status (+ 1 (hash-table-ref/default counts status 0)))
(hash-table-set! statecounts state (+ 1 (hash-table-ref/default statecounts state 0)))
(set! outtxt (conc outtxt "<tr>"
"<td><a href=\"" itempath "/" logf "\"> " itempath "</a></td>"
"<td>" state "</td>"
"<td><font color=" (common:get-color-from-status status)
">" status "</font></td>"
"<td>" (if (equal? comment "")
" "
comment) "</td>"
"</tr>"))))
testdat)
(print "<table><tr><td valign=\"top\">")
;; Print out stats for status
(set! tot 0)
(print "<table cellspacing=\"0\" border=\"1\"><tr><td colspan=\"2\"><h2>State stats</h2></td></tr>")
(for-each (lambda (state)
(set! tot (+ tot (hash-table-ref statecounts state)))
(print "<tr><td>" state "</td><td>" (hash-table-ref statecounts state) "</td></tr>"))
|
| ︙ | | | ︙ | |
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
|
(print "<table cellspacing=\"0\" border=\"1\">"
"<tr><td>Item</td><td>State</td><td>Status</td><td>Comment</td>"
outtxt "</table></body></html>")
(release-dot-lock outputfilename)))
(close-output-port oup)
(change-directory orig-dir)
(tests:test-set-toplog! db run-id test-name outputfilename)
)))))
(define (get-all-legal-tests)
(let* ((tests (glob (conc *toppath* "/tests/*")))
(res '()))
(debug:print 4 "INFO: Looking at tests " (string-intersperse tests ","))
(for-each (lambda (testpath)
(if (file-exists? (conc testpath "/testconfig"))
(set! res (cons (last (string-split testpath "/")) res))))
tests)
res))
(define (tests:get-testconfig test-name system-allowed)
|
>
|
|
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
|
(print "<table cellspacing=\"0\" border=\"1\">"
"<tr><td>Item</td><td>State</td><td>Status</td><td>Comment</td>"
outtxt "</table></body></html>")
(release-dot-lock outputfilename)))
(close-output-port oup)
(change-directory orig-dir)
;; NB// tests:test-set-toplog! is remote internal...
(tests:test-set-toplog! db run-id test-name outputfilename)
)))))
(define (get-all-legal-tests)
(let* ((tests (glob (conc *toppath* "/tests/*")))
(res '()))
(debug:print-info 4 "Looking at tests " (string-intersperse tests ","))
(for-each (lambda (testpath)
(if (file-exists? (conc testpath "/testconfig"))
(set! res (cons (last (string-split testpath "/")) res))))
tests)
res))
(define (tests:get-testconfig test-name system-allowed)
|
| ︙ | | | ︙ | |
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
|
#t ;; this is the correct order, b is waiting on a and b is before a
(if (> a-priority b-priority)
#t ;; if a is a higher priority than b then we are good to go
#f))))))))
;; for each test:
;;
(define (tests:filter-non-runnable db run-id testkeynames testrecordshash)
(let ((runnables '()))
(for-each
(lambda (testkeyname)
(let* ((test-record (hash-table-ref testrecordshash testkeyname))
(test-name (tests:testqueue-get-testname test-record))
(itemdat (tests:testqueue-get-itemdat test-record))
(item-path (tests:testqueue-get-item_path test-record))
(waitons (tests:testqueue-get-waitons test-record))
(keep-test #t)
(test-id (db:get-test-id db run-id test-name item-path))
(tdat (db:get-test-info-by-id db test-id)))
(if tdat
(begin
;; Look at the test state and status
(if (or (member (db:test-get-status tdat)
'("PASS" "WARN" "WAIVED" "CHECK"))
(member (db:test-get-state tdat)
'("INCOMPLETE" "KILLED")))
(set! keep-test #f))
;; examine waitons for any fails. If it is FAIL or INCOMPLETE then eliminate this test
;; from the runnable list
(if keep-test
(for-each (lambda (waiton)
;; for now we are waiting only on the parent test
(let* ((parent-test-id (db:get-test-id db run-id waiton ""))
(wtdat (db:get-test-info-by-id db test-id)))
(if (or (member (db:test-get-status wtdat)
'("FAIL" "KILLED"))
(member (db:test-get-state wtdat)
'("INCOMPETE")))
(set! keep-test #f)))) ;; no point in running this one again
waitons))))
(if keep-test (set! runnables (cons testkeyname runnables)))))
testkeynames)
runnables))
;;======================================================================
;; test steps
;;======================================================================
;; teststep-set-status! used to be here
(define (test-get-kill-request db test-id) ;; run-id test-name itemdat)
(let* (;; (item-path (item-list->path itemdat))
(testdat (db:get-test-info-by-id db test-id))) ;; run-id test-name item-path)))
(equal? (test:get-state testdat) "KILLREQ")))
(define (test:tdb-get-rundat-count tdb)
(if tdb
(let ((res 0))
(sqlite3:for-each-row
(lambda (count)
|
|
|
|
|
|
|
|
|
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
|
#t ;; this is the correct order, b is waiting on a and b is before a
(if (> a-priority b-priority)
#t ;; if a is a higher priority than b then we are good to go
#f))))))))
;; for each test:
;;
(define (tests:filter-non-runnable run-id testkeynames testrecordshash)
(let ((runnables '()))
(for-each
(lambda (testkeyname)
(let* ((test-record (hash-table-ref testrecordshash testkeyname))
(test-name (tests:testqueue-get-testname test-record))
(itemdat (tests:testqueue-get-itemdat test-record))
(item-path (tests:testqueue-get-item_path test-record))
(waitons (tests:testqueue-get-waitons test-record))
(keep-test #t)
(test-id (cdb:remote-run db:get-test-id #f run-id test-name item-path))
(tdat (cdb:get-test-info-by-id *runremote* test-id)))
(if tdat
(begin
;; Look at the test state and status
(if (or (member (db:test-get-status tdat)
'("PASS" "WARN" "WAIVED" "CHECK"))
(member (db:test-get-state tdat)
'("INCOMPLETE" "KILLED")))
(set! keep-test #f))
;; examine waitons for any fails. If it is FAIL or INCOMPLETE then eliminate this test
;; from the runnable list
(if keep-test
(for-each (lambda (waiton)
;; for now we are waiting only on the parent test
(let* ((parent-test-id (cdb:remote-run db:get-test-id #f run-id waiton ""))
(wtdat (cdb:get-test-info-by-id *runremote* test-id)))
(if (or (member (db:test-get-status wtdat)
'("FAIL" "KILLED"))
(member (db:test-get-state wtdat)
'("INCOMPETE")))
(set! keep-test #f)))) ;; no point in running this one again
waitons))))
(if keep-test (set! runnables (cons testkeyname runnables)))))
testkeynames)
runnables))
;;======================================================================
;; test steps
;;======================================================================
;; teststep-set-status! used to be here
(define (test-get-kill-request test-id) ;; run-id test-name itemdat)
(let* (;; (item-path (item-list->path itemdat))
(testdat (cdb:get-test-info-by-id *runremote* test-id))) ;; run-id test-name item-path)))
(equal? (test:get-state testdat) "KILLREQ")))
(define (test:tdb-get-rundat-count tdb)
(if tdb
(let ((res 0))
(sqlite3:for-each-row
(lambda (count)
|
| ︙ | | | ︙ | |