dmbcs/mcron
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

base: Rewrite 'run-job-loop'.

Browse source 
* src/mcron/base.scm (run-job-loop): Use #:optional keyword argument, and
'match'.
This commit is contained in:
Mathieu Lirzin 2016-07-18 14:32:52 +02:00
commit 74babba80e
No known key found for this signature in database
GPG key ID: 0ADEE10094604D37
1 changed files with 33 additions and 44 deletions
Download patch file Download diff file Expand all files Collapse all files

71
src/mcron/base.scm
View file

@ -20,6 +20,7 @@
(define-module (mcron base) (define-module (mcron base)
#:use-module (ice-9 match)
#:use-module (mcron environment) #:use-module (mcron environment)
#:use-module (srfi srfi-9) #:use-module (srfi srfi-9)
#:export (add-job #:export (add-job
@ -225,50 +226,38 @@
(eqv? (car (waitpid WAIT_ANY WNOHANG)) 0))) (eqv? (car (waitpid WAIT_ANY WNOHANG)) 0)))
(set! number-children (- number-children 1)))) (set! number-children (- number-children 1))))
(define* (run-job-loop #:optional fd-list)
;; Loop over all job specifications, get a list of the next ones to run (may
;; Now the main loop. Loop over all job specifications, get a list of the next ;; be more than one). Set an alarm and go to sleep. When we wake, run the
;; ones to run (may be more than one). Set an alarm and go to sleep. When we ;; jobs and reap any children (old jobs) that have completed. Repeat ad
;; wake, run the jobs and reap any children (old jobs) that have ;; infinitum.
;; completed. Repeat ad infinitum. ;;
;; ;; Note that, if we wake ahead of time, it can only mean that a signal has
;; Note that, if we wake ahead of time, it can only mean that a signal has been ;; been sent by a crontab job to tell us to re-read a crontab file. In this
;; sent by a crontab job to tell us to re-read a crontab file. In this case we ;; case we break out of the loop here, and let the main procedure deal with
;; break out of the loop here, and let the main procedure deal with the ;; the situation (it will eventually re-call this function, thus maintaining
;; situation (it will eventually re-call this function, thus maintaining the ;; the loop).
;; loop).
(define (run-job-loop . fd-list)
(call-with-current-continuation (call-with-current-continuation
(lambda (break) (lambda (break)
(let ((fd-list (if (null? fd-list) '() (car fd-list))))
(let loop () (let loop ()
(match (find-next-jobs)
(let* ((next-jobs (find-next-jobs)) ((next-time . next-jobs-lst)
(next-time (car next-jobs)) (let ((sleep-time (if next-time
(next-jobs-list (cdr next-jobs)) (- next-time (current-time))
(sleep-time (if next-time (- next-time (current-time))
2000000000))) 2000000000)))
(when (and
(and (> sleep-time 0) (> sleep-time 0)
(if (not (null? (not (null? (catch 'system-error
(catch 'system-error (λ ()
(lambda ()
(car (select fd-list '() '() sleep-time))) (car (select fd-list '() '() sleep-time)))
(lambda (key . args) ;; Exception add by Sergey (λ (key . args)
;; Poznyakoff. (let ((err (car (last args))))
(if (member (car (last args)) (cond ((member err (list EINTR EAGAIN))
(list EINTR EAGAIN))
(begin
(child-cleanup) '())
(apply throw key args))))))
(break)))
(run-jobs next-jobs-list)
(child-cleanup) (child-cleanup)
'())
(loop))))))) (else
(apply throw key args)))))))))
(break))
(run-jobs next-jobs-lst)
(child-cleanup)
(loop))))))))