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
|
(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 cadr (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
462
463
464
|
(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
"pre-launch-env-vars"
#f))
#f)))
|
|
|
|
|
|
|
|
|
|
|
|
|
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
|
(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 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))))
(if testexists
(read-config test-configf #f system-allowed environ-patt: (if system-allowed
"pre-launch-env-vars"
#f))
#f)))
|
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
|
runnables))
;;======================================================================
;; refactoring this block into tests:get-full-data from line 263 of runs.scm
;;======================================================================
;; hed is the test name
;; test-records is a hash of test-name => test record
(define (tests:get-full-data test-names test-records required-tests)
(if (not (null? test-names))
(let loop ((hed (car test-names))
(tal (cdr test-names))) ;; 'return-procs tells the config reader to prep running system but return a proc
(debug:print-info 4 "hed=" hed " at top of loop")
(let* ((config (tests:get-testconfig hed 'return-procs))
(waitons (let ((instr (if config
(config-lookup config "requirements" "waiton")
(begin ;; No config means this is a non-existant test
(debug:print 0 "ERROR: non-existent required test \"" hed "\", grep through your testconfigs to find and remove or create the test. Discarding and continuing.")
""))))
(debug:print-info 8 "waitons string is " instr)
(string-split (cond
|
|
|
|
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
|
runnables))
;;======================================================================
;; refactoring this block into tests:get-full-data from line 263 of runs.scm
;;======================================================================
;; hed is the test name
;; test-records is a hash of test-name => test record
(define (tests:get-full-data test-names test-records required-tests all-tests-registry)
(if (not (null? test-names))
(let loop ((hed (car test-names))
(tal (cdr test-names))) ;; 'return-procs tells the config reader to prep running system but return a proc
(debug:print-info 4 "hed=" hed " at top of loop")
(let* ((config (tests:get-testconfig hed all-tests-registry 'return-procs))
(waitons (let ((instr (if config
(config-lookup config "requirements" "waiton")
(begin ;; No config means this is a non-existant test
(debug:print 0 "ERROR: non-existent required test \"" hed "\", grep through your testconfigs to find and remove or create the test. Discarding and continuing.")
""))))
(debug:print-info 8 "waitons string is " instr)
(string-split (cond
|