24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
|
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "test_records.scm")
(define (tests:get-valid-tests testsdir test-patts) ;; #!key (test-names '()))
(let ((tests (glob (conc testsdir "/tests/*")))) ;; " (string-translate patt "%" "*")))))
(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)))))
|
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
|
>
|
|
|
<
<
|
|
24
25
26
27
28
29
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
59
60
61
62
63
64
65
66
67
68
69
70
|
(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 (cons (conc *toppath* "/tests") ;; the default
(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 car (configf:get-section cfgdat "tests-paths"))))
(cons (conc *toppath* "/tests") paths)))
(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)
(for-each (lambda (test-path)
(let* ((tname (last (string-split test-path "/")))
(tconfig (conc test-path "/testconfig")))
(if (and (not (hash-table-ref/default test-registry tname #f))
(file-exists? tconfig))
(hash-table-set! test-registry tname test-path))))
(glob (conc hed "/*"))))
(if (null? tal)
test-registry
(loop (car tal)(cdr tal))))))
(define (tests:filter-test-names test-names test-patts)
(delete-duplicates
(filter (lambda (testname)
(tests:match test-patts testname #f))
test-names)))
;; tests:glob-like-match
(define (tests:glob-like-match patt str)
(let ((like (substring-index "%" patt)))
(let* ((notpatt (equal? (substring-index "~" patt) 0))
(newpatt (if notpatt (substring patt 1) patt))
(finpatt (if like
|
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
|
(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 "%" "*")))))
(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 system-allowed)
(let* ((test-path (conc *toppath* "/tests/" test-name))
(test-configf (conc test-path "/testconfig"))
(testexists (and (file-exists? test-configf)(file-read-access? test-configf))))
(if testexists
(read-config test-configf #f system-allowed environ-patt: (if system-allowed
|
|
|
|
|
|
|
|
|
|
|
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
|
(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 "%" "*")))))
;; (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 system-allowed)
(let* ((test-path (conc *toppath* "/tests/" test-name))
(test-configf (conc test-path "/testconfig"))
(testexists (and (file-exists? test-configf)(file-read-access? test-configf))))
(if testexists
(read-config test-configf #f system-allowed environ-patt: (if system-allowed
|