30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
|
(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)
(let* ((test-search-path (tests:get-tests-search-path *configdat*)))
(tests:get-valid-tests (make-hash-table) test-search-path)))
(define (tests:get-tests-search-path cfgdat)
(let ((paths (map cadr (configf:get-section cfgdat "tests-paths"))))
(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)
|
|
|
|
|
|
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
|
(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))))
(tests:get-valid-tests (make-hash-table) test-search-path)))
(define (tests:get-tests-search-path cfgdat area-dat)
(let ((paths (map cadr (configf:get-section cfgdat "tests-paths"))))
(append paths (list (conc (megatest:area-path area-dat) "/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)
|
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
|
;; (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)
(let* ((test-path (hash-table-ref/default test-registry test-name (conc *toppath* "/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
"pre-launch-env-vars"
#f))
#f)))
|
|
|
|
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
|
;; (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
"pre-launch-env-vars"
#f))
#f)))
|