264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
|
(let ((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 (or (not max-concurrent-jobs)
(and max-concurrent-jobs
(string->number max-concurrent-jobs)
(not (>= num-running (string->number max-concurrent-jobs)))))
(run-one-test db run-id test-name keyvallst)
(print "WARNING: Max running jobs exceeded, current number running: " num-running
", max_concurrent_jobs: \"" max-concurrent-jobs "\""))))
test-names)
(if (args:get-arg "-keepgoing")
(let ((estrem (db:estimated-tests-remaining db run-id)))
(if (> estrem 0)
(begin
(print "Keep going, estimated " estrem " tests remaining to run, will continue in 10 seconds ...")
(sleep 10)
;; (run-waiting-tests db)
(loop (+ numtimes 1)))))))))
;; VERY INEFFICIENT! Move stuff that should be done once up to calling proc
(define (run-one-test db run-id test-name keyvallst)
(run-waiting-tests db)
(print "Launching test " test-name)
;; All these vars might be referenced by the testconfig file reader
(setenv "MT_TEST_NAME" test-name) ;;
(setenv "MT_RUNNAME" (args:get-arg ":runname"))
(set-megatest-env-vars db run-id) ;; these may be needed by the launching process
(change-directory *toppath*)
(let* ((test-path (conc *toppath* "/tests/" test-name))
|
|
>
<
|
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
|
(let ((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 (or (not max-concurrent-jobs)
(and max-concurrent-jobs
(string->number max-concurrent-jobs)
(not (>= num-running (string->number max-concurrent-jobs)))))
(run-one-test db run-id test-name keyvallst)
(print "WARNING: Max running jobs exceeded, current number running: " num-running
", max_concurrent_jobs: \"" max-concurrent-jobs "\""))))
test-names)
(run-waiting-tests db)
(if (args:get-arg "-keepgoing")
(let ((estrem (db:estimated-tests-remaining db run-id)))
(if (> estrem 0)
(begin
(print "Keep going, estimated " estrem " tests remaining to run, will continue in 10 seconds ...")
(sleep 10)
;; (run-waiting-tests db)
(loop (+ numtimes 1)))))))))
;; VERY INEFFICIENT! Move stuff that should be done once up to calling proc
(define (run-one-test db run-id test-name keyvallst)
(print "Launching test " test-name)
;; All these vars might be referenced by the testconfig file reader
(setenv "MT_TEST_NAME" test-name) ;;
(setenv "MT_RUNNAME" (args:get-arg ":runname"))
(set-megatest-env-vars db run-id) ;; these may be needed by the launching process
(change-directory *toppath*)
(let* ((test-path (conc *toppath* "/tests/" test-name))
|
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
|
;; 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)
|
>
>
|
|
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
|
;; 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 (not (null? items))(equal? item-path "")))
(single-test (and (null? items) (equal? item-path "")))
(item-test (not (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)
|
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
|
'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"))
|
|
>
|
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
|
'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
;; i.e. this is the parent test to a suite of items, never "run" it
(parent-test
(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"))
|