134
135
136
137
138
139
140
141
142
143
144
145
146
147
|
;; (debug:print 0 *default-log-port* "res=" res)
(cond
((string? res) res) ;;; FIX THE ROOT CAUSE HERE ....
((null? res) #f)
((string? (cdr res)) (cdr res)) ;; it is a pair
((string? (cadr res))(cadr res)) ;; it is a list
(else cadr res))))))
;; return items given config
;;
(define (tests:get-items tconfig)
(let ((items (hash-table-ref/default tconfig "items" #f)) ;; items 4
(itemstable (hash-table-ref/default tconfig "itemstable" #f)))
;; if either items or items table is a proc return it so test running
|
>
>
>
>
>
>
|
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
|
;; (debug:print 0 *default-log-port* "res=" res)
(cond
((string? res) res) ;;; FIX THE ROOT CAUSE HERE ....
((null? res) #f)
((string? (cdr res)) (cdr res)) ;; it is a pair
((string? (cadr res))(cadr res)) ;; it is a list
(else cadr res))))))
(define (tests:get-global-waitons rconfig)
(let* ((global-waitons (runconfigs-get config "!GLOBAL_WAITONS")))
(if (string? global-waitons)
(string-split global-waitons)
'())))
;; return items given config
;;
(define (tests:get-items tconfig)
(let ((items (hash-table-ref/default tconfig "items" #f)) ;; items 4
(itemstable (hash-table-ref/default tconfig "itemstable" #f)))
;; if either items or items table is a proc return it so test running
|
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
|
" items: " items " itemstable: " itemstable)
(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")
"")))
(debug:print-info 8 *default-log-port* "waitons string is " instr ", waitors string is " instr2)
(let ((newwaitons
(string-split (cond
((procedure? instr) ;; here
(let ((res (instr)))
(debug:print-info 8 *default-log-port* "waiton procedure results in string " res " for test " test-name)
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 " test-name)
""))))
(newwaitors
(string-split (cond
((procedure? instr2)
(let ((res (instr2)))
(debug:print-info 8 *default-log-port* "waitor procedure results in string " res " for test " test-name)
res))
((string? instr2) instr2)
(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 " test-name)
"")))))
(values
;; the waitons
(filter (lambda (x)
(if (hash-table-ref/default all-tests-registry x #f)
#t
(begin
(debug:print-error 0 *default-log-port* "test " test-name " has unrecognised waiton testname " x)
|
|
|
|
>
>
>
|
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
|
" items: " items " itemstable: " itemstable)
(items:get-items-from-config tconfig))
(else #f)))) ;; not iterated
;; returns waitons waitors tconfigdat
;;
(define (tests:get-waitons test-name all-tests-registry global-waitons)
(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")
"")))
(debug:print-info 8 *default-log-port* "waitons string is " instr ", waitors string is " instr2)
(let ((newwaitons-tmp
(string-split (cond
((procedure? instr) ;; here
(let ((res (instr)))
(debug:print-info 8 *default-log-port* "waiton procedure results in string " res " for test " test-name)
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 " test-name)
""))))
(newwaitors
(string-split (cond
((procedure? instr2)
(let ((res (instr2)))
(debug:print-info 8 *default-log-port* "waitor procedure results in string " res " for test " test-name)
res))
((string? instr2) instr2)
(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 " test-name)
""))))
(newwaitons (if global-waitons
(append newwaitons-tmp global-waitons)
newwaitons-tmp)))
(values
;; the waitons
(filter (lambda (x)
(if (hash-table-ref/default all-tests-registry x #f)
#t
(begin
(debug:print-error 0 *default-log-port* "test " test-name " has unrecognised waiton testname " x)
|