| ︙ | | | ︙ | |
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
|
(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
|
|
|
|
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
|
(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 #!key (required '()))
(if (string? patterns)
(let ((patts (append (string-split patterns ",") required)))
(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
|
| ︙ | | | ︙ | |
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
|
(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)))
db
(conc "SELECT " selstr " FROM runs WHERE id=? ORDER BY event_time DESC;") run-id)
|
>
>
>
|
|
|
|
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
|
(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)))
db
(conc "SELECT " selstr " FROM runs WHERE id=? ORDER BY event_time DESC;") run-id)
|
| ︙ | | | ︙ | |
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
|
(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)
|
|
>
>
>
|
|
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
|
(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)'() '() #f #f #f #f)))
(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?
;;
;; Run this remotely!!
;;
(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)
|
| ︙ | | | ︙ | |
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
|
;; 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)))
|
|
|
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
|
;; 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) '() '() #f #f #f #f)))
(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)))
|
| ︙ | | | ︙ | |
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
|
;; 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)
|
|
|
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
|
;; 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)
|
| ︙ | | | ︙ | |
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
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
|
;; (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)
)))))
;;======================================================================
;; Gather data from test/task specifications
;;======================================================================
(define (tests:get-valid-tests testsdir test-patts) ;; #!key (test-names '()))
(let ((tests (glob (conc testsdir "/tests/*")))) ;; " (string-translate patt "%" "*")))))
|
|
|
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
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
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
|
;; (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 (not (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)
)))))))
;;======================================================================
;; Gather data from test/task specifications
;;======================================================================
(define (tests:get-valid-tests testsdir test-patts) ;; #!key (test-names '()))
(let ((tests (glob (conc testsdir "/tests/*")))) ;; " (string-translate patt "%" "*")))))
|
| ︙ | | | ︙ | |
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
|
;;======================================================================
;; 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")))
|
<
|
>
|
|
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
|
;;======================================================================
;; test steps
;;======================================================================
;; teststep-set-status! used to be here
(define (test-get-kill-request test-id) ;; run-id test-name itemdat)
(let* ((testdat (cdb:get-test-info-by-id *runremote* test-id))) ;; run-id test-name item-path)))
(and testdat
(equal? (test:get-state testdat) "KILLREQ"))))
(define (test:tdb-get-rundat-count tdb)
(if tdb
(let ((res 0))
(sqlite3:for-each-row
(lambda (count)
(set! res count))
|
| ︙ | | | ︙ | |