| ︙ | | | ︙ | |
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
|
(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 (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)))
|
|
|
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
|
(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)))
|
| ︙ | | | ︙ | |
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
155
156
|
(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 (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 (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)
|
|
|
|
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
155
156
|
(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)
|
| ︙ | | | ︙ | |
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
|
;; 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 (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)))
|
|
|
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
|
;; 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)))
|
| ︙ | | | ︙ | |
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
|
;; 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 (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)))
|
|
|
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
|
;; 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)))
|
| ︙ | | | ︙ | |
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
|
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)
(if (or (and (string? comment)
(string-match (regexp "\\S+") comment))
waived)
(let ((cmt (if waived waived comment)))
(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>"))
|
|
|
|
>
<
|
|
|
>
|
>
<
<
|
|
|
|
|
|
|
<
<
<
|
|
>
|
>
>
>
>
>
|
>
>
|
|
|
|
|
|
|
|
|
|
|
<
<
|
<
|
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
342
|
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
(cdb:remote-run db:roll-up-pass-fail-counts #f 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 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
(print "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 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>"))
|
| ︙ | | | ︙ | |
354
355
356
357
358
359
360
361
362
363
364
365
366
367
|
(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-info 4 "Looking at tests " (string-intersperse tests ","))
|
>
|
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
|
(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 ","))
|
| ︙ | | | ︙ | |
421
422
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
|
#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)
|
|
|
|
|
|
|
|
|
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
484
|
#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)
|
| ︙ | | | ︙ | |