From 011df9b8fd152554619f76ea1e35a68ef206762d Mon Sep 17 00:00:00 2001
From: dale_mellor <dale_mellor>
Date: Sun, 16 Apr 2006 22:10:43 +0000
Subject: Update to 1.0.3.  Lots of small changes, mainly to work with guile
 1.8.0.  Daylight savings time is now handled okay.  Bug fix in Vixie parser. 
 User gets option to correct bad crontab entries.

---
 mcron-core.scm | 67 +++++++++++++++++++++++++++++++++++++---------------------
 1 file changed, 43 insertions(+), 24 deletions(-)

(limited to 'mcron-core.scm')

diff --git a/mcron-core.scm b/mcron-core.scm
index 631311a..b8ca289 100644
--- a/mcron-core.scm
+++ b/mcron-core.scm
@@ -167,7 +167,7 @@
           ((eqv? count 0))
         (and-let* ((next-jobs (find-next-jobs))
                    (time (car next-jobs))
-                   (date-string (strftime "%c\n" (localtime time))))
+                   (date-string (strftime "%c %z\n" (localtime time))))
           (for-each (lambda (job)
                       (display date-string)
                       (display (job:displayable job))
@@ -214,6 +214,16 @@
 
 
 
+;; Give any zombie children a chance to die, and decrease the number known to
+;; exist.
+
+(define (child-cleanup)
+  (do () ((or (<= number-children 0)
+	      (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
@@ -227,26 +237,35 @@
 
 (define (run-job-loop . fd-list)
 
-  (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? (car (select fd-list '() '() sleep-time))))
-                   (break)))
-        
-          (run-jobs next-jobs-list)
-
-          (do () ((or (<= number-children 0)
-                      (eqv? (car (waitpid WAIT_ANY WNOHANG)) 0)))
-            (set! number-children (- number-children 1)))
-        
-          (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 ()
+                                   (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)))))))
-- 
cgit v1.2.3