248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
|
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
|
+
+
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
|
tests)
res))
(define (runs:can-run-more-tests db)
(let ((num-running (db:get-count-tests-running db))
(max-concurrent-jobs (config-lookup *configdat* "setup" "max_concurrent_jobs")))
(debug:print 2 "max-concurrent-jobs: " max-concurrent-jobs ", num-running: " num-running)
(if (not (eq? 0 *globalexitstatus*))
#f
(if (or (not max-concurrent-jobs)
(and max-concurrent-jobs
(string->number max-concurrent-jobs)
(not (>= num-running (string->number max-concurrent-jobs)))))
#t
(begin
(debug:print 0 "WARNING: Max running jobs exceeded, current number running: " num-running
", max_concurrent_jobs: " max-concurrent-jobs)
#f))))
|
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
|
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
|
-
+
+
-
+
+
|
(set! *passnum* (+ *passnum* 1))
(let loop ((numtimes 0))
(for-each
(lambda (test-name)
(if (runs:can-run-more-tests db)
(run-one-test db run-id test-name keyvallst)
;; add some delay
(sleep 2)))
;(sleep 2)
))
test-names)
;; (run-waiting-tests db)
(if (args:get-arg "-keepgoing")
(let ((estrem (db:estimated-tests-remaining db run-id)))
(if (> estrem 0)
(if (and (> estrem 0)
(eq? *globalexitstatus* 0))
(begin
(debug:print 1 "Keep going, estimated " estrem " tests remaining to run, will continue in 3 seconds ...")
(sleep 3)
(run-waiting-tests db)
(loop (+ numtimes 1)))))))))
;; VERY INEFFICIENT! Move stuff that should be done once up to calling proc
|
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
|
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
|
-
+
+
+
+
+
|
(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...
((cadr testrundat)) ;; this is the line that launches the test to the remote host
(if (not ((cadr testrundat))) ;; this is the line that launches the test to the remote host
(begin
(print "ERROR: Failed to launch the test. Exiting as soon as possible")
(set! *globalexitstatus* 1) ;;
(exit 1)))
(if (not (args:get-arg "-keepgoing"))
(hash-table-set! *waiting-queue* new-test-name testrundat)))))))
((KILLED)
(debug:print 1 "NOTE: " new-test-name " is already running or was explictly killed, use -force to launch it."))
((LAUNCHED REMOTEHOSTSTART RUNNING)
(if (> (- (current-seconds)(+ (db:test-get-event_time testdat)
(db:test-get-run_duration testdat)))
|