209
210
211
212
213
214
215
216
217
218
219
220
221
222
|
;; now add non-directly referenced dependencies (i.e. waiton)
(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
(let* ((config (tests:get-testconfig hed 'return-procs))
(waitons (string-split (let ((w (config-lookup config "requirements" "waiton")))
(if w w "")))))
;; (items (items:get-items-from-config config)))
(if (not (hash-table-ref/default test-records hed #f))
(hash-table-set! test-records
hed (vector hed ;; 0
config ;; 1
waitons ;; 2
(config-lookup config "requirements" "priority") ;; priority 3
|
>
>
>
>
>
>
>
|
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
|
;; now add non-directly referenced dependencies (i.e. waiton)
(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
(let* ((config (tests:get-testconfig hed 'return-procs))
(waitons (string-split (let ((w (config-lookup config "requirements" "waiton")))
(if w w "")))))
;; check for hed in waitons => this would be circular, remove it and issue an
;; error
(if (member hed waitons)
(begin
(debug:print 0 "ERROR: test " hed " has listed itself as a waiton, please correct this!")
(set! waitons (filter (lambda (x)(not (equal? x hed))) waitons))))
;; (items (items:get-items-from-config config)))
(if (not (hash-table-ref/default test-records hed #f))
(hash-table-set! test-records
hed (vector hed ;; 0
config ;; 1
waitons ;; 2
(config-lookup config "requirements" "priority") ;; priority 3
|
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
|
(and (vector? test) ;; not (string? test))
(not (member (db:test-get-status test)
'("PASS" "WARN" "CHECK" "WAIVED")))))
prereqs-not-met))))
(debug:print 6
"itemdat: " itemdat
"\n items: " items
"\n item-path: " item-path)
(cond
((not items) ;; when false the test is ok to be handed off to launch (but not before)
(let* ((have-resources (runs:can-run-more-tests db test-record)) ;; look at the test jobgroup and tot jobs running
(prereqs-not-met (db:get-prereqs-not-met db run-id waitons item-path))
(fails (calc-fails prereqs-not-met)))
(debug:print 8 "INFO: have-resources: " have-resources " prereqs-not-met: " prereqs-not-met " fails: " fails)
;; Don't know at this time if the test have been launched at some time in the past
;; i.e. is this a re-launch?
(cond
((and have-resources
(null? prereqs-not-met))
|
|
>
>
>
>
>
>
>
>
>
|
|
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
|
(and (vector? test) ;; not (string? test))
(not (member (db:test-get-status test)
'("PASS" "WARN" "CHECK" "WAIVED")))))
prereqs-not-met))))
(debug:print 6
"itemdat: " itemdat
"\n items: " items
"\n item-path: " item-path
"\n waitons: " waitons)
;; check for hed in waitons => this would be circular, remove it and issue an
;; error
(if (member hed waitons)
(begin
(debug:print 0 "ERROR: test " hed " has listed itself as a waiton, please correct this!")
(set! waiton (filter (lambda (x)(not (equal? x hed))) waitons))))
(cond
((not items) ;; when false the test is ok to be handed off to launch (but not before)
(let* ((have-resources (runs:can-run-more-tests db test-record)) ;; look at the test jobgroup and tot jobs running
(prereqs-not-met (db:get-prereqs-not-met db run-id waitons item-path mode: (config-lookup tconfig "requirements" "testmode")))
(fails (calc-fails prereqs-not-met)))
(debug:print 8 "INFO: have-resources: " have-resources " prereqs-not-met: " prereqs-not-met " fails: " fails)
;; Don't know at this time if the test have been launched at some time in the past
;; i.e. is this a re-launch?
(cond
((and have-resources
(null? prereqs-not-met))
|
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
|
(if (not (null? tal))
(loop (car tal)(cdr tal))))
;; if items is a proc then need to run items:get-items-from-config, get the list and loop
;; - but only do that if resources exist to kick off the job
((or (procedure? items)(eq? items 'have-procedure))
(let* ((can-run-more (runs:can-run-more-tests db test-record))
(prereqs-not-met (db:get-prereqs-not-met db run-id waitons item-path))
(fails (calc-fails prereqs-not-met)))
(debug:print 8 "INFO: can-run-more: " can-run-more
" prereqs-not-met:\n " (intersperse prereqs-not-met "\n")
" fails:\n " (intersperse fails "\n"))
(cond
((and can-run-more (null? prereqs-not-met))
(let ((test-name (tests:testqueue-get-testname test-record)))
|
|
|
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
|
(if (not (null? tal))
(loop (car tal)(cdr tal))))
;; if items is a proc then need to run items:get-items-from-config, get the list and loop
;; - but only do that if resources exist to kick off the job
((or (procedure? items)(eq? items 'have-procedure))
(let* ((can-run-more (runs:can-run-more-tests db test-record))
(prereqs-not-met (db:get-prereqs-not-met db run-id waitons item-path mode: (config-lookup tconfig "requirements" "testmode")))
(fails (calc-fails prereqs-not-met)))
(debug:print 8 "INFO: can-run-more: " can-run-more
" prereqs-not-met:\n " (intersperse prereqs-not-met "\n")
" fails:\n " (intersperse fails "\n"))
(cond
((and can-run-more (null? prereqs-not-met))
(let ((test-name (tests:testqueue-get-testname test-record)))
|