︙ | | | ︙ | |
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
|
(runconfigf (conc *toppath* "/runconfigs.config")))
(print "items: ")(pp allitems)
(if (args:get-arg "-m")
(db:set-comment-for-run db run-id (args:get-arg "-m")))
(let loop ((itemdat (car allitems))
(tal (cdr allitems)))
;; (lambda (itemdat) ;;; ((ripeness "overripe") (temperature "cool") (season "summer"))
(let* ((item-path (item-list->path itemdat)) ;; (string-intersperse (map cadr itemdat) "/"))
(new-test-path (string-intersperse (cons test-path (map cadr itemdat)) "/"))
(new-test-name (if (equal? item-path "") test-name (conc test-name "/" item-path))) ;; just need it to be unique
(testdat #f)
(num-running (db:get-count-tests-running db))
(max-concurrent-jobs (config-lookup *configdat* "setup" "max_concurrent_jobs")))
;; (print "max-concurrent-jobs: " max-concurrent-jobs ", num-running: " num-running)
(if (not (or (not max-concurrent-jobs)
(and max-concurrent-jobs
(string->number max-concurrent-jobs)
(not (>= num-running (string->number max-concurrent-jobs))))))
(print "WARNING: Max running jobs exceeded, current number running: " num-running
", max_concurrent_jobs: " max-concurrent-jobs)
|
>
|
>
|
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
|
(runconfigf (conc *toppath* "/runconfigs.config")))
(print "items: ")(pp allitems)
(if (args:get-arg "-m")
(db:set-comment-for-run db run-id (args:get-arg "-m")))
(let loop ((itemdat (car allitems))
(tal (cdr allitems)))
;; (lambda (itemdat) ;;; ((ripeness "overripe") (temperature "cool") (season "summer"))
;; Handle lists of items
(let* ((item-path (item-list->path itemdat)) ;; (string-intersperse (map cadr itemdat) "/"))
(new-test-path (string-intersperse (cons test-path (map cadr itemdat)) "/"))
(new-test-name (if (equal? item-path "") test-name (conc test-name "/" item-path))) ;; just need it to be unique
(testdat #f)
(num-running (db:get-count-tests-running db))
(max-concurrent-jobs (config-lookup *configdat* "setup" "max_concurrent_jobs"))
(parent-test (and (null? items)(equal? item-path ""))))
;; (print "max-concurrent-jobs: " max-concurrent-jobs ", num-running: " num-running)
(if (not (or (not max-concurrent-jobs)
(and max-concurrent-jobs
(string->number max-concurrent-jobs)
(not (>= num-running (string->number max-concurrent-jobs))))))
(print "WARNING: Max running jobs exceeded, current number running: " num-running
", max_concurrent_jobs: " max-concurrent-jobs)
|
︙ | | | ︙ | |
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
|
'NOT_STARTED
(if testdat
(string->symbol (test:get-state testdat))
'failed-to-insert))
((failed-to-insert)
(print "ERROR: Failed to insert the record into the db"))
((NOT_STARTED COMPLETED)
(print "Got here, " (test:get-state testdat))
(let ((runflag #f))
(cond
;; -force, run no matter what
((args:get-arg "-force")(set! runflag #t))
;; NOT_STARTED, run no matter what
((equal? (test:get-state testdat) "NOT_STARTED")(set! runflag #t))
;; not -rerun and PASS, WARN or CHECK, do no run
((and (or (not (args:get-arg "-rerun"))
(args:get-arg "-keepgoing"))
|
|
>
>
|
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
|
'NOT_STARTED
(if testdat
(string->symbol (test:get-state testdat))
'failed-to-insert))
((failed-to-insert)
(print "ERROR: Failed to insert the record into the db"))
((NOT_STARTED COMPLETED)
;; (print "Got here, " (test:get-state testdat))
(let ((runflag #f))
(cond
(parent-test ;; i.e. this is the parent test to a suite of items
(set! runflag #f))
;; -force, run no matter what
((args:get-arg "-force")(set! runflag #t))
;; NOT_STARTED, run no matter what
((equal? (test:get-state testdat) "NOT_STARTED")(set! runflag #t))
;; not -rerun and PASS, WARN or CHECK, do no run
((and (or (not (args:get-arg "-rerun"))
(args:get-arg "-keepgoing"))
|
︙ | | | ︙ | |
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
|
(set! runflag #f))
((and (not (args:get-arg "-rerun"))
(member (test:get-status testdat) '("FAIL" "n/a")))
(set! runflag #t))
(else (set! runflag #f)))
;; (print "RUNNING => runflag: " runflag " STATE: " (test:get-state testdat) " STATUS: " (test:get-status testdat))
(if (not runflag)
(print "NOTE: Not starting test " new-test-name " as it is state \"COMPLETED\" and status \"" (test:get-status testdat) "\", use -force to override")
(let* ((get-prereqs-cmd (lambda ()
(db-get-prereqs-not-met db run-id waiton))) ;; check before running ....
(launch-cmd (lambda ()
(launch-test db run-id test-conf keyvallst test-name test-path itemdat)))
(testrundat (list get-prereqs-cmd launch-cmd)))
(if (or (args:get-arg "-force")
(null? ((car testrundat)))) ;; are there any tests that must be run before this one...
|
>
|
|
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
|
(set! runflag #f))
((and (not (args:get-arg "-rerun"))
(member (test:get-status testdat) '("FAIL" "n/a")))
(set! runflag #t))
(else (set! runflag #f)))
;; (print "RUNNING => runflag: " runflag " STATE: " (test:get-state testdat) " STATUS: " (test:get-status testdat))
(if (not runflag)
(if (not parent-test)
(print "NOTE: Not starting test " new-test-name " as it is state \"COMPLETED\" and status \"" (test:get-status testdat) "\", use -force to override"))
(let* ((get-prereqs-cmd (lambda ()
(db-get-prereqs-not-met db run-id waiton))) ;; check before running ....
(launch-cmd (lambda ()
(launch-test db run-id test-conf keyvallst test-name test-path itemdat)))
(testrundat (list get-prereqs-cmd launch-cmd)))
(if (or (args:get-arg "-force")
(null? ((car testrundat)))) ;; are there any tests that must be run before this one...
|
︙ | | | ︙ | |
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
|
(begin
(print "Prerequisites met, launching " testname)
((cadr testdat))
(hash-table-delete! *waiting-queue* testname)))
(if (not db)
(sqlite3:finalize! ldb))))
waiting-test-names)
(sleep 10) ;; no point in rushing things at this stage?
(loop (hash-table-keys *waiting-queue*)))))))
(define (get-dir-up-one dir)
(let ((dparts (string-split dir "/")))
(conc "/" (string-intersperse
(take dparts (- (length dparts) 1))
"/"))))
|
|
|
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
|
(begin
(print "Prerequisites met, launching " testname)
((cadr testdat))
(hash-table-delete! *waiting-queue* testname)))
(if (not db)
(sqlite3:finalize! ldb))))
waiting-test-names)
;; (sleep 10) ;; no point in rushing things at this stage?
(loop (hash-table-keys *waiting-queue*)))))))
(define (get-dir-up-one dir)
(let ((dparts (string-split dir "/")))
(conc "/" (string-intersperse
(take dparts (- (length dparts) 1))
"/"))))
|
︙ | | | ︙ | |