| ︙ | | |
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
|
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
|
-
-
+
+
+
+
-
+
+
+
+
+
+
+
|
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "test_records.scm")
;; Call this one to do all the work and get a standardized list of tests
(define (tests:get-all area-dat)
(let* ((test-search-path (tests:get-tests-search-path (megatest:area-configdat area-dat) area-dat)))
(append paths (list (conc (megatest:area-path area-dat) "/tests")))))
;; (append paths (list (conc (megatest:area-path area-dat) "/tests")))))
(if (directory-exists? d)
d
(begin
(debug:print 0 "WARNING: problem with directory " d ", dropping it from tests path")
#f)))
(append paths (list (conc *toppath* "/tests"))))))
(define (tests:get-valid-tests test-registry tests-paths)
(if (null? tests-paths)
test-registry
(let loop ((hed (car tests-paths))
(tal (cdr tests-paths)))
(if (file-exists? hed)
|
| ︙ | | |
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
|
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
|
-
+
|
type )))
;; This was run remote, don't think that makes sense. Perhaps not, but that is the easiest path for the moment.
(rmt:csv->test-data run-id test-id
dat))))
;; need to update the top test record if PASS or FAIL and this is a subtest
(if (not (equal? item-path ""))
(rmt:roll-up-pass-fail-counts run-id test-name item-path status))
(rmt:roll-up-pass-fail-counts run-id test-name item-path state status))
(if (or (and (string? comment)
(string-match (regexp "\\S+") comment))
waived)
(let ((cmt (if waived waived comment)))
(rmt:general-call 'set-test-comment run-id cmt test-id)))))
|
| ︙ | | |
581
582
583
584
585
586
587
588
589
590
591
592
593
594
|
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
|
+
|
;; (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)))))
(define (tests:get-testconfig test-name test-registry system-allowed area-dat)
(let* ((test-path (hash-table-ref/default test-registry test-name (conc (megatest:area-path area-dat) "/tests/" test-name)))
(test-configf (conc test-path "/testconfig"))
(testexists (and (file-exists? test-configf)(file-read-access? test-configf)))
(tcfg (if testexists
(read-config test-configf #f system-allowed environ-patt: (if system-allowed
|
| ︙ | | |
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
|
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
|
-
+
|
;; 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 (rmt:get-test-id run-id waiton ""))
(wtdat (rmt:get-testinfo-state-status run-id test-id))) ;; (cdb:get-test-info-by-id (common:get-remote remote) test-id)))
(if (or (and (equal? (db:test-get-state wtdat) "COMPLETED")
(member (db:test-get-status wtdat) '("FAIL")))
(member (db:test-get-status wtdat) '("FAIL" "ABORT")))
(member (db:test-get-status wtdat) '("KILLED"))
(member (db:test-get-state wtdat) '("INCOMPETE")))
;; (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
|
| ︙ | | |