1 files changed, 247 insertions, 0 deletions
diff --git a/mcron-core.scm b/mcron-core.scm
new file mode 100644
index 0000000..90e1da9
--- /dev/null
+++ b/mcron-core.scm
@@ -0,0 +1,247 @@
+;;   Copyright (C) 2003 Dale Mellor
+;; 
+;;   This program is free software; you can redistribute it and/or modify
+;;   it under the terms of the GNU General Public License as published by
+;;   the Free Software Foundation; either version 2, or (at your option)
+;;   any later version.
+;; 
+;;   This program is distributed in the hope that it will be useful,
+;;   but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;   GNU General Public License for more details.
+;; 
+;;   You should have received a copy of the GNU General Public License
+;;   along with this program; if not, write to the Free Software
+;;   Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
+;;   USA.
+
+
+
+(define-module (mcron core)
+  #:use-module (mcron environment)
+  #:export     (add-job
+                remove-user-jobs
+                get-schedule
+                run-job-loop
+                   ;; These three are deprecated and not documented.
+                use-system-job-list
+                use-user-job-list
+                clear-system-jobs)
+  #:re-export  (clear-environment-mods
+                append-environment-mods))
+
+
+(use-modules (srfi srfi-1)    ;; For remove.
+             (srfi srfi-2))   ;; For and-let*.
+
+
+
+;; The list of all jobs known to the system. Each element of the list is
+;;
+;;  (vector user next-time-function action environment displayable next-time)
+;;
+;; where action may be a string (indicating a shell command) or a list
+;; (indicating scheme code) or a procedure, and the environment is an alist of
+;; modifications that need making to the UNIX environment before the action is
+;; run. The next-time elements is the only one that is modified during the
+;; running of a cron process (i.e. all the others are set once and for all at
+;; configuration time).
+;;
+;; The reason we maintain two lists is that jobs in /etc/crontab may be placed
+;; in one, and all other jobs go in the other. This makes it possible to remove
+;; all the jobs in the first list in one go, and separately we can remove all
+;; jobs from the second list which belong to a particular user. This behaviour
+;; is required for full vixie compatibility.
+
+(define system-job-list '())
+(define user-job-list '())
+
+(define configuration-source 'user)
+
+(define (use-system-job-list) (set! configuration-source 'system))
+(define (use-user-job-list) (set! configuration-source 'user))
+
+
+
+;; Convenience functions for getting and setting the elements of a job object.
+
+(define (job:user job)                (vector-ref job 0))
+(define (job:next-time-function job)  (vector-ref job 1))
+(define (job:action job)              (vector-ref job 2))
+(define (job:environment job)         (vector-ref job 3))
+(define (job:displayable job)         (vector-ref job 4))
+(define (job:next-time job)           (vector-ref job 5))
+(define (job:advance-time! job)
+  (vector-set! job 5 ((job:next-time-function job) (job:next-time job))))
+
+
+
+;; Remove jobs from the user-job-list belonging to this user.
+
+(define (remove-user-jobs user)
+  (if (or (string? user)
+          (integer? user))
+      (set! user (getpw user)))
+    (set! user-job-list
+          (remove (lambda (job) (eqv? (passwd:uid user)
+                                      (passwd:uid (job:user job))))
+                  user-job-list)))
+
+
+
+;; Remove all the jobs on the system job list.
+
+(define (clear-system-jobs) (set! system-job-list '()))
+
+
+
+;; Add a new job with the given specifications to the head of the appropriate
+;; jobs list.
+
+(define (add-job time-proc action displayable configuration-time
+                 configuration-user)
+  (if (eq? configuration-source 'user)
+      (set! user-job-list (cons (vector configuration-user
+                                        time-proc
+                                        action
+                                        (get-current-environment-mods-copy)
+                                        displayable
+                                        (time-proc configuration-time))
+                                user-job-list))
+      (set! system-job-list (cons (vector configuration-user
+                                          time-proc
+                                          action
+                                          (get-current-environment-mods-copy)
+                                          displayable
+                                          (time-proc configuration-time))
+                                  system-job-list))))
+
+
+
+;; Procedure to locate the jobs in the global job-list with the lowest
+;; (soonest) next-times. These are the jobs for which we must schedule the mcron
+;; program (under any personality) to next wake up. The return value is a cons
+;; cell consisting of the next time (maintained in the next-time variable) and a
+;; list of the job entries that are to run at this time (maintained in the
+;; next-jobs-list variable).
+;;
+;; The procedure works by first obtaining the time of the first job on the list,
+;; and setting this job in the next-jobs-list. Then for each other entry on the
+;; job-list, either the job runs earlier than any other that have been scanned,
+;; in which case the next-time and next-jobs-list are re-initialized to
+;; accomodate, or the job runs at the same time as the next job, in which case
+;; the next-jobs-list is simply augmented with the new job, or else the job runs
+;; later than others noted in which case we ignore it for now and continue to
+;; recurse the list.
+
+(define (find-next-jobs)
+  (let ((job-list (append system-job-list user-job-list)))
+    
+    (if (null? job-list)
+        
+        '(#f . '())
+        
+        (let ((next-time 2000000000)
+              (next-jobs-list '()))
+
+          (for-each
+           (lambda (job)
+             (let ((this-time (job:next-time job)))
+               (cond ((< this-time next-time)
+                          (set! next-time this-time)
+                          (set! next-jobs-list (list job)))
+                     ((eqv? this-time next-time)
+                          (set! next-jobs-list (cons job next-jobs-list))))))
+           job-list)
+
+          (cons next-time next-jobs-list)))))
+
+
+
+;; If the user has requested a schedule of jobs that will run, we provide the
+;; information here and then get out.
+;;
+;; Start by determining the number of time points in the future that output is
+;; required for. This may be provided on the command line as a parameter to the
+;; --schedule option, or else we assume a default of 8. Having determined this
+;; count we enter a loop of displaying the next set of jobs to run, artificially
+;; forwarding the time to the next time point (instead of waiting for it to
+;; occur as we would do in a normal run of mcron), and recurse around the loop
+;; count times.
+
+(define (get-schedule count)
+  (with-output-to-string
+    (lambda ()
+      (do ((count count (- count 1)))
+          ((eqv? count 0))
+        (and-let* ((next-jobs (find-next-jobs))
+                   (time (car next-jobs))
+                   (date-string (strftime "%c\n" (localtime time))))
+          (for-each (lambda (job) (display date-string)
+                                  (display (job:displayable job))
+                                  (newline)(newline)
+                                  (job:advance-time! job))
+                    (cdr next-jobs)))))))
+
+
+
+;; For proper housekeeping, it is necessary to keep a record of the number of
+;; child processes we fork off to run the jobs.
+
+(define number-children 0)
+
+
+
+;; For every job on the list, fork a process to run it (noting the fact by
+;; increasing the number-children counter), and in the new process set up the
+;; run-time environment exactly as it should be before running the job proper.
+;;
+;; In the parent, update the job entry by computing the next time the job needs
+;; to run.
+
+(define (run-jobs jobs-list)
+  (for-each (lambda (job)
+              (if (eqv? (primitive-fork) 0)
+                  (begin
+                    (setuid (passwd:uid (job:user job)))
+                    (chdir (passwd:dir (job:user job)))
+                    (modify-environment (job:environment job) (job:user job))
+                    ((job:action job))
+                    (primitive-exit 0))
+                  (begin
+                    (set! number-children (+ number-children 1))
+                    (job:advance-time! job))))
+            jobs-list))
+
+
+
+;; 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.
+
+(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)))))))