SummaryRefsLogTreeCommitDiffStats
path: root/scm/mcron
diff options
context:
space:
mode:
authorMathieu Lirzin <mthl@gnu.org>2016-05-07 11:09:44 +0200
committerMathieu Lirzin <mthl@gnu.org>2016-05-07 23:38:53 +0200
commit995bc9ca6ebf6880d7e7e6f3d1baa2941758fc47 (patch)
tree1f12ba3e4218d91a8736df5a5fa6eb82ffe39181 /scm/mcron
parentbb8703b679509fe3b842f9f24f6871b3c2889916 (diff)
downloadmcron-995bc9ca6ebf6880d7e7e6f3d1baa2941758fc47.tar.gz
mcron-995bc9ca6ebf6880d7e7e6f3d1baa2941758fc47.tar.bz2
mcron-995bc9ca6ebf6880d7e7e6f3d1baa2941758fc47.zip
all: Rename 'scm' directory to 'src'.
* scm/mcron/config.scm.in: Rename to ... * src/mcron/config.scm.in: ... this. * scm/mcron/crontab.scm: Rename to ... * src/mcron/crontab.scm: ... this. * scm/mcron/environment.scm: Rename to ... * src/mcron/environment.scm: ... this. * scm/mcron/job-specifier.scm: Rename to ... * src/mcron/job-specifier.scm: ... this. * scm/mcron/main.scm: Rename to ... * src/mcron/main.scm: ... this. * scm/mcron/mcron-core.scm: Rename to ... * src/mcron/mcron-core.scm: ... this. * scm/mcron/redirect.scm: Rename to ... * src/mcron/redirect.scm: ... this. * scm/mcron/vixie-specification.scm: Rename to ... * src/mcron/vixie-specification.scm: ... this. * scm/mcron/vixie-time.scm: Rename to ... * src/mcron/vixie-time.scm: ... this. * mcron.c: Rename to ... * src/mcron.c: ... this. * Makefile.am: Adapt to them. * build-aux/pre-inst-env.in: Likewise. * configure.ac (AC_CONFIG_FILES): Likewise. (AC_CONFIG_HEADER): Set to 'src/config.h'. * .gitignore: Update.
Diffstat (limited to 'scm/mcron')
-rw-r--r--scm/mcron/config.scm.in39
-rw-r--r--scm/mcron/crontab.scm228
-rw-r--r--scm/mcron/environment.scm97
-rw-r--r--scm/mcron/job-specifier.scm253
-rw-r--r--scm/mcron/main.scm401
-rw-r--r--scm/mcron/mcron-core.scm270
-rw-r--r--scm/mcron/redirect.scm190
-rw-r--r--scm/mcron/vixie-specification.scm207
-rw-r--r--scm/mcron/vixie-time.scm384
9 files changed, 0 insertions, 2069 deletions
diff --git a/scm/mcron/config.scm.in b/scm/mcron/config.scm.in
deleted file mode 100644
index db2bc32..0000000
--- a/scm/mcron/config.scm.in
+++ /dev/null
@@ -1,39 +0,0 @@
-;; -*-scheme-*-
-
-;; Copyright (C) 2015 Mathieu Lirzin
-;; Copyright (C) 2003 Dale Mellor
-;;
-;; 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/>.
-
-
-;; Some constants set by the configuration process.
-
-(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/scm/mcron/crontab.scm b/scm/mcron/crontab.scm
deleted file mode 100644
index 6be5c61..0000000
--- a/scm/mcron/crontab.scm
+++ /dev/null
@@ -1,228 +0,0 @@
-;; Copyright (C) 2003, 2014 Dale Mellor
-;;
-;; 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/>.
-
-
-;; Apart from the collecting of options and the handling of --help and --version
-;; (which are done in the main.scm file), this file provides all the
-;; functionality of the crontab personality. It is designed to be loaded and run
-;; once, and then the calling program can exit and the crontab program will have
-;; completed its function.
-
-
-
-;; 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.
-
-(let ((hit-server
- (lambda (user-name)
- (catch #t (lambda ()
- (let ((socket (socket AF_UNIX SOCK_STREAM 0)))
- (connect socket AF_UNIX config-socket-file)
- (display user-name socket)
- (close socket)))
- (lambda (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?
- (lambda (file name)
- (catch #t (lambda ()
- (with-input-from-file
- file
- (lambda ()
- (let loop ((input (read-line)))
- (if (eof-object? input)
- #f
- (if (string=? input name)
- #t
- (loop (read-line))))))))
- (lambda (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.
-
- (if (> (+ (if (option-ref options 'edit #f) 1 0)
- (if (option-ref options 'list #f) 1 0)
- (if (option-ref options '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.
-
- (if (and (not (eqv? (getuid) 0))
- (option-ref options 'user #f))
- (mcron-error 8 "Only root can use the -u option."))
-
-
-
- (let (
-
-
- ;; Iff the --user option is given, the crontab-user may be different
- ;; from the real user.
-
- (crontab-user (option-ref options '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 (lambda (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 options 'list #f)
- (catch #t (lambda ()
- (with-input-from-file crontab-file (lambda ()
- (do ((input (read-char) (read-char)))
- ((eof-object? input))
- (display input)))))
- (lambda (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 options 'edit #f)
- (let ((temp-file (string-append config-tmp-dir
- "/crontab."
- (number->string (getpid)))))
- (catch #t (lambda () (copy-file crontab-file temp-file))
- (lambda (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
- (lambda () (read-vixie-file temp-file))
- (lambda (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 options 'remove #f)
- (catch #t (lambda () (delete-file crontab-file)
- (hit-server crontab-user))
- noop))
-
-
- ;; !!!! 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 options '() '())))
- (let ((input-file (car (option-ref options '() '()))))
- (catch-mcron-error
- (if (string=? input-file "-")
- (let ((input-string (stdin->string)))
- (read-vixie-port (open-input-string input-string))
- (with-output-to-file crontab-file (lambda ()
- (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.")))
-
-
-)) ;; End of file-level let-scopes.
diff --git a/scm/mcron/environment.scm b/scm/mcron/environment.scm
deleted file mode 100644
index b563d55..0000000
--- a/scm/mcron/environment.scm
+++ /dev/null
@@ -1,97 +0,0 @@
-;; Copyright (C) 2015, 2016 Mathieu Lirzin
-;; Copyright (C) 2003 Dale Mellor
-;;
-;; 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/>.
-
-
-
-;; This file defines 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.
-
-
-
-
-(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/scm/mcron/job-specifier.scm b/scm/mcron/job-specifier.scm
deleted file mode 100644
index 1c2f9d9..0000000
--- a/scm/mcron/job-specifier.scm
+++ /dev/null
@@ -1,253 +0,0 @@
-;; Copyright (C) 2003 Dale Mellor
-;; Copyright (C) 2016 Mathieu Lirzin
-;;
-;; 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/>.
-
-
-
-;; This module defines 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 core
-;; add-job function), and the procedure for declaring environment modifications.
-
-(define-module (mcron job-specifier)
- #:use-module (ice-9 match)
- #:use-module (mcron core)
- #: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 (all assumed less than
- ;; 9999). 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, 9999 will be returned.
- (let loop ((smallest 9999) (closest+ 9999) (lst next-list))
- (match lst
- (() (cons smallest closest+))
- ((time . rest)
- (loop (min time smallest)
- (if (> time current) (min time closest+) closest+)
- rest)))))
-
-;; Internal function to 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).
-
-(define (bump-time time value-list component higher-component
- set-component! set-higher-component!)
- (if (null? value-list)
- (set-component! time (+ (component time) 1))
- (let ((best-next (%find-best-next (component time) (car value-list))))
- (if (eqv? 9999 (cdr best-next))
- (begin
- (set-higher-component! time (+ (higher-component time) 1))
- (set-component! time (car best-next)))
- (set-component! time (cdr best-next)))))
- (car (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 . 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 . 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 . 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 . 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 . 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 . second-list)
- (let ((time (localtime current-time)))
- (bump-time time second-list tm:sec tm:min set-tm:sec set-tm:min)))
-
-
-
-;; The current-action-time is 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.
-
-(define current-action-time 0)
-
-
-
-;; We want to provide functions which take a single optional argument (as well
-;; as implicitly the current action time), but unlike usual scheme behaviour if
-;; the argument is missing we want to act like it is really missing, and if it
-;; is there we want to act like it is a genuine argument, not a list of
-;; optionals.
-
-(define (maybe-args function args)
- (if (null? args)
- (function current-action-time)
- (function current-action-time (car args))))
-
-
-
-;; These are the convenience functions we were striving to define for the
-;; configuration files. They are wrappers for the next-X-from functions above,
-;; but implicitly use the current-action-time for the time argument.
-
-(define (next-year . args) (maybe-args next-year-from args))
-(define (next-month . args) (maybe-args next-month-from args))
-(define (next-day . args) (maybe-args next-day-from args))
-(define (next-hour . args) (maybe-args next-hour-from args))
-(define (next-minute . args) (maybe-args next-minute-from args))
-(define (next-second . args) (maybe-args next-second-from 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 global variable). 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 . displayable)
- (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 ((not (null? displayable)) (car displayable))
- ((procedure? action) "Lambda function")
- ((string? action) action)
- ((list? action) (with-output-to-string
- (lambda () (display action)))))))
- (add-job (lambda (current-time)
- (set! current-action-time current-time) ;; ?? !!!! Code
-
- ;; Contributed by Sergey Poznyakoff to 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
- configuration-user)))
diff --git a/scm/mcron/main.scm b/scm/mcron/main.scm
deleted file mode 100644
index 1f2b068..0000000
--- a/scm/mcron/main.scm
+++ /dev/null
@@ -1,401 +0,0 @@
-;; Copyright (C) 2015, 2016 Mathieu Lirzin
-;; Copyright (C) 2003, 2012 Dale Mellor
-;;
-;; 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/>.
-
-;;; This is the 'main' routine for the whole system; this module is the global
-;;; entry point (after the minimal C wrapper); to all intents and purposes the
-;;; program is pure Guile and starts here.
-
-(define-module (mcron main)
- #:use-module (ice-9 getopt-long)
- #:use-module (ice-9 rdelim)
- #:use-module (ice-9 regex)
- #:use-module (mcron config)
- #:use-module (mcron core)
- #:use-module (mcron job-specifier)
- #:use-module (mcron vixie-specification)
- #:use-module (srfi srfi-2)
- #:use-module (srfi srfi-26)
- #:export (delete-run-file
- main))
-
-(define* (command-name #:optional (command (car (command-line))))
- "Extract the actual command name from COMMAND. This returns the last part
-of COMMAND without any non-alphabetic characters. For example \"in.cron\" and
-\"./mcron\" will return respectively \"cron\" and \"mcron\".
-
-When COMMAND is not specified this uses the first element of (command-line)."
- (match:substring (regexp-exec (make-regexp "[[:alpha:]]*$") command)))
-
-(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 (append (list (command-name) ": ") 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 command-type
- ;; 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.
- (let* ((command (command-name))
- (command=? (cut string=? command <>)))
- (cond ((command=? "mcron") 'mcron)
- ((or (command=? "cron") (command=? "crond")) 'cron)
- ((command=? "crontab") 'crontab)
- (else (mcron-error 12 "The command name is invalid.")))))
-
-(define options
- ;; There are a different set of options for the crontab personality compared
- ;; to all the others, with the --help and --version options common to all
- ;; the personalities.
- (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 #t)
- (predicate
- ,(lambda (value)
- (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))))))
- (lambda (key func fmt args . rest)
- (mcron-error 1 (apply format (append (list #f fmt) args))))))
-
-(define* (show-version #:optional (command (command-name)))
- "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)
- (quit)))
-
-(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* (show-help #:optional (command (command-name)))
- "Display informations of usage for COMMAND and quit."
- (simple-format #t "Usage: ~a" command)
- (display
- (case command-type
- ((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)")
- ((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).")
- ((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")
- (else "\nrubbish")))
- (newline)
- (show-package-information)
- (quit))
-
-(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 (lambda () (delete-file config-pid-file)
- (delete-file config-socket-file))
- noop)
- (quit))
-
-(define (stdin->string)
- "Return standard input as a string."
- (with-output-to-string (lambda () (do ((in (read-char) (read-char)))
- ((eof-object? in))
- (display in)))))
-
-(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)))
- (do ((file-name (readdir dir) (readdir dir)))
- ((eof-object? file-name) (closedir dir))
- (proc file-name))))
-
-(define process-user-file
- (let ((guile-regexp (make-regexp "\\.gui(le)?$"))
- (vixie-regexp (make-regexp "\\.vix(ie)?$")))
- (lambda* (file-name #:optional guile-syntax?)
- "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=? (option-ref options 'stdin "guile") "vixie")
- (read-vixie-port (current-input-port))
- (eval-string (stdin->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)
- "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 (lambda (dir)
- (catch #t
- (lambda ()
- (for-each-file
- (lambda (file)
- (process-user-file (string-append dir "/" file)))
- dir))
- (lambda (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-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
- (lambda ()
- (for-each-file
- (lambda (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))
- (lambda (key . args)
- (mcron-error 4
- "You do not have permission to access the system crontabs."))))
-
-(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."
- (if (eq? command-type 'cron)
- (catch #t
- (lambda ()
- (let ((sock (socket AF_UNIX SOCK_STREAM 0)))
- (bind sock AF_UNIX config-socket-file)
- (listen sock 5)
- (list sock)))
- (lambda (key . args)
- (delete-file config-pid-file)
- (mcron-error 1 "Cannot bind to UNIX socket " config-socket-file)))
- '()))
-
-(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)))))))
-
-
-;;;
-;;; Entry point.
-;;;
-
-(define (main . args)
- ;; Turn debugging on if indicated.
- (when config-debug
- (debug-enable 'backtrace))
- (when (option-ref options 'version #f)
- (show-version))
- (when (option-ref options 'help #f)
- (show-help))
-
- ;; Setup the cron process, if appropriate. If there is already a
- ;; /var/run/cron.pid file, then we must assume a cron daemon is already
- ;; running and refuse to start another one.
- ;;
- ;; Otherwise, clear the MAILTO environment variable so that output from cron
- ;; jobs is sent to the various users (this may still be overridden in the
- ;; configuration files), and call the function in the C wrapper to set up
- ;; terminal signal responses to vector to the procedure above. The PID file
- ;; will be filled in properly later when we have forked our daemon process
- ;; (but not done if we are only viewing the schedules).
- (when (eq? command-type 'cron)
- (unless (eqv? (getuid) 0)
- (mcron-error 16
- "This program must be run by the root user (and should have been "
- "installed as such)."))
- (when (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 ".)"))
- (unless (option-ref options 'schedule #f)
- (with-output-to-file config-pid-file noop))
- (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))
-
- ;; Now we have the procedures in place for dealing with the contents of
- ;; configuration files, the crontab personality is able to validate such
- ;; files. If the user requested the crontab personality, we load and run the
- ;; code here and then get out.
- (when (eq? command-type 'crontab)
- (load "crontab.scm")
- (quit))
-
- ;; 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.
- (case command-type
- ((mcron)
- (if (null? (option-ref options '() '()))
- (process-files-in-user-directory)
- (for-each (lambda (file-path) (process-user-file file-path #t))
- (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)
- (unless (option-ref options 'noetc #f)
- (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."))))
-
- ;; 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. Finally, ensure that the count is some
- ;; positive integer.
- (and-let* ((count (option-ref options 'schedule #f)))
- (set! count (string->number count))
- (display (get-schedule (if (<= count 0) 1 count)))
- (quit))
-
- ;; If we are supposed to run as a daemon process (either a --daemon option
- ;; has been explicitly used, or we are running as cron or crond), detach
- ;; from the terminal now. If we are running as cron, we can now write the
- ;; PID file.
- (when (option-ref options 'daemon (eq? command-type 'cron))
- (unless (eqv? (primitive-fork) 0)
- (quit))
- (setsid)
- (when (eq? command-type 'cron)
- (with-output-to-file config-pid-file
- (lambda () (display (getpid)) (newline)))))
-
- ;; 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. Sergey Poznyakoff: we can also drop out of run-job-loop
- ;; because of a SIGCHLD, so must test FDES-LIST.
- (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/scm/mcron/mcron-core.scm b/scm/mcron/mcron-core.scm
deleted file mode 100644
index 13781c9..0000000
--- a/scm/mcron/mcron-core.scm
+++ /dev/null
@@ -1,270 +0,0 @@
-;; Copyright (C) 2015, 2016 Mathieu Lirzin
-;; Copyright (C) 2003 Dale Mellor
-;;
-;; 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 core)
- #:use-module (mcron environment)
- #:use-module (srfi srfi-9)
- #: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
-;;
-;; (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)))))
-
-
-
-;; 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)))))
-
-
-
-;; 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)
- (begin
- (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))
- (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))))
-
-
-
-;; Now the main loop. Loop over all job specifications, get a list of the next
-;; ones to run (may be more than one). Set an alarm and go to sleep. When we
-;; wake, run the jobs and reap any children (old jobs) that have
-;; completed. Repeat ad infinitum.
-;;
-;; Note that, if we wake ahead of time, it can only mean that a signal has been
-;; sent by a crontab job to tell us to re-read a crontab file. In this case we
-;; break out of the loop here, and let the main procedure deal with the
-;; situation (it will eventually re-call this function, thus maintaining the
-;; loop).
-
-(define (run-job-loop . fd-list)
-
- (call-with-current-continuation
- (lambda (break)
-
- (let ((fd-list (if (null? fd-list) '() (car fd-list))))
-
- (let loop ()
-
- (let* ((next-jobs (find-next-jobs))
- (next-time (car next-jobs))
- (next-jobs-list (cdr next-jobs))
- (sleep-time (if next-time (- next-time (current-time))
- 2000000000)))
-
- (and (> sleep-time 0)
- (if (not (null?
- (catch 'system-error
- (lambda ()
- (car (select fd-list '() '() sleep-time)))
- (lambda (key . args) ;; Exception add by Sergey
- ;; Poznyakoff.
- (if (member (car (last args))
- (list EINTR EAGAIN))
- (begin
- (child-cleanup) '())
- (apply throw key args))))))
- (break)))
-
- (run-jobs next-jobs-list)
-
- (child-cleanup)
-
- (loop)))))))
diff --git a/scm/mcron/redirect.scm b/scm/mcron/redirect.scm
deleted file mode 100644
index af763cb..0000000
--- a/scm/mcron/redirect.scm
+++ /dev/null
@@ -1,190 +0,0 @@
-;; Copyright (C) 2003 Dale Mellor
-;;
-;; 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/>.
-
-
-
-;; This module provides 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.
-
-(define-module (mcron redirect)
- #:export (with-mail-out)
- #:use-module (ice-9 regex)
- #:use-module ((mcron config) :select (config-sendmail))
- #:use-module (mcron vixie-time))
-
-
-
-;; 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.
-
-(use-modules (ice-9 popen))
-
-(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/scm/mcron/vixie-specification.scm b/scm/mcron/vixie-specification.scm
deleted file mode 100644
index 5cd1528..0000000
--- a/scm/mcron/vixie-specification.scm
+++ /dev/null
@@ -1,207 +0,0 @@
-;; Copyright (C) 2003 Dale Mellor
-;;
-;; 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/>.
-
-
-
-;; This file provides 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.
-
-(define-module (mcron vixie-specification)
- #:export (parse-user-vixie-line
- parse-system-vixie-line
- read-vixie-port
- read-vixie-file
- check-system-crontab)
- #:use-module ((mcron config) :select (config-socket-file))
- #:use-module (mcron core)
- #:use-module (mcron job-specifier)
- #:use-module (mcron redirect)
- #:use-module (mcron vixie-time))
-
-
-(use-modules (ice-9 regex) (ice-9 rdelim)
- (srfi srfi-1) (srfi srfi-2) (srfi srfi-13) (srfi srfi-14))
-
-
-
-;; 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-let* ((match (regexp-exec parse-vixie-environment-regexp4 string)))
- (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/scm/mcron/vixie-time.scm b/scm/mcron/vixie-time.scm
deleted file mode 100644
index a91fa89..0000000
--- a/scm/mcron/vixie-time.scm
+++ /dev/null
@@ -1,384 +0,0 @@
-;; Copyright (C) 2003 Dale Mellor
-;;
-;; 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)
- #:use-module (srfi srfi-13)
- #:use-module (srfi srfi-14)
- #: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]
-
-