| ︙ | | | ︙ | |
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) 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)
|
| ︙ | | | ︙ | |
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
|
(if (null? tal)
(string-intersperse (append (reverse res)(list qry)) " OR ")
(loop (car tal)(cdr tal)(cons qry res)))))))
#f))
;; Check for waiver eligibility
;;
(define (tests:check-waiver-eligibility testdat prev-testdat)
(let* ((test-registry (make-hash-table))
(testconfig (tests:get-testconfig (db:test-get-testname testdat) test-registry #f))
(test-rundir ;; (sdb:qry 'passstr
(db:test-get-rundir testdat)) ;; )
(prev-rundir ;; (sdb:qry 'passstr
(db:test-get-rundir prev-testdat)) ;; )
(waivers (configf:section-vars testconfig "waivers"))
(waiver-rx (regexp "^(\\S+)\\s+(.*)$"))
(diff-rule "diff %file1% %file2%")
|
|
|
|
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
|
(if (null? tal)
(string-intersperse (append (reverse res)(list qry)) " OR ")
(loop (car tal)(cdr tal)(cons qry res)))))))
#f))
;; Check for waiver eligibility
;;
(define (tests:check-waiver-eligibility testdat prev-testdat area-dat)
(let* ((test-registry (make-hash-table))
(testconfig (tests:get-testconfig (db:test-get-testname testdat) test-registry #f area-dat))
(test-rundir ;; (sdb:qry 'passstr
(db:test-get-rundir testdat)) ;; )
(prev-rundir ;; (sdb:qry 'passstr
(db:test-get-rundir prev-testdat)) ;; )
(waivers (configf:section-vars testconfig "waivers"))
(waiver-rx (regexp "^(\\S+)\\s+(.*)$"))
(diff-rule "diff %file1% %file2%")
|
| ︙ | | | ︙ | |
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
|
(if comment
comment
prev-comment) ;; waived is either the comment or #f
#f))
#f)
#f)))
(if (and waived
(tests:check-waiver-eligibility testdat prev-test))
(set! real-status "WAIVED"))
(debug:print 4 "real-status " real-status ", waived " waived ", status " status)
;; update the primary record IF state AND status are defined
(if (and state status)
(begin
|
|
|
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
|
(if comment
comment
prev-comment) ;; waived is either the comment or #f
#f))
#f)
#f)))
(if (and waived
(tests:check-waiver-eligibility testdat prev-test area-dat))
(set! real-status "WAIVED"))
(debug:print 4 "real-status " real-status ", waived " waived ", status " status)
;; update the primary record IF state AND status are defined
(if (and state status)
(begin
|
| ︙ | | | ︙ | |
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)))
|
| ︙ | | | ︙ | |
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
|
(let* ((test-record (hash-table-ref testrecordshash testkeyname))
(test-name (tests:testqueue-get-testname test-record))
(itemdat (tests:testqueue-get-itemdat test-record))
(item-path (tests:testqueue-get-item_path test-record))
(waitons (tests:testqueue-get-waitons test-record))
(keep-test #t)
(test-id (rmt:get-test-id run-id test-name item-path))
(tdat (rmt:get-testinfo-state-status run-id test-id))) ;; (cdb:get-test-info-by-id *runremote* test-id)))
(if tdat
(begin
;; Look at the test state and status
(if (or (and (member (db:test-get-status tdat)
'("PASS" "WARN" "WAIVED" "CHECK" "SKIP"))
(equal? (db:test-get-state tdat) "COMPLETED"))
(member (db:test-get-state tdat)
'("INCOMPLETE" "KILLED")))
(set! keep-test #f))
;; examine waitons for any fails. If it is FAIL or INCOMPLETE then eliminate this test
;; 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 *runremote* 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) '("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
waitons))))
(if keep-test (set! runnables (cons testkeyname runnables)))))
testkeynames)
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
|
|
|
|
|
|
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
|
(let* ((test-record (hash-table-ref testrecordshash testkeyname))
(test-name (tests:testqueue-get-testname test-record))
(itemdat (tests:testqueue-get-itemdat test-record))
(item-path (tests:testqueue-get-item_path test-record))
(waitons (tests:testqueue-get-waitons test-record))
(keep-test #t)
(test-id (rmt:get-test-id run-id test-name item-path))
(tdat (rmt:get-testinfo-state-status run-id test-id))) ;; (cdb:get-test-info-by-id (common:get-remote remote) test-id)))
(if tdat
(begin
;; Look at the test state and status
(if (or (and (member (db:test-get-status tdat)
'("PASS" "WARN" "WAIVED" "CHECK" "SKIP"))
(equal? (db:test-get-state tdat) "COMPLETED"))
(member (db:test-get-state tdat)
'("INCOMPLETE" "KILLED")))
(set! keep-test #f))
;; examine waitons for any fails. If it is FAIL or INCOMPLETE then eliminate this test
;; 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) '("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
waitons))))
(if keep-test (set! runnables (cons testkeyname runnables)))))
testkeynames)
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 area-dat)
(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 area-dat))
(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
|
| ︙ | | | ︙ | |