| ︙ | | | ︙ | |
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
|
(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 keys ","))
(qrystr (string-intersperse (map (lambda (x)(conc x "=?")) 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)))
|
>
>
>
|
|
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
|
(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
;;
;; Run this server-side
;;
(define (test:get-previous-test-run-record db run-id test-name item-path)
(let* ((keys (db:get-keys db))
(selstr (string-intersperse keys ","))
(qrystr (string-intersperse (map (lambda (x)(conc x "=?")) 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)))
|
| ︙ | | | ︙ | |
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
|
(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))))))))))
|
|
|
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
|
(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))))))))))
|
| ︙ | | | ︙ | |
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
|
;; was WAIVED if this test is FAIL
;; NOTES:
;; 1. Is the call to test:get-previous-run-record remotified?
;; 2. Add test for testconfig waiver propagation control here
;;
(prev-test (if (equal? status "FAIL")
(open-run-close test:get-previous-test-run-record db run-id test-name item-path)
#f))
(waived (if prev-test
(if prev-test ;; true if we found a previous test in this run series
(let ((prev-status (db:test-get-status prev-test))
(prev-state (db:test-get-state prev-test))
(prev-comment (db:test-get-comment prev-test)))
(debug:print 4 "prev-status " prev-status ", prev-state " prev-state ", prev-comment " prev-comment)
|
|
|
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
|
;; was WAIVED if this test is FAIL
;; NOTES:
;; 1. Is the call to test:get-previous-run-record remotified?
;; 2. Add test for testconfig waiver propagation control here
;;
(prev-test (if (equal? status "FAIL")
(cdb:remote-run test:get-previous-test-run-record #f run-id test-name item-path)
#f))
(waived (if prev-test
(if prev-test ;; true if we found a previous test in this run series
(let ((prev-status (db:test-get-status prev-test))
(prev-state (db:test-get-state prev-test))
(prev-comment (db:test-get-comment prev-test)))
(debug:print 4 "prev-status " prev-status ", prev-state " prev-state ", prev-comment " prev-comment)
|
| ︙ | | | ︙ | |
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
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
|
;; (set! outputfilename (conc path "/" outputfilename)))
(print "No such path: " path))
(debug:print 4 "summarize-items with logf " logf ", outputfilename " outputfilename " and force " force)
(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>"))
(hash-table-keys statecounts))
(print "<tr><td>Total</td><td>" tot "</td></tr></table>")
(print "</td><td valign=\"top\">")
;; Print out stats for state
(set! tot 0)
(print "<table cellspacing=\"0\" border=\"1\"><tr><td colspan=\"2\"><h2>Status stats</h2></td></tr>")
(for-each (lambda (status)
(set! tot (+ tot (hash-table-ref counts status)))
(print "<tr><td><font color=\"" (common:get-color-from-status status) "\">" status
"</font></td><td>" (hash-table-ref counts status) "</td></tr>"))
(hash-table-keys counts))
(print "<tr><td>Total</td><td>" tot "</td></tr></table>")
(print "</td></td></tr></table>")
(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"))
|
|
|
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
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
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
|
;; (set! outputfilename (conc path "/" outputfilename)))
(print "No such path: " path))
(debug:print 4 "summarize-items with logf " logf ", outputfilename " outputfilename " and force " force)
(if (or (equal? logf "logs/final.log")
(equal? logf outputfilename)
force)
(begin
(if Onot (obtain-dot-lock outputfilename 1 5 7)) ;; retry every second for 20 seconds, call it dead after 30 seconds and steal the lock
(print "Failed to obtain lock for " outputfilename)
(begin
(print "Obtained 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>"))
(hash-table-keys statecounts))
(print "<tr><td>Total</td><td>" tot "</td></tr></table>")
(print "</td><td valign=\"top\">")
;; Print out stats for state
(set! tot 0)
(print "<table cellspacing=\"0\" border=\"1\"><tr><td colspan=\"2\"><h2>Status stats</h2></td></tr>")
(for-each (lambda (status)
(set! tot (+ tot (hash-table-ref counts status)))
(print "<tr><td><font color=\"" (common:get-color-from-status status) "\">" status
"</font></td><td>" (hash-table-ref counts status) "</td></tr>"))
(hash-table-keys counts))
(print "<tr><td>Total</td><td>" tot "</td></tr></table>")
(print "</td></td></tr></table>")
(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"))
|
| ︙ | | | ︙ | |