| ︙ | | |
51
52
53
54
55
56
57
58
59
60
61
62
63
64
|
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
|
+
|
;; Call this one to do all the work and get a standardized list of tests
;; gets paths from configs and finds valid tests
;; returns hash of testname --> fullpath
;;
(define (tests:get-all)
(let* ((test-search-path (tests:get-tests-search-path *configdat*)))
(debug:print 8 *default-log-port* "test-search-path: " test-search-path)
(tests:get-valid-tests (make-hash-table) test-search-path)))
(define (tests:get-tests-search-path cfgdat)
(let ((paths (let ((section (if cfgdat
(configf:get-section cfgdat "tests-paths")
#f)))
(if section
|
| ︙ | | |
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
|
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
|
-
+
|
(tests:dashboard-body page pg-size keys numkeys total-runs linktree area-name get-prev-links get-next-links #f run-patt target-patt)) ;; update this function
(close-output-port oup)
; (set! page (+ 1 page))
(if (> total-runs (* (+ 1 page) pg-size))
(loop (+ 1 page)))))
(common:simple-file-release-lock lockfile))
(begin
(debug-print 0 *default-log-port* "Failed to get lock on file outf, lockfile: " lockfile) #f))))
(debug:print 0 *default-log-port* "Failed to get lock on file outf, lockfile: " lockfile) #f))))
(define (tests:readlines filename)
(call-with-input-file filename
(lambda (p)
(let loop ((line (read-line p))
(result '()))
|
| ︙ | | |
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
|
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
|
-
+
|
#f)
(
(and wait-a-minute (> tries-left 0))
(thread-sleep! 10)
(debug:print 0 *default-log-port* "WARNING: testconfig file does not exist: "test-configf" will retry in 10 seconds. Tries left: "tries-left) ;; BB: this fires
(loopa (sub1 tries-left)))
(else
(debug:print 0 *default-log-port* "WARNING: testconfig file does not exist: "test-configf) ;; BB: this fires
(debug:print 2 *default-log-port* "WARNING: testconfig file does not exist: "test-configf) ;; BB: this fires
#f))))
(tcfg (if testexists
(read-config test-configf #f system-allowed
environ-patt: (if system-allowed
"pre-launch-env-vars"
#f))
#f)))
|
| ︙ | | |
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
|
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
|
+
-
+
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
|
;;======================================================================
;; 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)
(let ((missing-waitons (make-hash-table)))
(if (not (null? test-names))
(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 *default-log-port* "hed=" hed " at top of loop")
;; don't know item-path at this time, let the testconfig get the top level testconfig
(let* ((config (tests:get-testconfig hed #f all-tests-registry 'return-procs))
(waitons (let ((instr (if config
(configf:lookup config "requirements" "waiton")
(begin ;; No config means this is a non-existant test
(debug:print-error 0 *default-log-port* "non-existent required test \"" hed "\", grep through your testconfigs to find and remove or create the test. Discarding and continuing.")
""))))
(begin ;; No config means this is a non-existent test
(let ((waiters '()))
;; find the waiter(s) for this waiton.
(for-each
(lambda(waiter)
;; (print "test-record = " (hash-table-ref test-records waiter))
;; (print "waitons = " (vector-ref (hash-table-ref test-records waiter) 2))
(if (member hed (vector-ref (hash-table-ref test-records waiter) 2))
(set! waiters (cons waiter waiters))
)
)
(hash-table-keys test-records))
(hash-table-set! missing-waitons hed waiters)
)
""))))
(debug:print-info 8 *default-log-port* "waitons string is " instr)
(string-split (cond
((procedure? instr)
(let ((res (instr)))
(debug:print-info 8 *default-log-port* "waiton procedure results in string " res " for test " hed)
res))
((string? instr) instr)
(else
;; NOTE: This is actually the case of *no* waitons! ;; (debug:print-error 0 *default-log-port* "something went wrong in processing waitons for test " hed)
;; NOTE: This is actually the case of *no* waitons! ;;
""))))))
(if (not config) ;; this is a non-existant test called in a waiton.
(if (null? tal)
test-records
(loop (car tal)(cdr tal)))
(begin
(debug:print-info 8 *default-log-port* "waitons: " waitons)
|
| ︙ | | |
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
|
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
|
-
+
-
+
-
+
+
+
+
+
+
+
+
|
(debug:print-info 4 *default-log-port* "items and itemstable are lists, calc now\n"
" items: " items " itemstable: " itemstable)
(items:get-items-from-config config))
(else #f))) ;; not iterated
#f ;; itemsdat 5
#f ;; spare - used for item-path
)))
(for-each
(if (and waiton (not (member waiton test-names)))
(if (and waiton (not (string= "#f" waiton)) (not (member waiton test-names)))
(begin
(set! required-tests (cons waiton required-tests))
(set! test-names (cons waiton test-names))))) ;; was an append, now a cons
waitons)
(let ((remtests (delete-duplicates (append waitons tal))))
(if (not (null? remtests))
(loop (car remtests)(cdr remtests))
test-records))))))))
test-records)))))))
(for-each
(lambda (missing-waiton)
(debug:print-error 0 *default-log-port* "non-existent test \"" missing-waiton "\" is a waiton for tests " (hash-table-ref missing-waitons missing-waiton))
)
(hash-table-keys missing-waitons)
)
))
;;======================================================================
;; test steps
;;======================================================================
;; teststep-set-status! used to be here
|
| ︙ | | |