From 74babba80ef6c2084035e1bc5d78d31021341cb6 Mon Sep 17 00:00:00 2001
From: Mathieu Lirzin <mthl@gnu.org>
Date: Mon, 18 Jul 2016 14:32:52 +0200
Subject: base: Rewrite 'run-job-loop'.

* src/mcron/base.scm (run-job-loop): Use #:optional keyword argument, and
'match'.
---
 src/mcron/base.scm | 77 +++++++++++++++++++++++-------------------------------
 1 file changed, 33 insertions(+), 44 deletions(-)

(limited to 'src/mcron/base.scm')

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