425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
|
(debug:print-info 4 *default-log-port* "test-records=" (hash-table->alist test-records))
(let ((reglen (configf:lookup *configdat* "setup" "runqueue")))
(if (> (length (hash-table-keys test-records)) 0)
(let* ((keep-going #t)
(run-queue-retries 5)
(th1 (make-thread (lambda ()
(runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests (any->number reglen) all-tests-registry))
;; (common:debug-handle-exceptions #t
;; exn
;; (begin
;; (print-call-chain (current-error-port))
;; (debug:print-error 0 *default-log-port* "failure in runs:run-tests-queue thread, error: " ((condition-property-accessor 'exn 'message) exn))
;; (if (> run-queue-retries 0)
;; (begin
;; (set! run-queue-retries (- run-queue-retries 1))
;; (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests (any->number reglen) all-tests-registry))))
;; (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests (any->number reglen) all-tests-registry)))
"runs:run-tests-queue"))
(th2 (make-thread (lambda ()
;; (rmt:find-and-mark-incomplete-all-runs))))) CAN'T INTERRUPT IT ...
(let ((run-ids (rmt:get-all-run-ids)))
(for-each (lambda (run-id)
(if keep-going
(common:debug-handle-exceptions #t
exn
(debug:print 0 *default-log-port* "error in calling find-and-mark-incomplete for run-id " run-id)
(rmt:find-and-mark-incomplete run-id #f)))) ;; ovr-deadtime)))
run-ids)))
"runs: mark-incompletes")))
(thread-start! th1)
(thread-start! th2)
|
|
|
|
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
|
(debug:print-info 4 *default-log-port* "test-records=" (hash-table->alist test-records))
(let ((reglen (configf:lookup *configdat* "setup" "runqueue")))
(if (> (length (hash-table-keys test-records)) 0)
(let* ((keep-going #t)
(run-queue-retries 5)
(th1 (make-thread (lambda ()
(runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests (any->number reglen) all-tests-registry))
;; (handle-exceptions
;; exn
;; (begin
;; (print-call-chain (current-error-port))
;; (debug:print-error 0 *default-log-port* "failure in runs:run-tests-queue thread, error: " ((condition-property-accessor 'exn 'message) exn))
;; (if (> run-queue-retries 0)
;; (begin
;; (set! run-queue-retries (- run-queue-retries 1))
;; (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests (any->number reglen) all-tests-registry))))
;; (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests (any->number reglen) all-tests-registry)))
"runs:run-tests-queue"))
(th2 (make-thread (lambda ()
;; (rmt:find-and-mark-incomplete-all-runs))))) CAN'T INTERRUPT IT ...
(let ((run-ids (rmt:get-all-run-ids)))
(for-each (lambda (run-id)
(if keep-going
(handle-exceptions
exn
(debug:print 0 *default-log-port* "error in calling find-and-mark-incomplete for run-id " run-id)
(rmt:find-and-mark-incomplete run-id #f)))) ;; ovr-deadtime)))
run-ids)))
"runs: mark-incompletes")))
(thread-start! th1)
(thread-start! th2)
|
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
|
(debug:print 0 *default-log-port* "WARNING: test dir " real-dir " appears to not exist or is not readable")))
(if real-dir
(debug:print 0 *default-log-port* "WARNING: directory " real-dir " does not exist")
(debug:print 0 *default-log-port* "WARNING: no real directory corrosponding to link " run-dir ", nothing done")))
(if (symbolic-link? run-dir)
(begin
(debug:print-info 1 *default-log-port* "Removing symlink " run-dir)
(common:debug-handle-exceptions #t
exn
(debug:print-error 0 *default-log-port* " Failed to remove symlink " run-dir ((condition-property-accessor 'exn 'message) exn) ", attempting to continue")
(delete-file run-dir)))
(if (directory? run-dir)
(if (> (directory-fold (lambda (f x)(+ 1 x)) 0 run-dir) 0)
(debug:print 0 *default-log-port* "WARNING: refusing to remove " run-dir " as it is not empty")
(common:debug-handle-exceptions #t
exn
(debug:print-error 0 *default-log-port* " Failed to remove directory " run-dir ((condition-property-accessor 'exn 'message) exn) ", attempting to continue")
(delete-directory run-dir)))
(if (and run-dir
(not (member run-dir (list "n/a" "/tmp/badname"))))
(debug:print 0 *default-log-port* "WARNING: not removing " run-dir " as it either doesn't exist or is not a symlink")
(debug:print 0 *default-log-port* "NOTE: the run dir for this test is undefined. Test may have already been deleted."))
|
|
|
|
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
|
(debug:print 0 *default-log-port* "WARNING: test dir " real-dir " appears to not exist or is not readable")))
(if real-dir
(debug:print 0 *default-log-port* "WARNING: directory " real-dir " does not exist")
(debug:print 0 *default-log-port* "WARNING: no real directory corrosponding to link " run-dir ", nothing done")))
(if (symbolic-link? run-dir)
(begin
(debug:print-info 1 *default-log-port* "Removing symlink " run-dir)
(handle-exceptions
exn
(debug:print-error 0 *default-log-port* " Failed to remove symlink " run-dir ((condition-property-accessor 'exn 'message) exn) ", attempting to continue")
(delete-file run-dir)))
(if (directory? run-dir)
(if (> (directory-fold (lambda (f x)(+ 1 x)) 0 run-dir) 0)
(debug:print 0 *default-log-port* "WARNING: refusing to remove " run-dir " as it is not empty")
(handle-exceptions
exn
(debug:print-error 0 *default-log-port* " Failed to remove directory " run-dir ((condition-property-accessor 'exn 'message) exn) ", attempting to continue")
(delete-directory run-dir)))
(if (and run-dir
(not (member run-dir (list "n/a" "/tmp/badname"))))
(debug:print 0 *default-log-port* "WARNING: not removing " run-dir " as it either doesn't exist or is not a symlink")
(debug:print 0 *default-log-port* "NOTE: the run dir for this test is undefined. Test may have already been deleted."))
|