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.1.0.3

1 files changed, 169 insertions, 91 deletions

diff --git a/main.scm b/main.scm
index 82b6464..9017276 100644
--- a/main.scm
+++ b/main.scm
@@ -43,13 +43,39 @@
 ;; backwards for the first non-alphabetic character. This allows names like
 ;; in.cron to be accepted as an invocation of the cron command.
 
-(use-modules (ice-9 regex))
+(use-modules (ice-9 regex) (ice-9 rdelim))
 
 (define command-name (match:substring (regexp-exec (make-regexp "[[:alpha:]]*$")
                                                    (car (command-line)))))
 
 
 
+;; Code contributed by Sergey Poznyakoff.  Print an error message (made up from
+;; the parts of rest), and if the error is fatal (present and non-zero) then
+;; exit to the system with this code.
+
+(define (mcron-error exit-code . rest)
+  (with-output-to-port (current-error-port)
+    (lambda ()
+      (for-each display (append (list command-name ": ") rest))
+      (newline)))
+  (if (and exit-code (not (eq? exit-code 0)))
+      (primitive-exit exit-code)))
+
+
+
+;; Code contributed by Sergey Poznyakoff.  Execute body. If an 'mcron-error
+;; exception occurs, print its diagnostics and exit with its error code.
+
+(defmacro catch-mcron-error (. body)
+  `(catch 'mcron-error
+          (lambda ()
+            ,@body)
+          (lambda (key exit-code . msg)
+            (apply mcron-error exit-code msg))))
+
+
+
 ;; We will be doing a lot of testing of the command name, so it makes sense to
 ;; perform the string comparisons once and for all here.
 
@@ -58,8 +84,7 @@
                                 (string=? command-name "crond")) 'cron)
                            ((string=? command-name "crontab") 'crontab)
                            (else
-                            (display "The command name is invalid.\n")
-                            (primitive-exit 12))))
+                            (mcron-error 12 "The command name is invalid."))))
 
 
 
@@ -70,26 +95,34 @@
 (use-modules (ice-9 getopt-long))
 
 (define options
-  (getopt-long (command-line)
-               (append
-                (case command-type ('crontab
-                            '((user     (single-char #\u) (value #t))
-                              (edit     (single-char #\e) (value #f))
-                              (list     (single-char #\l) (value #f))
-                              (remove   (single-char #\r) (value #f))))
-                      (else `((schedule (single-char #\s) (value optional))
-                              (daemon   (single-char #\d) (value #f))
-                              (noetc    (single-char #\n) (value #f))
-                              (stdin    (single-char #\i) (value #t)
-                                        (predicate
-                                         ,(lambda (value)
+  (catch
+   'misc-error
+   (lambda ()
+     (getopt-long (command-line)
+                  (append
+                   (case command-type
+                     ((crontab)
+                      '((user     (single-char #\u) (value #t))
+                        (edit     (single-char #\e) (value #f))
+                        (list     (single-char #\l) (value #f))
+                        (remove   (single-char #\r) (value #f))))
+                     (else `((schedule (single-char #\s)
+                                       (value optional)
+                                       (predicate ;; Added by Sergey Poznyakoff.
+                                        ,(lambda (value)
+                                           (or (eq? value #t)
+                                               (string->number value)))))
+                             (daemon   (single-char #\d) (value #f))
+                             (noetc    (single-char #\n) (value #f))
+                             (stdin    (single-char #\i) (value #t)
+                                       (predicate
+                                        ,(lambda (value)
                                            (or (string=? "vixie" value)
                                                (string=? "guile" value))))))))
-                '((version  (single-char #\v) (value #f))
-                  (help     (single-char #\h) (value #f))))))
-
-
-
+                   '((version  (single-char #\v) (value #f))
+                     (help     (single-char #\h) (value #f))))))
+   (lambda (key func fmt args . rest)
+     (mcron-error 1 (apply format (append (list #f fmt) args))))))
 
 ;; If the user asked for the version of this program, give it to him and get
 ;; out.
@@ -100,7 +133,7 @@
 " command-name "  (" config-package-string ")\n
 Written by Dale Mellor\n
 \n
-Copyright (C) 2003  Dale Mellor\n
+Copyright (C) 2003, 2006  Dale Mellor\n
 This is free software; see the source for copying conditions.  There is NO\n
 warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.\n
 "))
@@ -114,7 +147,9 @@ warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.\n
     (begin
       (display (string-append "
 Usage: " (car (command-line))
-(case command-type ('mcron
+(case command-type
+
+  ((mcron)
 " [OPTIONS] [FILES]\n
 Run an mcron process according to the specifications in the FILES (`-' for\n
 standard input), or use all the files in ~/.cron with .guile or .vixie\n
@@ -126,10 +161,10 @@ extensions.\n
                               will be run by mcron\n
   -d, --daemon              Immediately detach the program from the terminal and\n
                               run as a daemon process\n
-  -i, --stdin=(guile|vixie) Format of data passed as standard input\n
-                              (default guile)")
+  -i, --stdin=(guile|vixie) Format of data passed as standard input or\n
+                              file arguments (default guile)")
 
-  ('cron
+  ((cron)
 " [OPTIONS]\n
 Unless an option is specified, run a cron daemon as a detached process, \n
 reading all the information in the users' crontabs and in /etc/crontab.\n
@@ -141,13 +176,15 @@ reading all the information in the users' crontabs and in /etc/crontab.\n
   -n, --noetc               Do not check /etc/crontab for updates (HIGHLY\n
                               RECOMMENDED).")
   
-  ('crontab
+  ((crontab)
            (string-append " [-u user] file\n"
            "       " (car (command-line)) " [-u user] { -e | -l | -r }\n"
            "               (default operation is replace, per 1003.2)\n"
            "       -e      (edit user's crontab)\n"
            "       -l      (list user's crontab)\n"
-           "       -r      (delete user's crontab)\n")))
+           "       -r      (delete user's crontab)\n"))
+
+  (else "rubbish"))
 
 "\n\n
 Report bugs to " config-package-bugreport ".\n
@@ -158,7 +195,7 @@ Report bugs to " config-package-bugreport ".\n
 
 ;; This is called from the C front-end whenever a terminal signal is
 ;; received. We remove the /var/run/cron.pid file so that crontab and other
-;; invokations of cron don't get the wrong idea that a daemon is currently
+;; invocations of cron don't get the wrong idea that a daemon is currently
 ;; running.
 
 (define (delete-run-file)
@@ -183,16 +220,16 @@ Report bugs to " config-package-bugreport ".\n
 (if (eq? command-type 'cron)
     (begin
       (if (not (eqv? (getuid) 0))
-          (begin
-            (display "This program must be run by the root user (and should ")
-            (display "have been installed as such).\n")
-            (primitive-exit 16)))
+          (mcron-error 16
+                       "This program must be run by the root user (and should "
+                       "have been installed as such)."))
       (if (access? config-pid-file F_OK)
-          (begin
-            (display "A cron daemon is already running.\n")
-            (display "  (If you are sure this is not true, remove the file\n")
-            (display "   " config-pid-file ".)\n")
-            (primitive-exit 1)))
+          (mcron-error 1
+		       "A cron daemon is already running.\n"
+		       "  (If you are sure this is not true, remove the file\n"
+		       "   "
+		       config-pid-file
+		       ".)"))
       (if (not (option-ref options 'schedule #f))
           (with-output-to-file config-pid-file noop))
       (setenv "MAILTO" #f)
@@ -230,6 +267,19 @@ Report bugs to " config-package-bugreport ".\n
 
 
 
+;; Code contributed by Sergey Poznyakoff.  Determine if the given file is a
+;; regular file or not.
+
+(define (regular-file? file)
+  (catch 'system-error
+	 (lambda ()
+	   (eq? (stat:type (stat file)) 'regular))
+	 (lambda (key call fmt args . rest)
+	   (mcron-error 0 (apply format (append (list #f fmt) args)))
+	   #f)))
+
+
+
 ;; Procedure which processes any configuration file according to the
 ;; extension. If a file is not recognized, it is silently ignored (this deals
 ;; properly with most editors' backup files, for instance).
@@ -259,12 +309,12 @@ Report bugs to " config-package-bugreport ".\n
                      (directory (opendir dir-path)))
                 (do ((file-name (readdir directory) (readdir directory)))
                     ((eof-object? file-name) (closedir directory))
-                    (process-user-file (string-append dir-path
-                                                      "/"
-                                                      file-name)))))
+                  (process-user-file (string-append dir-path
+                                                    "/"
+                                                    file-name)))))
          (lambda (key . args)
-           (display "Cannot read files in your ~/.cron directory.\n")
-           (primitive-exit 13))))
+           (mcron-error 13 "Cannot read files in your ~/.cron directory."))))
+
 
 
 
@@ -293,18 +343,21 @@ Report bugs to " config-package-bugreport ".\n
 (use-modules (srfi srfi-2))  ;; For and-let*.
 
 (define (process-files-in-system-directory)
-  (catch #t (lambda ()
-              (let ((directory (opendir config-spool-dir)))
-                (do ((file-name (readdir directory) (readdir directory)))
-                    ((eof-object? file-name))
-                  (and-let* ((user (valid-user file-name)))
-                            (set-configuration-user user)         ;; / ?? !!!!
-                            (read-vixie-file (string-append config-spool-dir
-                                                            "/"
-                                                            file-name))))))
-      (lambda (key . args)
-        (display "You do not have permission to access the system crontabs.\n")
-        (primitive-exit 4))))
+  (catch #t
+         (lambda ()
+           (let ((directory (opendir config-spool-dir)))
+             (do ((file-name (readdir directory) (readdir directory)))
+                 ((eof-object? file-name))
+               (and-let* ((user (valid-user file-name)))
+                         (set-configuration-user user)         ;; / ?? !!!!
+                         (catch-mcron-error
+                          (read-vixie-file (string-append config-spool-dir
+                                                          "/"
+                                                          file-name)))))))
+         (lambda (key . args)
+           (mcron-error
+            4
+            "You do not have permission to access the system crontabs."))))
 
 
 
@@ -316,27 +369,28 @@ Report bugs to " config-package-bugreport ".\n
 ;; /var/cron/tabs directory and also the /etc/crontab file.
 
 (case command-type
-  ('mcron (if (null? (option-ref options '() '()))
-              (process-files-in-user-directory)
-              (for-each (lambda (file-path)
-                          (process-user-file file-path))
-                        (option-ref options '() '()))))
- 
-  ('cron (process-files-in-system-directory)
-         (use-system-job-list)
-         (read-vixie-file "/etc/crontab" parse-system-vixie-line)
-         (use-user-job-list)
-         (if (not (option-ref options 'noetc #f))
-             (begin
-               (display
-"WARNING: cron will check for updates to /etc/crontab EVERY MINUTE. If you do\n
+  ((mcron) (if (null? (option-ref options '() '()))
+                (process-files-in-user-directory)
+                (for-each (lambda (file-path)
+                            (process-user-file file-path))
+                          (option-ref options '() '()))))
+  
+  ((cron) (process-files-in-system-directory)
+   (use-system-job-list)
+   (catch-mcron-error
+    (read-vixie-file "/etc/crontab" parse-system-vixie-line))
+   (use-user-job-list)
+   (if (not (option-ref options 'noetc #f))
+       (begin
+         (display
+          "WARNING: cron will check for updates to /etc/crontab EVERY MINUTE. If you do\n
 not use this file, or you are prepared to manually restart cron whenever you\n
 make a change, then it is HIGHLY RECOMMENDED that you use the --noetc\n
 option.\n")
-               (set-configuration-user "root")
-               (job '(- (next-minute-from (next-minute)) 6)
-                    check-system-crontab
-                    "/etc/crontab update checker.")))))
+         (set-configuration-user "root")
+         (job '(- (next-minute-from (next-minute)) 6)
+              check-system-crontab
+              "/etc/crontab update checker.")))))
 
 
 
@@ -380,10 +434,18 @@ option.\n")
 (define fd-list '())
 
 (if (eq? command-type 'cron)
-    (let ((socket (socket AF_UNIX SOCK_STREAM 0)))
-      (bind socket AF_UNIX config-socket-file)
-      (listen socket 5)
-      (set! fd-list (list socket))))
+    (catch #t
+           (lambda ()
+             (let ((socket (socket AF_UNIX SOCK_STREAM 0)))
+               (bind socket AF_UNIX config-socket-file)
+               (listen socket 5)
+               (set! fd-list (list socket))))
+           (lambda (key . args)
+             (delete-file config-pid-file)
+             (mcron-error 1
+                          "Cannot bind to UNIX socket "
+                          config-socket-file))))
+		     
 
 
 
@@ -398,23 +460,39 @@ option.\n")
          (user-name (read-line socket)))
     (close socket)
     (set-configuration-time (current-time))
-    (if (string=? user-name "/etc/crontab")
-        (begin
-          (clear-system-jobs)
-          (use-system-job-list)
-          (read-vixie-file "/etc/crontab" parse-system-vixie-line)
-          (use-user-job-list))
-        (let ((user (getpw user-name)))
-          (remove-user-jobs user)
-          (set-configuration-user user)
-          (read-vixie-file (string-append config-spool-dir "/" user-name))))))
+    (catch-mcron-error
+     (if (string=? user-name "/etc/crontab")
+         (begin
+           (clear-system-jobs)
+           (use-system-job-list)
+           (read-vixie-file "/etc/crontab" parse-system-vixie-line)
+           (use-user-job-list))
+         (let ((user (getpw user-name)))
+           (remove-user-jobs user)
+           (set-configuration-user user)
+           (read-vixie-file (string-append config-spool-dir "/" user-name)))))))
+
+
+
+;; Added by Sergey Poznyakoff.  This no-op will collect zombie child processes
+;; as soon as they die.  This is a big improvement as previously they stayed
+;; around the system until the next time mcron wakes to fire a new job off.
+
+;; Unfortunately it seems to interact badly with the select system call,
+;; wreaking havoc...
+
+;; (sigaction SIGCHLD (lambda (sig) noop) SA_RESTART)
 
 
 
 ;; Now the main loop. Forever execute the run-job-loop procedure in the mcron
 ;; core, and when it drops out (can only be because a message has come in on the
 ;; socket) we process the socket request before restarting the loop again.
-
-(while #t
-       (run-job-loop fd-list)
-       (process-update-request))
+;; Sergey Poznyakoff: we can also drop out of run-job-loop because of a SIGCHLD,
+;; so must test fd-list.
+
+(catch-mcron-error
+ (while #t
+        (run-job-loop fd-list)
+        (if (not (null? fd-list))
+            (process-update-request))))