166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
|
(items:get-items-from-config tconfig))
(else #f)))) ;; not iterated
;; returns waitons waitors tconfigdat
;;
(define (tests:get-waitons test-name all-tests-registry)
(let* ((config (tests:get-testconfig test-name #f all-tests-registry 'return-procs))) ;; assuming no problems with immediate evaluation, this could be simplified ('return-procs -> #t)
(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 \"" test-name "\"")
(exit 1))))
(instr2 (if config
(configf:lookup config "requirements" "waitor")
|
|
|
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
|
(items:get-items-from-config tconfig))
(else #f)))) ;; not iterated
;; returns waitons waitors tconfigdat
;;
(define (tests:get-waitons test-name all-tests-registry)
(let* ((config (tests:get-testconfig test-name #f all-tests-registry #t))) ;;'return-procs))) ;; assuming no problems with immediate evaluation, this could be simplified ('return-procs -> #t)
(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 \"" test-name "\"")
(exit 1))))
(instr2 (if config
(configf:lookup config "requirements" "waitor")
|
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
|
(getenv "MT_TARGET") "/"
(getenv "MT_RUNNAME") "/"
test-name "/" item-path))
(local-tcfg (conc local-tcdir "/testconfig")))
(if (common:file-exists? local-tcfg)
local-tcdir
#f))
(conc *toppath* "/tests/" test-name)))
(test-configf (conc test-path "/testconfig"))
(testexists (let loopa ((tries-left 30))
(cond
(
(and (common:file-exists? test-configf)(file-read-access? test-configf))
(
(common:file-exists? test-configf)
(
(and wait-a-minute (> tries-left 0))
(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
#f))))
(tcfg (if testexists
(read-config test-configf #f system-allowed
environ-patt: (if system-allowed
"pre-launch-env-vars"
#f))
#f)))
(if (and tcfg cache-file) (hash-table-set! tcfg "have fulldata" #t)) ;; mark this as fully read data
(if tcfg (hash-table-set! *testconfigs* test-full-name tcfg))
(if (and testexists
|
>
>
|
>
<
|
<
|
<
|
|
>
|
|
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
|
(getenv "MT_TARGET") "/"
(getenv "MT_RUNNAME") "/"
test-name "/" item-path))
(local-tcfg (conc local-tcdir "/testconfig")))
(if (common:file-exists? local-tcfg)
local-tcdir
#f))
(begin
(debug:print-info 0 *default-log-port* "reading testconfig for "test-full-name" from tests/"test-name" directory.")
(conc *toppath* "/tests/" test-name)) ;; should this fallback exist?
))
(test-configf (conc test-path "/testconfig"))
(testexists (let loopa ((tries-left 30))
(cond
((and (common:file-exists? test-configf)(file-read-access? test-configf))
#t)
((common:file-exists? test-configf)
(debug:print 0 *default-log-port* "WARNING: Cannot read testconfig file: "test-configf)
#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
#f))))
(tcfg (if testexists
(configf:read-file test-configf #f system-allowed
environ-patt: (if system-allowed
"pre-launch-env-vars"
#f))
#f)))
(if (and tcfg cache-file) (hash-table-set! tcfg "have fulldata" #t)) ;; mark this as fully read data
(if tcfg (hash-table-set! *testconfigs* test-full-name tcfg))
(if (and testexists
|