AboutSummaryRefsLogTreeCommitDiffStats
path: root/src/mcron
diff options
context:
space:
mode:
authorMathieu Lirzin <mthl@gnu.org>2017-09-27 23:16:54 +0200
committerMathieu Lirzin <mthl@gnu.org>2017-09-27 23:16:54 +0200
commitd72716ce16e8326f14ff7ae9ca41af5315e94ae4 (patch)
treee208805a5558748bd010dda915a126e6f043308b /src/mcron
parenta0b580448c4b24830ea37190eda53aa84b36cd60 (diff)
parentba294d6a3ba4d086bc9571d62c705ab6eab200e3 (diff)
downloadmcron-d72716ce16e8326f14ff7ae9ca41af5315e94ae4.tar.gz
mcron-d72716ce16e8326f14ff7ae9ca41af5315e94ae4.tar.bz2
mcron-d72716ce16e8326f14ff7ae9ca41af5315e94ae4.zip
Merge branch 'devel'
Diffstat (limited to 'src/mcron')
-rw-r--r--src/mcron/base.scm247
-rw-r--r--src/mcron/config.scm.in35
-rw-r--r--src/mcron/environment.scm97
-rw-r--r--src/mcron/job-specifier.scm256
-rw-r--r--src/mcron/redirect.scm190
-rw-r--r--src/mcron/scripts/cron.scm177
-rw-r--r--src/mcron/scripts/crontab.scm225
-rw-r--r--src/mcron/scripts/mcron.scm136
-rw-r--r--src/mcron/utils.scm116
-rw-r--r--src/mcron/vixie-specification.scm205
-rw-r--r--src/mcron/vixie-time.scm383
11 files changed, 2067 insertions, 0 deletions
diff --git a/src/mcron/base.scm b/src/mcron/base.scm
new file mode 100644
index 0000000..c100b4f
--- /dev/null
+++ b/src/mcron/base.scm
@@ -0,0 +1,247 @@
+;;;; base.scm -- core procedures
+;;; Copyright © 2003 Dale Mellor <dale_mellor@users.sourceforge.net>
+;;; Copyright © 2015, 2016 Mathieu Lirzin <mthl@gnu.org>
+;;; Copyright © 2016 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Mcron.
+;;;
+;;; GNU Mcron 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 3 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; GNU Mcron 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 GNU Mcron. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (mcron base)
+ #:use-module (ice-9 match)
+ #:use-module (mcron environment)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-2)
+ #:use-module (srfi srfi-9)
+ #:export (add-job
+ remove-user-jobs
+ get-schedule
+ run-job-loop
+ ;; Deprecated and undocumented procedures.
+ use-system-job-list
+ use-user-job-list
+ clear-system-jobs)
+ #:re-export (clear-environment-mods
+ append-environment-mods))
+
+;; The list of all jobs known to the system. Each element of the list is
+;;
+;; (make-job user next-time-function action environment displayable next-time)
+;;
+;; where action must be 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 element 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))
+
+;; A cron job.
+(define-record-type <job>
+ (make-job user time-proc action environment displayable next-time)
+ job?
+ (user job:user) ;object : passwd entry
+ (time-proc job:next-time-function) ;proc : with one 'time' parameter
+ (action job:action) ;thunk : user's code
+ (environment job:environment) ;alist : environment variables
+ (displayable job:displayable) ;string : visible in schedule
+ (next-time job:next-time ;number : time in UNIX format
+ job:next-time-set!))
+
+;; 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)
+ (let ((entry (make-job configuration-user
+ time-proc
+ action
+ (get-current-environment-mods-copy)
+ displayable
+ (time-proc configuration-time))))
+ (if (eq? configuration-source 'user)
+ (set! user-job-list (cons entry user-job-list))
+ (set! system-job-list (cons entry system-job-list)))))
+
+(define (find-next-jobs)
+ "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."
+ (let loop ((jobs (append system-job-list user-job-list))
+ (next-time (inf))
+ (next-jobs '()))
+ (match jobs
+ (()
+ (cons (and (finite? next-time) next-time) next-jobs))
+ ((job . rest)
+ (let ((this-time (job:next-time job)))
+ (cond ((< this-time next-time)
+ (loop rest this-time (list job)))
+ ((= this-time next-time)
+ (loop rest next-time (cons job next-jobs)))
+ (else
+ (loop rest next-time next-jobs))))))))
+
+;; Create a string containing a textual list of the next count jobs to run.
+;;
+;; 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.
+;;
+;; Note that this has the effect of mutating the job timings. Thus the program
+;; must exit after calling this function; the internal data state will be left
+;; unusable.
+
+(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 %z\n" (localtime time))))
+ (for-each (lambda (job)
+ (display date-string)
+ (display (job:displayable job))
+ (newline)(newline)
+ (job:next-time-set! job ((job:next-time-function job)
+ (job:next-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)
+ (dynamic-wind
+ (const #t)
+ (lambda ()
+ (setgid (passwd:gid (job:user job)))
+ (setuid (passwd:uid (job:user job)))
+ (chdir (passwd:dir (job:user job)))
+ (modify-environment (job:environment job) (job:user job))
+ ((job:action job)))
+ (lambda ()
+ (primitive-exit 0)))
+ (begin
+ (set! number-children (+ number-children 1))
+ (job:next-time-set! job ((job:next-time-function job)
+ (current-time))))))
+ jobs-list))
+
+
+
+;; 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))))
+
+(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 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)))
+ (λ (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))))))))
diff --git a/src/mcron/config.scm.in b/src/mcron/config.scm.in
new file mode 100644
index 0000000..2b0bc7f
--- /dev/null
+++ b/src/mcron/config.scm.in
@@ -0,0 +1,35 @@
+;;;; config.scm -- variables defined at configure time
+;;; Copyright © 2003 Dale Mellor <dale_mellor@users.sourceforge.net>
+;;; Copyright © 2015, 2016 Mathieu Lirzin <mthl@gnu.org>
+;;;
+;;; This file is part of GNU Mcron.
+;;;
+;;; GNU Mcron 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 3 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; GNU Mcron 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 GNU Mcron. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (mcron config))
+
+(define-public config-debug @CONFIG_DEBUG@)
+(define-public config-package-name "@PACKAGE_NAME@")
+(define-public config-package-version "@PACKAGE_VERSION@")
+(define-public config-package-string "@PACKAGE_STRING@")
+(define-public config-package-bugreport "@PACKAGE_BUGREPORT@")
+(define-public config-package-url "@PACKAGE_URL@")
+(define-public config-sendmail "@SENDMAIL@")
+
+(define-public config-spool-dir "@CONFIG_SPOOL_DIR@")
+(define-public config-socket-file "@CONFIG_SOCKET_FILE@")
+(define-public config-allow-file "@CONFIG_ALLOW_FILE@")
+(define-public config-deny-file "@CONFIG_DENY_FILE@")
+(define-public config-pid-file "@CONFIG_PID_FILE@")
+(define-public config-tmp-dir "@CONFIG_TMP_DIR@")
diff --git a/src/mcron/environment.scm b/src/mcron/environment.scm
new file mode 100644
index 0000000..f6b9637
--- /dev/null
+++ b/src/mcron/environment.scm
@@ -0,0 +1,97 @@
+;;;; environment.scm -- interact with the job process environment
+;;; Copyright © 2003 Dale Mellor <dale_mellor@users.sourceforge.net>
+;;; Copyright © 2015, 2016 Mathieu Lirzin <mthl@gnu.org>
+;;;
+;;; This file is part of GNU Mcron.
+;;;
+;;; GNU Mcron 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 3 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; GNU Mcron 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 GNU Mcron. If not, see <http://www.gnu.org/licenses/>.
+
+;;;; Commentary:
+;;;
+;;; Define the variable current-environment-mods, and the procedures
+;;; append-environment-mods (which is available to user configuration files),
+;;; clear-environment-mods and modify-environment. The idea is that the
+;;; current-environment-mods is a list of pairs of environment names and
+;;; values, and represents the cumulated environment settings in a
+;;; configuration file. When a job definition is seen in a configuration file,
+;;; the current-environment-mods are copied into the internal job description,
+;;; and when the job actually runs these environment modifications are applied
+;;; to the UNIX environment in which the job runs.
+;;;
+;;;; Code:
+
+(define-module (mcron environment)
+ #:export (modify-environment
+ clear-environment-mods
+ append-environment-mods
+ get-current-environment-mods-copy))
+
+
+
+;; As we parse configuration files, we build up an alist of environment
+;; variables here.
+
+(define current-environment-mods '())
+
+
+
+;; Each time a job is added to the system, we take a snapshot of the current
+;; set of environment modifiers.
+
+(define (get-current-environment-mods-copy)
+ (list-copy current-environment-mods))
+
+
+
+;; When we start to parse a new configuration file, we want to start with a
+;; fresh environment (actually an umodified version of the pervading mcron
+;; environment).
+
+(define (clear-environment-mods)
+ (set! current-environment-mods '()))
+
+
+
+;; Procedure to add another environment setting to the alist above. This is
+;; used both implicitly by the Vixie parser, and can be used directly by users
+;; in scheme configuration files. The return value is purely for the
+;; convenience of the parse-vixie-environment in the vixie-specification module
+;; (yuk).
+
+(define (append-environment-mods name value)
+ (set! current-environment-mods (append current-environment-mods
+ (list (cons name value))))
+ #t)
+
+(define (modify-environment env passwd-entry)
+ "Modify the environment (in the UNIX sense) by setting the variables from
+ENV and some default ones which are modulated by PASSWD-ENTRY. \"LOGNAME\"
+and \"USER\" environment variables can't be overided by ENV. ENV must be an
+alist which associate environment variables to their value. PASSWD-ENTRY must
+be an object representing user information which corresponds to a valid entry
+in /etc/passwd. The return value is not specified."
+ (for-each (lambda (pair) (setenv (car pair) (cdr pair)))
+ (let ((home-dir (passwd:dir passwd-entry))
+ (user-name (passwd:name passwd-entry)))
+ (append
+ ;; Default environment variables which can be overided by ENV.
+ `(("HOME" . ,home-dir)
+ ("CWD" . ,home-dir)
+ ("SHELL" . ,(passwd:shell passwd-entry))
+ ("TERM" . #f)
+ ("TERMCAP" . #f))
+ env
+ ;; Environment variables with imposed values.
+ `(("LOGNAME" . ,user-name)
+ ("USER" . ,user-name))))))
diff --git a/src/mcron/job-specifier.scm b/src/mcron/job-specifier.scm
new file mode 100644
index 0000000..d4c05bd
--- /dev/null
+++ b/src/mcron/job-specifier.scm
@@ -0,0 +1,256 @@
+;;;; job-specifier.scm -- public interface for defining jobs
+;;; Copyright © 2003 Dale Mellor <dale_mellor@users.sourceforge.net>
+;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
+;;;
+;;; This file is part of GNU Mcron.
+;;;
+;;; GNU Mcron 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 3 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; GNU Mcron 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 GNU Mcron. If not, see <http://www.gnu.org/licenses/>.
+
+;;;; Commentary:
+;;;
+;;; Define all the functions that can be used by scheme Mcron configuration
+;;; files, namely the procedures for working out next times, the job procedure
+;;; for registering new jobs (actually a wrapper around the base add-job
+;;; function), and the procedure for declaring environment modifications.
+;;;
+;;;; Code:
+
+(define-module (mcron job-specifier)
+ #:use-module (ice-9 match)
+ #:use-module (mcron base)
+ #:use-module (mcron environment)
+ #:use-module (mcron vixie-time)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-26)
+ #:re-export (append-environment-mods)
+ #:export (range
+ next-year-from next-year
+ next-month-from next-month
+ next-day-from next-day
+ next-hour-from next-hour
+ next-minute-from next-minute
+ next-second-from next-second
+ set-configuration-user
+ set-configuration-time
+ job))
+
+(define* (range start end #:optional (step 1))
+ "Produces a list of values from START up to (but not including) END. An
+optional STEP may be supplied, and (if positive) only every step'th value will
+go into the list. For example, (range 1 6 2) returns '(1 3 5)."
+ (unfold (cut >= <> end) identity (cute + <> (max step 1)) start))
+
+(define (%find-best-next current next-list)
+ ;; Takes a value and a list of possible next values. It returns a pair
+ ;; consisting of the smallest element of the NEXT-LIST, and the smallest
+ ;; element larger than the CURRENT value. If an example of the latter
+ ;; cannot be found, +INF.0 will be returned.
+ (let loop ((smallest (inf)) (closest+ (inf)) (lst next-list))
+ (match lst
+ (() (cons smallest closest+))
+ ((time . rest)
+ (loop (min time smallest)
+ (if (> time current) (min time closest+) closest+)
+ rest)))))
+
+(define (bump-time time value-list component higher-component
+ set-component! set-higher-component!)
+ ;; Return the time corresponding to some near future hour. If hour-list is
+ ;; not supplied, the time returned corresponds to the start of the next hour
+ ;; of the day.
+ ;;
+ ;; If the hour-list is supplied the time returned corresponds to the first
+ ;; hour of the day in the future which is contained in the list. If all the
+ ;; values in the list are less than the current hour, then the time returned
+ ;; will correspond to the first hour in the list *on the following day*.
+ ;;
+ ;; ... except that the function is actually generalized to deal with
+ ;; seconds, minutes, etc., in an obvious way :-)
+ ;;
+ ;; Note that value-list always comes from an optional argument to a
+ ;; procedure, so is wrapped up as the first element of a list (i.e. it is a
+ ;; list inside a list).
+ (match value-list
+ (()
+ (set-component! time (1+ (component time))))
+ ((val . rest)
+ (match (%find-best-next (component time) val)
+ ((smallest . closest+)
+ (cond ((inf? closest+)
+ (set-higher-component! time (1+ (higher-component time)))
+ (set-component! time smallest))
+ (else
+ (set-component! time closest+)))))))
+ (first (mktime time)))
+
+;; Set of configuration methods which use the above general function to bump
+;; specific components of time to the next legitimate value. In each case, all
+;; the components smaller than that of interest are taken to zero, so that for
+;; example the time of the next year will be the time at which the next year
+;; actually starts.
+
+(define* (next-year-from current-time #:optional (year-list '()))
+ (let ((time (localtime current-time)))
+ (set-tm:mon time 0)
+ (set-tm:mday time 1)
+ (set-tm:hour time 0)
+ (set-tm:min time 0)
+ (set-tm:sec time 0)
+ (bump-time time year-list tm:year tm:year set-tm:year set-tm:year)))
+
+(define* (next-month-from current-time #:optional (month-list '()))
+ (let ((time (localtime current-time)))
+ (set-tm:mday time 1)
+ (set-tm:hour time 0)
+ (set-tm:min time 0)
+ (set-tm:sec time 0)
+ (bump-time time month-list tm:mon tm:year set-tm:mon set-tm:year)))
+
+(define* (next-day-from current-time #:optional (day-list '()))
+ (let ((time (localtime current-time)))
+ (set-tm:hour time 0)
+ (set-tm:min time 0)
+ (set-tm:sec time 0)
+ (bump-time time day-list tm:mday tm:mon set-tm:mday set-tm:mon)))
+
+(define* (next-hour-from current-time #:optional (hour-list '()))
+ (let ((time (localtime current-time)))
+ (set-tm:min time 0)
+ (set-tm:sec time 0)
+ (bump-time time hour-list tm:hour tm:mday set-tm:hour set-tm:mday)))
+
+(define* (next-minute-from current-time #:optional (minute-list '()))
+ (let ((time (localtime current-time)))
+ (set-tm:sec time 0)
+ (bump-time time minute-list tm:min tm:hour set-tm:min set-tm:hour)))
+
+(define* (next-second-from current-time #:optional (second-list '()))
+ (let ((time (localtime current-time)))
+ (bump-time time second-list tm:sec tm:min set-tm:sec set-tm:min)))
+
+;;; The following procedures are convenient for configuration files. They are
+;;; wrappers for the next-X-from functions above, by implicitly using
+;;; %CURRENT-ACTION-TIME as the time argument.
+
+(define %current-action-time
+ ;; The time a job was last run, the time from which the next time to run a
+ ;; job must be computed. (When the program is first run, this time is set to
+ ;; the configuration time so that jobs run from that moment forwards.) Once
+ ;; we have this, we supply versions of the time computation commands above
+ ;; which implicitly assume this value.
+ (make-parameter 0))
+
+(define* (next-year #:optional (args '()))
+ "Compute the next year from %CURRENT-ACTION-TIME parameter object."
+ (next-year-from (%current-action-time) args))
+
+(define* (next-month #:optional (args '()))
+ "Compute the next month from %CURRENT-ACTION-TIME parameter object."
+ (next-month-from (%current-action-time) args))
+
+(define* (next-day #:optional (args '()))
+ "Compute the next day from %CURRENT-ACTION-TIME parameter object."
+ (next-day-from (%current-action-time) args))
+
+(define* (next-hour #:optional (args '()))
+ "Compute the next hour from %CURRENT-ACTION-TIME parameter object."
+ (next-hour-from (%current-action-time) args))
+
+(define* (next-minute #:optional (args '()))
+ "Compute the next minute from %CURRENT-ACTION-TIME parameter object."
+ (next-minute-from (%current-action-time) args))
+
+(define* (next-second #:optional (args '()))
+ "Compute the next second from %CURRENT-ACTION-TIME parameter object."
+ (next-second-from (%current-action-time) args))
+
+;; The default user for running jobs is the current one (who invoked this
+;; program). There are exceptions: when cron parses /etc/crontab the user is
+;; specified on each individual line; when cron parses /var/cron/tabs/* the user
+;; is derived from the filename of the crontab. These cases are dealt with by
+;; mutating this variable. Note that the variable is only used at configuration
+;; time; a UID is stored with each job and it is that which takes effect when
+;; the job actually runs.
+
+(define configuration-user (getpw (getuid)))
+(define configuration-time (current-time))
+
+(define (set-configuration-user user)
+ (set! configuration-user (if (or (string? user)
+ (integer? user))
+ (getpw user)
+ user)))
+(define (set-configuration-time time) (set! configuration-time time))
+
+
+
+;; The job function, available to configuration files for adding a job rule to
+;; the system.
+;;
+;; Here we must 'normalize' the next-time-function so that it is always a lambda
+;; function which takes one argument (the last time the job ran) and returns a
+;; single value (the next time the job should run). If the input value is a
+;; string this is parsed as a Vixie-style time specification, and if it is a
+;; list then we arrange to eval it (but note that such lists are expected to
+;; ignore the function parameter - the last run time is always read from the
+;; %CURRENT-ACTION-TIME parameter object). A similar normalization is applied to
+;; the action.
+;;
+;; Here we also compute the first time that the job is supposed to run, by
+;; finding the next legitimate time from the current configuration time (set
+;; right at the top of this program).
+
+(define* (job time-proc action #:optional displayable
+ #:key (user configuration-user))
+ (let ((action (cond ((procedure? action) action)
+ ((list? action) (lambda () (primitive-eval action)))
+ ((string? action) (lambda () (system action)))
+ (else
+ (throw 'mcron-error 2
+ "job: invalid second argument (action; should be lambda "
+ "function, string or list)"))))
+
+ (time-proc
+ (cond ((procedure? time-proc) time-proc)
+ ((string? time-proc) (parse-vixie-time time-proc))
+ ((list? time-proc) (lambda (current-time)
+ (primitive-eval time-proc)))
+ (else
+ (throw 'mcron-error 3
+ "job: invalid first argument (next-time-function; "
+ "should be function, string or list)"))))
+ (displayable
+ (cond (displayable displayable)
+ ((procedure? action) "Lambda function")
+ ((string? action) action)
+ ((list? action) (with-output-to-string
+ (lambda () (display action))))))
+ (user* (if (or (string? user) (integer? user))
+ (getpw user)
+ user)))
+ (add-job (lambda (current-time)
+ (parameterize ((%current-action-time current-time))
+ ;; Allow for daylight savings time changes.
+ (let* ((next (time-proc current-time))
+ (gmtoff (tm:gmtoff (localtime next)))
+ (d (+ next
+ (- gmtoff
+ (tm:gmtoff (localtime current-time))))))
+ (if (eqv? (tm:gmtoff (localtime d)) gmtoff)
+ d
+ next))))
+ action
+ displayable
+ configuration-time
+ user*)))
diff --git a/src/mcron/redirect.scm b/src/mcron/redirect.scm
new file mode 100644
index 0000000..6711407
--- /dev/null
+++ b/src/mcron/redirect.scm
@@ -0,0 +1,190 @@
+;;;; redirect.scm -- modify job outputs
+;;; Copyright © 2003 Dale Mellor <dale_mellor@users.sourceforge.net>
+;;;
+;;; This file is part of GNU Mcron.
+;;;
+;;; GNU Mcron 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 3 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; GNU Mcron 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 GNU Mcron. If not, see <http://www.gnu.org/licenses/>.
+
+;;;; Commentary:
+;;;
+;;; Provide the (with-mail-out action . user) procedure. This procedure runs
+;;; the action in a child process, allowing the user control over the input
+;;; and output (including standard error). The input is governed (only in the
+;;; case of a string action) by the placing of percentage signs in the string;
+;;; the first delimits the true action from the standard input, and subsequent
+;;; ones denote newlines to be placed into the input. The output (if there
+;;; actually is any) is controlled by the MAILTO environment variable. If
+;;; this is not defined, output is e-mailed to the user passed as argument, if
+;;; any, or else the owner of the action; if defined but empty then any output
+;;; is sunk to /dev/null; otherwise output is e-mailed to the address held in
+;;; the MAILTO variable.
+;;;
+;;;; Code:
+
+(define-module (mcron redirect)
+ #:use-module (ice-9 popen)
+ #:use-module (ice-9 regex)
+ #:use-module (mcron config)
+ #:use-module (mcron vixie-time)
+ #:export (with-mail-out))
+
+;; An action string consists of a sequence of characters forming a command
+;; executable by the shell, possibly followed by an non-escaped percentage
+;; sign. The text after the percentage sign is to be fed to the command's
+;; standard input, with further unescaped percents being substituted with
+;; newlines. The escape character can itself be escaped.
+;;
+;; This regexp separates the two halves of the string, and indeed determines if
+;; the second part is present.
+
+(define action-string-regexp (make-regexp "((\\\\%|[^%])*)%(.*)$"))
+
+
+
+;; This regexp identifies an escaped percentage sign.
+
+(define e-percent (make-regexp "\\\\%"))
+
+
+;; Function to execute some action (this may be a shell command, lamdba function
+;; or list of scheme procedures) in a forked process, with the input coming from
+;; the string, and output (including the error output) being sent to a pipe
+;; opened on a mail transport.
+
+(define (with-mail-out action . user)
+
+ ;; Determine the name of the user who is to recieve the mail, looking for a
+ ;; name in the optional user argument, then in the MAILTO environment
+ ;; variable, and finally in the LOGNAME environment variable. (The case
+ ;; MAILTO="" is dealt with specially below.)
+
+ (let* ((mailto (getenv "MAILTO"))
+ (user (cond (mailto mailto)
+ ((not (null? user)) (car user))
+ (else (getenv "LOGNAME"))))
+ (parent->child (pipe))
+ (child->parent (pipe))
+ (child-pid (primitive-fork)))
+
+
+ ;; The child process. Close redundant ends of pipes, remap the standard
+ ;; streams, and run the action, taking care to chop off the input part of an
+ ;; action string.
+
+ (if (eqv? child-pid 0)
+ (begin
+ (close (cdr parent->child))
+ (close (car child->parent))
+
+ (dup2 (port->fdes (car parent->child)) 0)
+ (close (car parent->child))
+ (dup2 (port->fdes (cdr child->parent)) 1)
+ (close (cdr child->parent))
+ (dup2 1 2)
+
+ (cond ((string? action)
+ (let ((match (regexp-exec action-string-regexp action)))
+ (system (if match
+ (let ((action (match:substring match 1)))
+ (do ((match (regexp-exec e-percent action)
+ (regexp-exec e-percent action)))
+ ((not match))
+ (set! action (string-append
+ (match:prefix match)
+ "%"
+ (match:suffix match))))
+ action)
+ action))))
+
+ ((procedure? action) (action))
+ ((list? action) (primitive-eval action)))
+
+ (primitive-exit 0)))
+
+
+ ;; The parent process. Get rid of redundant pipe ends.
+
+ (close (car parent->child))
+ (close (cdr child->parent))
+
+
+ ;; Put stuff to child from after '%' in command line, replacing
+ ;; other %'s with newlines. Ugly or what?
+
+ (if (string? action)
+ (let ((port (cdr parent->child))
+ (match (regexp-exec action-string-regexp action)))
+ (if (and match
+ (match:substring match 3))
+ (with-input-from-string (match:substring match 3)
+ (lambda ()
+ (let loop ()
+ (let ((next-char (read-char)))
+ (if (not (eof-object? next-char))
+ (cond
+ ((char=? next-char #\%)
+ (newline port)
+ (loop))
+ ((char=? next-char #\\)
+ (let ((escape (read-char)))
+ (if (eof-object? escape)
+ (display #\\ port)
+ (if (char=? escape #\%)
+ (begin
+ (display #\% port)
+ (loop))
+ (begin
+ (display #\\ port)
+ (display escape port)
+ (loop))))))
+ (else
+ (display next-char port)
+ (loop)))))))))))
+
+
+ ;; So the child process doesn't hang on to its input expecting more stuff.
+
+ (close (cdr parent->child))
+
+
+ ;; That's got streaming into the child's input out of the way, now we stream
+ ;; the child's output to a mail sink, but only if there is something there
+ ;; in the first place.
+
+ (if (eof-object? (peek-char (car child->parent)))
+
+ (read-char (car child->parent))
+
+ (begin
+ (set-current-output-port (if (and (string? mailto)
+ (string=? mailto ""))
+ (open-output-file "/dev/null")
+ (open-output-pipe
+ (string-append config-sendmail
+ " "
+ user))))
+ (set-current-input-port (car child->parent))
+ (display "To: ") (display user) (newline)
+ (display "From: mcron") (newline)
+ (display (string-append "Subject: " user "@" (gethostname)))
+ (newline)
+ (newline)
+
+ (do ((next-char (read-char) (read-char)))
+ ((eof-object? next-char))
+ (display next-char))))
+
+ (close (car child->parent))
+
+ (waitpid child-pid)))
diff --git a/src/mcron/scripts/cron.scm b/src/mcron/scripts/cron.scm
new file mode 100644
index 0000000..d043d79
--- /dev/null
+++ b/src/mcron/scripts/cron.scm
@@ -0,0 +1,177 @@
+;;;; cron -- daemon for running jobs at scheduled times
+;;; Copyright © 2003, 2012 Dale Mellor <dale_mellor@users.sourceforge.net>
+;;; Copyright © 2015, 2016 Mathieu Lirzin <mthl@gnu.org>
+;;;
+;;; This file is part of GNU Mcron.
+;;;
+;;; GNU Mcron 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 3 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; GNU Mcron 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 GNU Mcron. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (mcron scripts cron)
+ #:use-module (mcron base)
+ #:use-module (mcron config)
+ #:use-module (mcron job-specifier)
+ #:use-module (mcron utils)
+ #:use-module (mcron vixie-specification)
+ #:use-module (srfi srfi-2)
+ #:export (main))
+
+(define (show-help)
+ (display "Usage: cron [OPTIONS]
+Unless an option is specified, run a cron daemon as a detached process,
+reading all the information in the users' crontabs and in /etc/crontab.
+
+ -v, --version Display version
+ -h, --help Display this help message
+ -sN, --schedule[=]N Display the next N jobs that will be run by cron
+ -n, --noetc Do not check /etc/crontab for updates (HIGHLY
+ RECOMMENDED).")
+ (newline)
+ (show-package-information))
+
+(define %options
+ `((schedule (single-char #\s) (value #t)
+ (predicate ,(λ (str) (string->number str))))
+ (noetc (single-char #\n) (value #f))
+ (version (single-char #\v) (value #f))
+ (help (single-char #\h) (value #f))))
+
+(define (delete-run-file)
+ "Remove the /var/run/cron.pid file so that crontab and other invocations of
+cron don't get the wrong idea that a daemon is currently running. This
+procedure is called from the C front-end whenever a terminal signal is
+received."
+ (catch #t
+ (λ ()
+ (delete-file config-pid-file)
+ (delete-file config-socket-file))
+ noop)
+ (quit))
+
+(define (cron-file-descriptors)
+ "Establish a socket to listen for updates from a crontab program, and return
+a list containing the file descriptors correponding to the files read by
+crontab. This requires that command-type is 'cron."
+ (catch #t
+ (λ ()
+ (let ((sock (socket AF_UNIX SOCK_STREAM 0)))
+ (bind sock AF_UNIX config-socket-file)
+ (listen sock 5)
+ (list sock)))
+ (λ (key . args)
+ (delete-file config-pid-file)
+ (mcron-error 1 "Cannot bind to UNIX socket " config-socket-file))))
+
+(define (process-files-in-system-directory)
+ "Process all the files in the crontab directory. When the job procedure is
+run on behalf of the configuration files, the jobs are registered on the
+system with the appropriate user. Only root should be able to perform this
+operation. The permissions on the /var/cron/tabs directory enforce this."
+
+ (define (user-entry name)
+ ;; Return the user database entry if NAME is valid, otherwise #f.
+ (false-if-exception (getpwnam name)))
+
+ (catch #t
+ (λ ()
+ (for-each-file
+ (λ (user)
+ (and-let* ((entry (user-entry user))) ;crontab without user?
+ (set-configuration-user entry)
+ (catch-mcron-error
+ (read-vixie-file (string-append config-spool-dir "/" user)))))
+ config-spool-dir))
+ (λ (key . args)
+ (mcron-error 4
+ "You do not have permission to access the system crontabs."))))
+
+(define (%process-files schedule? noetc?)
+ ;; XXX: What is this supposed to do?
+ (when schedule?
+ (with-output-to-file config-pid-file noop))
+ ;; Clear MAILTO so that outputs are sent to the various users.
+ (setenv "MAILTO" #f)
+ ;; XXX: At compile time, this yields a "possibly unbound variable" warning,
+ ;; but this is OK since it is bound in the C wrapper.
+ (c-set-cron-signals)
+ ;; Having defined all the necessary procedures for scanning various sets of
+ ;; files, we perform the actual configuration of the program depending on
+ ;; the personality we are running as. If it is mcron, we either scan the
+ ;; files passed on the command line, or else all the ones in the user's
+ ;; .config/cron (or .cron) directory. If we are running under the cron
+ ;; personality, we read the /var/cron/tabs directory and also the
+ ;; /etc/crontab file.
+ (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)
+ (unless noetc?
+ (display "\
+WARNING: cron will check for updates to /etc/crontab EVERY MINUTE. If you do
+not use this file, or you are prepared to manually restart cron whenever you
+make a change, then it is HIGHLY RECOMMENDED that you use the --noetc
+option.\n")
+ (set-configuration-user "root")
+ (job '(- (next-minute-from (next-minute)) 6)
+ check-system-crontab
+ "/etc/crontab update checker.")))
+
+
+;;;
+;;; Entry point.
+;;;
+
+(define* (main #:optional (args (command-line)))
+ (let ((opts (parse-args args %options)))
+ (when config-debug
+ (debug-enable 'backtrace))
+ (cond
+ ((option-ref opts 'help #f)
+ (show-help)
+ (exit 0))
+ ((option-ref opts 'version #f)
+ (show-version "cron")
+ (exit 0))
+ ((not (zero? (getuid)))
+ (mcron-error 16
+ "This program must be run by the root user (and should"
+ " have been installed as such)."))
+ ((access? config-pid-file F_OK)
+ (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 ".)"))
+ (else
+ (%process-files (option-ref opts 'schedule #f)
+ (option-ref opts 'noetc #f))
+ (cond ((option-ref opts 'schedule #f) ;display jobs schedule
+ => (λ (count)
+ (display (get-schedule (max 1 (string->number count))))
+ (exit 0)))
+ (else (case (primitive-fork) ;run the daemon
+ ((0)
+ (setsid)
+ ;; we can now write the PID file.
+ (with-output-to-file config-pid-file
+ (λ () (display (getpid)) (newline))))
+ (else (exit 0)))))
+ ;; Forever execute the 'run-job-loop', 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.
+ (catch-mcron-error
+ (let ((fdes-list (cron-file-descriptors)))
+ (while #t
+ (run-job-loop fdes-list)
+ (unless (null? fdes-list)
+ (process-update-request fdes-list)))))))))
diff --git a/src/mcron/scripts/crontab.scm b/src/mcron/scripts/crontab.scm
new file mode 100644
index 0000000..502fec6
--- /dev/null
+++ b/src/mcron/scripts/crontab.scm
@@ -0,0 +1,225 @@
+;;;; crontab -- edit user's cron tabs
+;;; Copyright © 2003, 2004 Dale Mellor <dale_mellor@users.sourceforge.net>
+;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
+;;;
+;;; This file is part of GNU Mcron.
+;;;
+;;; GNU Mcron 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 3 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; GNU Mcron 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 GNU Mcron. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (mcron scripts crontab)
+ #:use-module (ice-9 rdelim)
+ #:use-module (mcron config)
+ #:use-module (mcron utils)
+ #:use-module (mcron vixie-specification)
+ #:export (main))
+
+(define* (show-help)
+ (display "Usage: crontab [-u user] file
+ crontab [-u user] { -e | -l | -r }
+ (default operation is replace, per 1003.2)
+ -e (edit user's crontab)
+ -l (list user's crontab)
+ -r (delete user's crontab")
+ (newline)
+ (show-package-information))
+
+(define %options
+ '((user (single-char #\u) (value #t))
+ (edit (single-char #\e) (value #f))
+ (list (single-char #\l) (value #f))
+ (remove (single-char #\r) (value #f))
+ (version (single-char #\v) (value #f))
+ (help (single-char #\h) (value #f))))
+
+
+;;;
+;;; Entry point.
+;;;
+
+(define* (main #:optional (args (command-line)))
+ (let ((opts (parse-args args %options)))
+ (when config-debug
+ (debug-enable 'backtrace))
+ (cond ((option-ref opts 'help #f)
+ (show-help)
+ (exit 0))
+ ((option-ref opts 'version #f)
+ (show-version "crontab")
+ (exit 0)))
+ (let ((hit-server
+ (λ (user-name)
+ ;; Procedure to communicate with running cron daemon that a user
+ ;; has modified his crontab. The user name is written to the
+ ;; /var/cron/socket UNIX socket.
+ (catch #t
+ (λ ()
+ (let ((socket (socket AF_UNIX SOCK_STREAM 0)))
+ (connect socket AF_UNIX config-socket-file)
+ (display user-name socket)
+ (close socket)))
+ (λ (key . args)
+ (display "Warning: a cron daemon is not running.\n")))))
+
+ ;; Procedure to scan a file containing one user name per line (such
+ ;; as /var/cron/allow and /var/cron/deny), and determine if the
+ ;; given name is in there. The procedure returns #t, #f, or '() if
+ ;; the file does not exist.
+ (in-access-file?
+ (λ (file name)
+ (catch #t
+ (λ ()
+ (with-input-from-file file
+ (λ ()
+ (let loop ((input (read-line)))
+ (if (eof-object? input)
+ #f
+ (if (string=? input name)
+ #t
+ (loop (read-line))))))))
+ (λ (key . args) '()))))
+
+ ;; This program should have been installed SUID root. Here we get
+ ;; the passwd entry for the real user who is running this program.
+ (crontab-real-user (passwd:name (getpw (getuid)))))
+
+ ;; If the real user is not allowed to use crontab due to the
+ ;; /var/cron/allow and/or /var/cron/deny files, bomb out now.
+ (if (or (eq? (in-access-file? config-allow-file crontab-real-user) #f)
+ (eq? (in-access-file? config-deny-file crontab-real-user) #t))
+ (mcron-error 6 "Access denied by system operator."))
+
+ ;; Check that no more than one of the mutually exclusive options are
+ ;; being used.
+ (when (> (+ (if (option-ref opts 'edit #f) 1 0)
+ (if (option-ref opts 'list #f) 1 0)
+ (if (option-ref opts 'remove #f) 1 0))
+ 1)
+ (mcron-error 7 "Only one of options -e, -l or -r can be used."))
+
+ ;; Check that a non-root user is trying to read someone else's files.
+ (when (and (not (zero? (getuid)))
+ (option-ref opts 'user #f))
+ (mcron-error 8 "Only root can use the -u option."))
+
+ (letrec* (;; Iff the --user option is given, the crontab-user may be
+ ;; different from the real user.
+ (crontab-user (option-ref opts 'user crontab-real-user))
+ ;; So now we know which crontab file we will be manipulating.
+ (crontab-file (string-append config-spool-dir "/" crontab-user))
+ ;; Display the prompt and wait for user to type his
+ ;; choice. Return #t if the answer begins with 'y' or 'Y',
+ ;; return #f if it begins with 'n' or 'N', otherwise ask
+ ;; again.
+ (get-yes-no (λ (prompt . re-prompt)
+ (if (not (null? re-prompt))
+ (display "Please answer y or n.\n"))
+ (display (string-append prompt " "))
+ (let ((r (read-line)))
+ (if (not (string-null? r))
+ (case (string-ref r 0)
+ ((#\y #\Y) #t)
+ ((#\n #\N) #f)
+ (else (get-yes-no prompt #t)))
+ (get-yes-no prompt #t))))))
+ ;; There are four possible sub-personalities to the crontab
+ ;; personality: list, remove, edit and replace (when the user uses no
+ ;; options but supplies file names on the command line).
+ (cond
+ ;; In the list personality, we simply open the crontab and copy it
+ ;; character-by-character to the standard output. If anything goes
+ ;; wrong, it can only mean that this user does not have a crontab
+ ;; file.
+ ((option-ref opts 'list #f)
+ (catch #t
+ (λ ()
+ (with-input-from-file crontab-file
+ (λ ()
+ (do ((input (read-char) (read-char)))
+ ((eof-object? input))
+ (display input)))))
+ (λ (key . args)
+ (display (string-append "No crontab for "
+ crontab-user
+ " exists.\n")))))
+
+ ;; In the edit personality, we determine the name of a temporary file
+ ;; and an editor command, copy an existing crontab file (if it is
+ ;; there) to the temporary file, making sure the ownership is set so
+ ;; the real user can edit it; once the editor returns we try to read
+ ;; the file to check that it is parseable (but do nothing more with
+ ;; the configuration), and if it is okay (this program is still
+ ;; running!) we move the temporary file to the real crontab, wake the
+ ;; cron daemon up, and remove the temporary file. If the parse fails,
+ ;; we give user a choice of editing the file again or quitting the
+ ;; program and losing all changes made.
+ ((option-ref opts 'edit #f)
+ (let ((temp-file (string-append config-tmp-dir
+ "/crontab."
+ (number->string (getpid)))))
+ (catch #t
+ (λ () (copy-file crontab-file temp-file))
+ (λ (key . args) (with-output-to-file temp-file noop)))
+ (chown temp-file (getuid) (getgid))
+ (let retry ()
+ (system (string-append
+ (or (getenv "VISUAL") (getenv "EDITOR") "vi")
+ " "
+ temp-file))
+ (catch 'mcron-error
+ (λ () (read-vixie-file temp-file))
+ (λ (key exit-code . msg)
+ (apply mcron-error 0 msg)
+ (if (get-yes-no "Edit again?")
+ (retry)
+ (begin
+ (mcron-error 0 "Crontab not changed")
+ (primitive-exit 0))))))
+ (copy-file temp-file crontab-file)
+ (delete-file temp-file)
+ (hit-server crontab-user)))
+
+ ;; In the remove personality we simply make an effort to delete the
+ ;; crontab and wake the daemon. No worries if this fails.
+ ((option-ref opts 'remove #f)
+ (catch #t
+ (λ ()
+ (delete-file crontab-file)
+ (hit-server crontab-user))
+ noop))
+
+ ;; XXX: This comment is wrong.
+ ;; In the case of the replace personality we loop over all the
+ ;; arguments on the command line, and for each one parse the file to
+ ;; make sure it is parseable (but subsequently ignore the
+ ;; configuration), and all being well we copy it to the crontab
+ ;; location; we deal with the standard input in the same way but
+ ;; different. :-) In either case the server is woken so that it will
+ ;; read the newly installed crontab.
+ ((not (null? (option-ref opts '() '())))
+ (let ((input-file (car (option-ref opts '() '()))))
+ (catch-mcron-error
+ (if (string=? input-file "-")
+ (let ((input-string (read-string)))
+ (read-vixie-port (open-input-string input-string))
+ (with-output-to-file crontab-file
+ (λ () (display input-string))))
+ (begin
+ (read-vixie-file input-file)
+ (copy-file input-file crontab-file))))
+ (hit-server crontab-user)))
+
+ ;; The user is being silly. The message here is identical to the one
+ ;; Vixie cron used to put out, for total compatibility.
+ (else (mcron-error 15
+ "usage error: file name must be specified for replace.")))))))
diff --git a/src/mcron/scripts/mcron.scm b/src/mcron/scripts/mcron.scm
new file mode 100644
index 0000000..b6c7729
--- /dev/null
+++ b/src/mcron/scripts/mcron.scm
@@ -0,0 +1,136 @@
+;;;; mcron -- run jobs at scheduled times
+;;; Copyright © 2003, 2012 Dale Mellor <dale_mellor@users.sourceforge.net>
+;;; Copyright © 2015, 2016 Mathieu Lirzin <mthl@gnu.org>
+;;;
+;;; This file is part of GNU Mcron.
+;;;
+;;; GNU Mcron 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 3 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; GNU Mcron 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 GNU Mcron. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (mcron scripts mcron)
+ #:use-module (mcron base)
+ #:use-module (mcron config)
+ #:use-module (mcron job-specifier) ;for user/system files
+ #:use-module (mcron utils)
+ #:use-module (mcron vixie-specification)
+ #:export (main))
+
+(define (show-help)
+ (display "Usage: mcron [OPTIONS] [FILES]
+Run an mcron process according to the specifications in the FILES (`-' for
+standard input), or use all the files in ~/.config/cron (or the
+deprecated ~/.cron) with .guile or .vixie extensions.
+
+ -v, --version Display version
+ -h, --help Display this help message
+ -sN, --schedule[=]N Display the next N jobs that will be run by mcron
+ -d, --daemon Immediately detach the program from the terminal
+ and run as a daemon process
+ -i, --stdin=(guile|vixie) Format of data passed as standard input or
+ file arguments (default guile)")
+ (newline)
+ (show-package-information))
+
+(define %options
+ `((schedule (single-char #\s) (value #t)
+ (predicate ,(λ (str) (string->number str))))
+ (daemon (single-char #\d) (value #f))
+ (noetc (single-char #\n) (value #f))
+ (stdin (single-char #\i) (value #t)
+ (predicate ,(λ (val)
+ (or (string=? val "guile")
+ (string=? val "vixie")))))
+ (version (single-char #\v) (value #f))
+ (help (single-char #\h) (value #f))))
+
+(define process-user-file
+ (let ((guile-regexp (make-regexp "\\.gui(le)?$"))
+ (vixie-regexp (make-regexp "\\.vix(ie)?$")))
+ (lambda* (file-name #:optional guile-syntax? #:key (input "guile"))
+ "Process FILE-NAME according its extension. When GUILE-SYNTAX? is TRUE,
+force guile syntax usage. If FILE-NAME format is not recognized, it is
+silently ignored."
+ (cond ((string=? "-" file-name)
+ (if (string=? input "vixie")
+ (read-vixie-port (current-input-port))
+ (eval-string (read-string))))
+ ((or guile-syntax? (regexp-exec guile-regexp file-name))
+ (load file-name))
+ ((regexp-exec vixie-regexp file-name)
+ (read-vixie-file file-name))))))
+
+(define (process-files-in-user-directory input-type)
+ "Process files in $XDG_CONFIG_HOME/cron and/or ~/.cron directories (if
+$XDG_CONFIG_HOME is not defined uses ~/.config/cron instead)."
+ (let ((errors 0)
+ (home-directory (passwd:dir (getpw (getuid)))))
+ (map (λ (dir)
+ (catch #t
+ (λ ()
+ (for-each-file
+ (λ (file)
+ (process-user-file (string-append dir "/" file)
+ #:input input-type))
+ dir))
+ (λ (key . args)
+ (set! errors (1+ errors)))))
+ (list (string-append home-directory "/.cron")
+ (string-append (or (getenv "XDG_CONFIG_HOME")
+ (string-append home-directory "/.config"))
+ "/cron")))
+ (when (eq? 2 errors)
+ (mcron-error 13
+ "Cannot read files in your ~/.config/cron (or ~/.cron) directory."))))
+
+(define (%process-files files input-type)
+ (if (null? files)
+ (process-files-in-user-directory input-type)
+ (for-each (λ (file) (process-user-file file #t)) files)))
+
+
+;;;
+;;; Entry point.
+;;;
+
+(define* (main #:optional (args (command-line)))
+ (let ((opts (parse-args args %options)))
+ (when config-debug
+ (debug-enable 'backtrace))
+ (cond ((option-ref opts 'help #f)
+ (show-help)
+ (exit 0))
+ ((option-ref opts 'version #f)
+ (show-version "mcron")
+ (exit 0))
+ (else
+ (%process-files (option-ref opts '() '())
+ (option-ref opts 'stdin "guile"))
+ (cond ((option-ref opts 'schedule #f) ;display jobs schedule
+ => (λ (count)
+ (display (get-schedule (max 1 (string->number count))))
+ (exit 0)))
+ ((option-ref opts 'daemon #f) ;run mcron as a daemon
+ (case (primitive-fork)
+ ((0) (setsid))
+ (else (exit 0)))))
+ ;; Forever execute the 'run-job-loop', 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.
+ (catch-mcron-error
+ (let ((fdes-list '()))
+ (while #t
+ (run-job-loop fdes-list)
+ ;; we can also drop out of run-job-loop because of a SIGCHLD,
+ ;; so must test FDES-LIST.
+ (unless (null? fdes-list)
+ (process-update-request fdes-list)))))))))
diff --git a/src/mcron/utils.scm b/src/mcron/utils.scm
new file mode 100644
index 0000000..062e756
--- /dev/null
+++ b/src/mcron/utils.scm
@@ -0,0 +1,116 @@
+;;;; utils.scm -- helper procedures
+;;; Copyright © 2003, 2012 Dale Mellor <dale_mellor@users.sourceforge.net>
+;;; Copyright © 2015, 2016 Mathieu Lirzin <mthl@gnu.org>
+;;;
+;;; This file is part of GNU Mcron.
+;;;
+;;; GNU Mcron 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 3 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; GNU Mcron 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 GNU Mcron. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (mcron utils)
+ #:use-module (ice-9 getopt-long)
+ #:use-module (ice-9 rdelim)
+ #:use-module (mcron config)
+ #:use-module (mcron base)
+ #:use-module (mcron job-specifier)
+ #:use-module (mcron vixie-specification)
+ #:export (catch-mcron-error
+ mcron-error
+ parse-args
+ show-version
+ show-package-information
+ for-each-file
+ process-update-request)
+ #:re-export (option-ref
+ read-string))
+
+(define (mcron-error exit-code . rest)
+ "Print an error message (made up from the parts of REST), and if the
+EXIT-CODE error is fatal (present and non-zero) then exit to the system with
+EXIT-CODE."
+ (with-output-to-port (current-error-port)
+ (lambda ()
+ (for-each display (cons "mcron: " rest))
+ (newline)))
+ (when (and exit-code (not (eq? exit-code 0)))
+ (primitive-exit exit-code)))
+
+(define-syntax-rule (catch-mcron-error exp ...)
+ "Evaluate EXP .... if an 'mcron-error exception occurs, print its diagnostics
+and exit with its error code."
+ (catch 'mcron-error
+ (lambda () exp ...)
+ (lambda (key exit-code . msg)
+ (apply mcron-error exit-code msg))))
+
+(define (parse-args args option-desc-list)
+ "Parse ARGS with OPTION-DESC-LIST specification."
+ (catch 'misc-error
+ (lambda () (getopt-long args option-desc-list))
+ (lambda (key func fmt args . rest)
+ (mcron-error 1 (apply format (append (list #f fmt) args))))))
+
+(define (show-version command)
+ "Display version information for COMMAND and quit."
+ (let* ((name config-package-name)
+ (short-name (cadr (string-split name #\space)))
+ (version config-package-version))
+ (simple-format #t "~a (~a) ~a
+Copyright (C) 2015 the ~a authors.
+License GPLv3+: GNU GPL version 3 or later <http://gnu.org/licenses/gpl.html>
+This is free software: you are free to change and redistribute it.
+There is NO WARRANTY, to the extent permitted by law.\n"
+ command name version short-name)))
+
+(define (show-package-information)
+ "Display where to get help and send bug reports."
+ (simple-format #t "\nReport bugs to: ~a.
+~a home page: <~a>
+General help using GNU software: <http://www.gnu.org/gethelp/>\n"
+ config-package-bugreport
+ config-package-name
+ config-package-url))
+
+(define (for-each-file proc directory)
+ "Apply PROC to each file in DIRECTORY. DIRECTORY must be a valid directory name.
+PROC must be a procedure that take one file name argument. The return value
+is not specified"
+ (let ((dir (opendir directory)))
+ (let loop ((file-name (readdir dir)))
+ (if (eof-object? file-name)
+ (closedir dir)
+ (begin
+ (proc file-name)
+ (loop (readdir dir)))))))
+
+(define (process-update-request fdes-list)
+ "Read a user name from the socket, dealing with the /etc/crontab special
+case, remove all the user's jobs from the job list, and then re-read the
+user's updated file. In the special case drop all the system jobs and re-read
+the /etc/crontab file. This function should be called whenever a message
+comes in on the above socket."
+ (let* ((sock (car (accept (car fdes-list))))
+ (user-name (read-line sock)))
+ (close sock)
+ (set-configuration-time (current-time))
+ (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)))))))
diff --git a/src/mcron/vixie-specification.scm b/src/mcron/vixie-specification.scm
new file mode 100644
index 0000000..cf2679a
--- /dev/null
+++ b/src/mcron/vixie-specification.scm
@@ -0,0 +1,205 @@
+;;;; vixie-specification.scm -- read Vixie-sytle configuration file
+;;; Copyright © 2003 Dale Mellor <dale_mellor@users.sourceforge.net>
+;;;
+;;; This file is part of GNU Mcron.
+;;;
+;;; GNU Mcron 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 3 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; GNU Mcron 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 GNU Mcron. If not, see <http://www.gnu.org/licenses/>.
+
+;;;; Commentary:
+;;;
+;;; Methods for reading a complete Vixie-style configuration file, either from
+;;; a real file or an already opened port. It also exposes the method for
+;;; parsing the time-specification part of a Vixie string, so that these can
+;;; be used to form the next-time-function of a job in a Guile configuration
+;;; file.
+;;;
+;;;; Code:
+
+(define-module (mcron vixie-specification)
+ #:use-module (ice-9 regex)
+ #:use-module (ice-9 rdelim)
+ #:use-module (mcron base)
+ #:use-module (mcron config)
+ #:use-module (mcron job-specifier)
+ #:use-module (mcron redirect)
+ #:use-module (mcron vixie-time)
+ #:use-module (srfi srfi-1)
+ #:export (parse-user-vixie-line
+ parse-system-vixie-line
+ read-vixie-port
+ read-vixie-file
+ check-system-crontab))
+
+;; A line in a Vixie-style crontab file which gives a command specification
+;; carries two pieces of information: a time specification consisting of five
+;; space-separated items, and a command which is also separated from the time
+;; specification by a space. The line is broken into the two components, and the
+;; job procedure run to add the two pieces of information to the job list (this
+;; will in turn use the above function to turn the time specification into a
+;; function for computing future run times of the command).
+
+(define parse-user-vixie-line-regexp
+ (make-regexp "^[[:space:]]*(([^[:space:]]+[[:space:]]+){5})(.*)$"))
+
+(define (parse-user-vixie-line line)
+ (let ((match (regexp-exec parse-user-vixie-line-regexp line)))
+ (if (not match)
+ (throw 'mcron-error 10 "Bad job line in Vixie file."))
+ (job (match:substring match 1)
+ (lambda () (with-mail-out (match:substring match 3)))
+ (match:substring match 3))))
+
+
+
+;; The case of reading a line from /etc/crontab is similar to above but the user
+;; ID appears in the sixth field, before the action.
+
+(define parse-system-vixie-line-regexp
+ (make-regexp (string-append "^[[:space:]]*(([^[:space:]]+[[:space:]]+){5})"
+ "([[:alpha:]][[:alnum:]_]*)[[:space:]]+(.*)$")))
+
+(define (parse-system-vixie-line line)
+ (let ((match (regexp-exec parse-system-vixie-line-regexp line)))
+ (if (not match)
+ (throw 'mcron-error 11 "Bad job line in /etc/crontab."))
+ (let ((user (match:substring match 3)))
+ (set-configuration-user user)
+ (job (match:substring match 1)
+ (lambda () (with-mail-out (match:substring match 4)
+ user))
+ (match:substring match 4)))))
+
+
+
+;; Procedure to act on an environment variable specification in a Vixie-style
+;; configuration file, by adding an entry to the alist above. Returns #t if the
+;; operation was successful, #f if the line could not be interpreted as an
+;; environment specification.
+
+(define parse-vixie-environment-regexp1
+ (make-regexp
+ "^[ \t]*([[:alpha:]_][[:alnum:]_]*)[ \t]*=[ \t]*\"(.*)\"[ \t]*$"))
+(define parse-vixie-environment-regexp2
+ (make-regexp
+ "^[ \t]*([[:alpha:]_][[:alnum:]_]*)[ \t]*=[ \t]*'(.*)'[ \t]*$"))
+(define parse-vixie-environment-regexp3
+ (make-regexp
+ "^[ \t]*([[:alpha:]_][[:alnum:]_]*)[ \t]*=[ \t]*(.*[^ \t])[ \t]*$"))
+(define parse-vixie-environment-regexp4
+ (make-regexp
+ "^[ \t]*([[:alpha:]_][[:alnum:]_]*)[ \t]*=[ \t]*$"))
+
+
+(define (parse-vixie-environment string)
+ (let ((match (or (regexp-exec parse-vixie-environment-regexp1 string)
+ (regexp-exec parse-vixie-environment-regexp2 string)
+ (regexp-exec parse-vixie-environment-regexp3 string))))
+ (if match
+ (append-environment-mods (match:substring match 1)
+ (match:substring match 2))
+ (and=> (regexp-exec parse-vixie-environment-regexp4 string)
+ (λ (match)
+ (append-environment-mods (match:substring match 1) #f))))))
+
+;; The next procedure reads an entire Vixie-style file. For each line in the
+;; file there are three possibilities (after continuation lines have been
+;; appended): the line is blank or contains only a comment, the line contains an
+;; environment modifier which will be handled in the mcron environment module,
+;; or the line contains a command specification in which case we use the
+;; procedure above to add an entry to the internal job list.
+;;
+;; Note that the environment modifications are cleared, so that there is no
+;; interference between crontab files (this might lead to unpredictable
+;; behaviour because the order in which crontab files are processed, if there is
+;; more than one, is generally undefined).
+
+(define read-vixie-file-comment-regexp
+ (make-regexp "^[[:space:]]*(#.*)?$"))
+
+
+(define (read-vixie-port port . parse-vixie-line)
+ (clear-environment-mods)
+ (if port
+ (let ((parse-vixie-line
+ (if (null? parse-vixie-line) parse-user-vixie-line
+ (car parse-vixie-line))))
+ (do ((line (read-line port) (read-line port))
+ (line-number 1 (1+ line-number)))
+ ((eof-object? line))
+
+ (let ((report-line line-number))
+ ;; If the line ends with \, append the next line.
+ (while (and (>= (string-length line) 1)
+ (char=? (string-ref line
+ (- (string-length line) 1))
+ #\\))
+ (let ((next-line (read-line port)))
+ (if (eof-object? next-line)
+ (set! next-line ""))
+ (set! line-number (1+ line-number))
+ (set! line
+ (string-append
+ (substring line 0 (- (string-length line) 1))
+ next-line))))
+
+ (catch 'mcron-error
+ (lambda ()
+ ;; Consider the three cases mentioned in the description.
+ (or (regexp-exec read-vixie-file-comment-regexp line)
+ (parse-vixie-environment line)
+ (parse-vixie-line line)))
+ (lambda (key exit-code . msg)
+ (throw 'mcron-error exit-code
+ (apply string-append
+ (number->string report-line)
+ ": "
+ msg)))))))))
+
+
+
+;; If a file cannot be opened, we must silently ignore it because it may have
+;; been removed by crontab. However, if the file is there it must be parseable,
+;; otherwise the error must be propagated to the caller.
+
+(define (read-vixie-file file-path . parse-vixie-line)
+ (let ((port #f))
+ (catch #t (lambda () (set! port (open-input-file file-path)))
+ (lambda (key . args) (set! port #f)))
+ (if port
+ (catch 'mcron-error
+ (lambda ()
+ (if (null? parse-vixie-line)
+ (read-vixie-port port)
+ (read-vixie-port port (car parse-vixie-line)))
+ (close port))
+ (lambda (key exit-code . msg)
+ (close port)
+ (throw 'mcron-error exit-code
+ (apply string-append file-path ":" msg)))))))
+
+
+;; A procedure which determines if the /etc/crontab file has been recently
+;; modified, and, if so, signals the main routine to re-read the file. We run
+;; under the with-mail-to command so that the process runs as a child,
+;; preventing lockup. If cron is supposed to check for updates to /etc/crontab,
+;; then this procedure will be called about 5 seconds before every minute.
+
+(define (check-system-crontab)
+ (with-mail-out (lambda ()
+ (let ((mtime (stat:mtime (stat "/etc/crontab"))))
+ (if (> mtime (- (current-time) 60))
+ (let ((socket (socket AF_UNIX SOCK_STREAM 0)))
+ (connect socket AF_UNIX config-socket-file)
+ (display "/etc/crontab" socket)
+ (close socket)))))))
diff --git a/src/mcron/vixie-time.scm b/src/mcron/vixie-time.scm
new file mode 100644
index 0000000..c4d6bd9
--- /dev/null
+++ b/src/mcron/vixie-time.scm
@@ -0,0 +1,383 @@
+;;;; vixie-time.scm -- parse Vixie-style times
+;;; Copyright © 2003 Dale Mellor <dale_mellor@users.sourceforge.net>
+;;;
+;;; This file is part of GNU Mcron.
+;;;
+;;; GNU Mcron 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 3 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; GNU Mcron 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 GNU Mcron. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (mcron vixie-time)
+ #:use-module (ice-9 regex)
+ #:use-module (mcron job-specifier)
+ #:use-module (srfi srfi-1)
+ #:export (parse-vixie-time))
+
+;; In Vixie-style time specifications three-letter symbols are allowed to stand
+;; for the numbers corresponding to months and days of the week. We deal with
+;; this by making a textual substitution early on in the processing of the
+;; strings.
+;;
+;; We start by defining, once and for all, a list of cons cells consisting of
+;; regexps which will match the symbols - which allow an arbitrary number of
+;; other letters to appear after them (so that the user can optionally complete
+;; the month and day names; this is an extension of Vixie) - and the value which
+;; is to replace the symbol.
+;;
+;; The procedure then takes a string, and then for each symbol in the
+;; parse-symbols list attempts to locate an instance and replace it with an
+;; ASCII representation of the value it stands for. The procedure returns the
+;; modified string. (Note that each symbol can appear only once, which meets the
+;; Vixie specifications technically but still allows silly users to mess things
+;; up).
+
+(define parse-symbols
+ (map (lambda (symbol-cell)
+ (cons (make-regexp (string-append (car symbol-cell) "[[:alpha:]]*")
+ regexp/icase)
+ (cdr symbol-cell)))
+ '(("jan" . "0") ("feb" . "1") ("mar" . "2") ("apr" . "3")
+ ("may" . "4") ("jun" . "5") ("jul" . "6") ("aug" . "7")
+ ("sep" . "8") ("oct" . "9") ("nov" . "10") ("dec" . "11")
+
+ ("sun" . "0") ("mon" . "1") ("tue" . "2") ("wed" . "3")
+ ("thu" . "4") ("fri" . "5") ("sat" . "6") )))
+
+(define (vixie-substitute-parse-symbols string)
+ (for-each (lambda (symbol-cell)
+ (let ((match (regexp-exec (car symbol-cell) string)))
+ (if match
+ (set! string (string-append (match:prefix match)
+ (cdr symbol-cell)
+ (match:suffix match))))))
+ parse-symbols)
+ string)
+
+
+
+;; A Vixie time specification is made up of a space-separated list of elements,
+;; and the elements consist of a comma-separated list of subelements. The
+;; procedure below takes a string holding a subelement, which should have no
+;; spaces or symbols (see above) in it, and returns a list of all values which
+;; that subelement indicates. There are five distinct cases which must be dealt
+;; with: [1] a single '*' which returns a list of all values; [2] a '*' followed
+;; by a step specifier; [3] a range and step specifier; [4] a range; and [5] a
+;; single number.
+;;
+;; To perform the computation required for the '*' cases, we need to pass the
+;; limit of the allowable range for this subelement as the third argument. As
+;; days of the month start at 1 while all the other time components start at 0,
+;; we must pass the base of the range to deal with this case also.
+
+(define parse-vixie-subelement-regexp
+ (make-regexp "^([[:digit:]]+)(-([[:digit:]]+)(/([[:digit:]]+))?)?$"))
+
+(define (parse-vixie-subelement string base limit)
+ (if (char=? (string-ref string 0) #\*)
+ (range base limit (if (> (string-length string) 1)
+ (string->number (substring string 2)) ;; [2]
+ 1)) ;; [1]
+ (let ((match (regexp-exec parse-vixie-subelement-regexp string)))
+ (cond ((not match)
+ (throw 'mcron-error 9
+ "Bad Vixie-style time specification."))
+ ((match:substring match 5)
+ (range (string->number (match:substring match 1))
+ (+ 1 (string->number (match:substring match 3)))
+ (string->number (match:substring match 5)))) ;; [3]
+ ((match:substring match 3)
+ (range (string->number (match:substring match 1))
+ (+ 1 (string->number (match:substring match 3))))) ;; [4]
+ (else
+ (list (string->number (match:substring match 1)))))))) ;; [5]
+
+
+
+;; A Vixie element contains the entire specification, without spaces or symbols,
+;; of the acceptable values for one of the time components (minutes, hours,
+;; days, months, week days). Here we break the comma-separated list into
+;; subelements, and process each with the procedure above. The return value is a
+;; list of all the valid values of all the subcomponents.
+;;
+;; The second and third arguments are the base and upper limit on the values
+;; that can be accepted for this time element.
+;;
+;; The effect of the 'apply append' is to merge a list of lists into a single
+;; list.
+
+(define (parse-vixie-element string base limit)
+ (apply append
+ (map (lambda (sub-element)
+ (parse-vixie-subelement sub-element base limit))
+ (string-tokenize string (char-set-complement (char-set #\,))))))
+
+
+
+;; Consider there are two lists, one of days in the month, the other of days in
+;; the week. This procedure returns an augmented list of days in the month with
+;; weekdays accounted for.
+
+(define (interpolate-weekdays mday-list wday-list month year)
+ (let ((t (localtime 0)))
+ (set-tm:mday t 1)
+ (set-tm:mon t month)
+ (set-tm:year t year)
+ (let ((first-day (tm:wday (cdr (mktime t)))))
+ (apply append
+ mday-list
+ (map (lambda (wday)
+ (let ((first (- wday first-day)))
+ (if (< first 0) (set! first (+ first 7)))
+ (range (+ 1 first) 32 7)))
+ wday-list)))))
+
+
+
+;; Return the number of days in a month. Fix up a tm object for the zero'th day
+;; of the next month, rationalize the object and extract the day.
+
+(define (days-in-month month year)
+ (let ((t (localtime 0))) (set-tm:mday t 0)
+ (set-tm:mon t (+ month 1))
+ (set-tm:year t year)
+ (tm:mday (cdr (mktime t)))))
+
+
+
+;; We will be working with a list of time-spec's, one for each element of a time
+;; specification (minute, hour, ...). Each time-spec holds three pieces of
+;; information: a list of acceptable values for this time component, a procedure
+;; to get the component from a tm object, and a procedure to set the component
+;; in a tm object.
+
+(define (time-spec:list time-spec) (vector-ref time-spec 0))
+(define (time-spec:getter time-spec) (vector-ref time-spec 1))
+(define (time-spec:setter time-spec) (vector-ref time-spec 2))
+
+
+
+;; This procedure modifies the time tm object by setting the component referred
+;; to by the time-spec object to its next acceptable value. If this value is not
+;; greater than the original (because we have wrapped around the top of the
+;; acceptable values list), then the function returns #t, otherwise it returns
+;; #f. Thus, if the return value is true then it will be necessary for the
+;; caller to increment the next coarser time component as well.
+;;
+;; The first part of the let block is a concession to humanity; the procedure is
+;; simply unreadable without all of these aliases.
+
+(define (increment-time-component time time-spec)
+ (let* ((time-list (time-spec:list time-spec))
+ (getter (time-spec:getter time-spec))
+ (setter (time-spec:setter time-spec))
+ (find-best-next (@@ (mcron job-specifier) %find-best-next))
+ (next-best (find-best-next (getter time) time-list))
+ (wrap-around (eqv? (cdr next-best) 9999)))
+ (setter time ((if wrap-around car cdr) next-best))
+ wrap-around))
+
+
+
+;; There now follows a set of procedures for adjusting an element of time,
+;; i.e. taking it to the next acceptable value. In each case, the head of the
+;; time-spec-list is expected to correspond to the component of time in
+;; question. If the adjusted value wraps around its allowed range, then the next
+;; biggest element of time must be adjusted, and so on.
+
+;; There is no specification allowed for the year component of
+;; time. Therefore, if we have to make an adjustment (presumably because a
+;; monthly adjustment has wrapped around the top of its range) we can simply
+;; go to the next year.
+
+(define (nudge-year! time)
+ (set-tm:year time (+ (tm:year time) 1)))
+
+
+;; We nudge the month by finding the next allowable value, and if it wraps
+;; around we also nudge the year. The time-spec-list will have time-spec
+;; objects for month and weekday.
+
+(define (nudge-month! time time-spec-list)
+ (and (increment-time-component time (car time-spec-list))
+ (nudge-year! time)))
+
+
+;; Try to increment the day component of the time according to the combination
+;; of the mday-list and the wday-list. If this wraps around the range, or if
+;; this falls outside the current month (31st February, for example), then
+;; bump the month, set the day to zero, and recurse on this procedure to find
+;; the next day in the new month.
+;;
+;; The time-spec-list will have time-spec entries for mday, month, and
+;; weekday.
+
+(define (nudge-day! time time-spec-list)
+ (if (or (increment-time-component
+ time
+ (vector
+ (interpolate-weekdays (time-spec:list (car time-spec-list))
+ (time-spec:list (caddr time-spec-list))
+ (tm:mon time)
+ (tm:year time))
+ tm:mday
+ set-tm:mday))
+ (> (tm:mday time) (days-in-month (tm:mon time) (tm:year time))))
+ (begin
+ (nudge-month! time (cdr time-spec-list))
+ (set-tm:mday time 0)
+ (nudge-day! time time-spec-list))))
+
+
+
+;; The hour is bumped to the next accceptable value, and the day is bumped if
+;; the hour wraps around.
+;;
+;; The time-spec-list holds specifications for hour, mday, month and weekday.
+
+(define (nudge-hour! time time-spec-list)
+ (and (increment-time-component time (car time-spec-list))
+ (nudge-day! time (cdr time-spec-list))))
+
+
+
+;; The minute is bumped to the next accceptable value, and the hour is bumped
+;; if the minute wraps around.
+;;
+;; The time-spec-list holds specifications for minute, hour, day-date, month
+;; and weekday.
+
+(define (nudge-min! time time-spec-list)
+ (and (increment-time-component time (car time-spec-list))
+ (nudge-hour! time (cdr time-spec-list))))
+
+
+
+
+;; This is a procedure which returns a procedure which computes the next time a
+;; command should run after the current time, based on the information in the
+;; Vixie-style time specification.
+;;
+;; We start by computing a list of time-spec objects (described above) for the
+;; minute, hour, date, month, year and weekday components of the overall time
+;; specification [1]. Special care is taken to produce proper values for
+;; fields 2 and 4: according to Vixie specification "If both fields are
+;; restricted (ie, aren't *), the command will be run when _either_ field
+;; matches the current time." This implies that if one of these fields is *,
+;; while the other is not, its value should be '() [0], otherwise
+;; interpolate-weekdays below will produce incorrect results.
+
+;; When we create the return procedure, it is this list to
+;; which references to a time-spec-list will be bound. It will be used by the
+;; returned procedure [3] to compute the next time a function should run. Any
+;; 7's in the weekday component of the list (the last one) are folded into 0's
+;; (both values represent sunday) [2]. Any 0's in the month-day component of the
+;; list are removed (this allows a solitary zero to be used to indicate that
+;; jobs should only run on certain days of the _week_) [2.1].
+;;
+;; The returned procedure itself:-
+;;
+;; Starts by obtaining the current broken-down time [4], and fixing it to
+;; ensure that it is an acceptable value, as follows. Each component from the
+;; biggest down is checked for acceptability, and if it is not acceptable it
+;; is bumped to the next acceptable value (this may cause higher components to
+;; also be bumped if there is range wrap-around) and all the lower components
+;; are set to -1 so that it can successfully be bumped up to zero if this is
+;; an allowed value. The -1 value will be bumped up subsequently to an allowed
+;; value [5].
+;;
+;; Once it has been asserted that the current time is acceptable, or has been
+;; adjusted to one minute before the next acceptable time, the minute
+;; component is then bumped to the next acceptable time, which may ripple
+;; through the higher components if necessary [6]. We now have the next time
+;; the command needs to run.
+;;
+;; The new time is then converted back into a UNIX time and returned [7].
+
+(define (parse-vixie-time string)
+ (let ((tokens (string-tokenize (vixie-substitute-parse-symbols string))))
+ (cond
+ ((> (length tokens) 5)
+ (throw 'mcron-error 9
+ "Too many fields in Vixie-style time specification"))
+ ((< (length tokens) 5)
+ (throw 'mcron-error 9
+ "Not enough fields in Vixie-style time specification")))
+ (let ((time-spec-list
+ (map-in-order (lambda (x) (vector
+ (let* ((n (vector-ref x 0))
+ (tok (list-ref tokens n)))
+ (cond
+ ((and (= n 4)
+ (string=? tok "*")
+ (not (string=?
+ (list-ref tokens 2) "*")))
+ '())
+ ((and (= n 2)
+ (string=? tok "*")
+ (not (string=?
+ (list-ref tokens 4) "*")))
+ '())
+ (else
+ (parse-vixie-element
+ tok
+ (vector-ref x 1)
+ (vector-ref x 2))))) ; [0]
+ (vector-ref x 3)
+ (vector-ref x 4)))
+ ;; token range-top+1 getter setter
+ `( #( 0 0 60 ,tm:min ,set-tm:min )
+ #( 1 0 24 ,tm:hour ,set-tm:hour )
+ #( 2 1 32 ,tm:mday ,set-tm:mday )
+ #( 3 0 12 ,tm:mon ,set-tm:mon )
+ #( 4 0 7 ,tm:wday ,set-tm:wday ))))) ;; [1]
+
+ (vector-set! (car (last-pair time-spec-list))
+ 0
+ (map (lambda (time-spec)
+ (if (eqv? time-spec 7) 0 time-spec))
+ (vector-ref (car (last-pair time-spec-list)) 0))) ;; [2]
+
+ (vector-set! (caddr time-spec-list)
+ 0
+ (remove (lambda (day) (eqv? day 0))
+ (vector-ref (caddr time-spec-list) 0))) ;; [2.1]
+
+
+ (lambda (current-time) ;; [3]
+ (let ((time (localtime current-time))) ;; [4]
+
+ (if (not (member (tm:mon time)
+ (time-spec:list (cadddr time-spec-list))))
+ (begin
+ (nudge-month! time (cdddr time-spec-list))
+ (set-tm:mday time 0)))
+ (if (or (eqv? (tm:mday time) 0)
+ (not (member (tm:mday time)
+ (interpolate-weekdays
+ (time-spec:list (caddr time-spec-list))
+ (time-spec:list (caddr (cddr time-spec-list)))
+ (tm:mon time)
+ (tm:year time)))))
+ (begin
+ (nudge-day! time (cddr time-spec-list))
+ (set-tm:hour time -1)))
+ (if (not (member (tm:hour time)
+ (time-spec:list (cadr time-spec-list))))
+ (begin
+ (nudge-hour! time (cdr time-spec-list))
+ (set-tm:min time -1))) ;; [5]
+
+ (set-tm:sec time 0)
+ (nudge-min! time time-spec-list) ;; [6]
+ (car (mktime time))))))) ;; [7]
+
+