From c0ba5c6036e8962c3671928c54a2d66a4c805435 Mon Sep 17 00:00:00 2001 From: Dale Mellor Date: Sun, 25 May 2014 14:57:37 +0100 Subject: Juggled build infrastructure to make mcron.1 man page properly. --- ChangeLog | 12 +- config.scm.in | 35 --- configure.ac | 8 +- crontab.scm | 228 ----------------- environment.scm | 105 -------- job-specifier.scm | 272 --------------------- main.scm | 503 -------------------------------------- makefile.am | 35 +-- makefile.ed | 4 +- mcron-core.scm | 271 -------------------- mcron.1 | 0 redirect.scm | 189 -------------- scm/mcron/config.scm.in | 35 +++ scm/mcron/crontab.scm | 228 +++++++++++++++++ scm/mcron/environment.scm | 105 ++++++++ scm/mcron/job-specifier.scm | 272 +++++++++++++++++++++ scm/mcron/main.scm | 503 ++++++++++++++++++++++++++++++++++++++ scm/mcron/mcron-core.scm | 271 ++++++++++++++++++++ scm/mcron/redirect.scm | 189 ++++++++++++++ scm/mcron/vixie-specification.scm | 209 ++++++++++++++++ scm/mcron/vixie-time.scm | 385 +++++++++++++++++++++++++++++ vixie-specification.scm | 209 ---------------- vixie-time.scm | 385 ----------------------------- 23 files changed, 2227 insertions(+), 2226 deletions(-) delete mode 100644 config.scm.in delete mode 100644 crontab.scm delete mode 100644 environment.scm delete mode 100644 job-specifier.scm delete mode 100644 main.scm delete mode 100644 mcron-core.scm delete mode 100644 mcron.1 delete mode 100644 redirect.scm create mode 100644 scm/mcron/config.scm.in create mode 100644 scm/mcron/crontab.scm create mode 100644 scm/mcron/environment.scm create mode 100644 scm/mcron/job-specifier.scm create mode 100644 scm/mcron/main.scm create mode 100644 scm/mcron/mcron-core.scm create mode 100644 scm/mcron/redirect.scm create mode 100644 scm/mcron/vixie-specification.scm create mode 100644 scm/mcron/vixie-time.scm delete mode 100644 vixie-specification.scm delete mode 100644 vixie-time.scm diff --git a/ChangeLog b/ChangeLog index c604b83..15e01c0 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,7 +1,17 @@ +2014-05-25 Dale Mellor + + * Juggled build infrastructure so that we can make the minimal man + page in the proper autotools way. + + * configure.ac: version to 1.0.8. + + 2014-04-28 Dale Mellor * We now run against, and require, guile-2.0. + * configure.ac: version to 1.0.7. + 2012-02-04 Dale Mellor @@ -148,7 +158,7 @@ ________________________________________________________________________________ -Copyright (C) 2003, 2005, 2006 Dale Mellor +Copyright (C) 2003, 2005, 2006, 2014 Dale Mellor Copying and distribution of this file, with or without modification, are permitted in any medium without royalty provided the copyright diff --git a/config.scm.in b/config.scm.in deleted file mode 100644 index 6a0a85d..0000000 --- a/config.scm.in +++ /dev/null @@ -1,35 +0,0 @@ -;; -*-scheme-*- - -;; 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 . - - -;; Some constants set by the configuration process. - -(define-module (mcron config)) - -(define-public config-debug @CONFIG_DEBUG@) -(define-public config-package-string "@PACKAGE_STRING@") -(define-public config-package-bugreport "@PACKAGE_BUGREPORT@") -(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/configure.ac b/configure.ac index 0ffd581..c819d4d 100644 --- a/configure.ac +++ b/configure.ac @@ -21,7 +21,7 @@ AC_PREREQ(2.61) -AC_INIT([mcron], [1.0.7], [dale_mellor@users.sourceforge.net]) +AC_INIT([mcron], [1.0.8], [dale_mellor@users.sourceforge.net]) AM_INIT_AUTOMAKE @@ -44,10 +44,12 @@ AC_PROG_AWK AC_PROG_EGREP AM_PROG_CC_C_O -PKG_CHECK_MODULES(GUILE, guile-2.0 >= 2.0.7) +PKG_CHECK_MODULES(GUILE, guile-2.0) # Checks for programs. +AM_MISSING_PROG(HELP2MAN, help2man, $missing_dir) + AC_CHECK_PROGS(SED, sed) if test "x$ac_cv_prog_SED" = "x"; then AC_MSG_ERROR(sed not found) @@ -169,5 +171,5 @@ real_program_prefix=`echo $program_prefix | sed s/NONE//` AC_SUBST(real_program_prefix) -AC_CONFIG_FILES(mcron.texinfo makefile config.scm) +AC_CONFIG_FILES(mcron.texinfo makefile scm/mcron/makefile scm/mcron/config.scm) AC_OUTPUT diff --git a/crontab.scm b/crontab.scm deleted file mode 100644 index 30e5592..0000000 --- a/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 . - - -;; 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/environment.scm b/environment.scm deleted file mode 100644 index 9f694f1..0000000 --- a/environment.scm +++ /dev/null @@ -1,105 +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 . - - - -;; 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)) - - - - -;; The env-alist is an association list of variable names and values. Variables -;; later in the list will take precedence over variables before. We return a -;; fixed-up version in which some variables are given specific default values -;; (which the user can override), and two variables which the user is not -;; allowed to control are added at the end of the list. - -(define (impose-default-environment env-alist passwd-entry) - (append `(("HOME" . ,(passwd:dir passwd-entry)) - ("CWD" . ,(passwd:dir passwd-entry)) - ("SHELL" . ,(passwd:shell passwd-entry)) - ("TERM" . #f) - ("TERMCAP" . #f)) - env-alist - `(("LOGNAME" . ,(passwd:name passwd-entry)) - ("USER" . ,(passwd:name passwd-entry))))) - - - - -;; Modify the UNIX environment for the current process according to the given -;; association list of variables, with the default variable values imposed. - -(define (modify-environment env-alist passwd-entry) - (for-each (lambda (variable) - (setenv (car variable) (cdr variable))) - (impose-default-environment env-alist passwd-entry))) - - - - -;; 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) diff --git a/job-specifier.scm b/job-specifier.scm deleted file mode 100644 index cce948c..0000000 --- a/job-specifier.scm +++ /dev/null @@ -1,272 +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 . - - - -;; 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) - #: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 - find-best-next) - #:use-module (mcron core) - #:use-module (mcron environment) - #:use-module (mcron vixie-time) - #:re-export (append-environment-mods)) - - - -;; Function (available to user configuration files) which 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). - -(define (range start end . step) - (let ((step (if (or (null? step) - (<= (car step) 0)) - 1 - (car step)))) - (let loop ((start start)) - (if (>= start end) '() - (cons start - (loop (+ start step))))))) - - - -;; Internal function (not supposed to be used directly in configuration files; -;; it is exported from the module for the convenience of other parts of the -;; mcron implementation) which 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 list, and the smallest element larger than the current -;; value. If an example of the latter cannot be found, 9999 will be returned. - -(define (find-best-next current next-list) - (let ((current-best (cons 9999 9999))) - (for-each (lambda (allowed-time) - (if (< allowed-time (car current-best)) - (set-car! current-best allowed-time)) - (if (and (> allowed-time current) - (< allowed-time (cdr current-best))) - (set-cdr! current-best allowed-time))) - next-list) - current-best)) - - - -;; 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/main.scm b/main.scm deleted file mode 100644 index 36adef9..0000000 --- a/main.scm +++ /dev/null @@ -1,503 +0,0 @@ -;; 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 . - - - -;; This is the 'main' routine for the whole system; the top of this file is the -;; global entry point (after the minimal C wrapper, mcron.c.template); to all -;; intents and purposes the program is pure Guile and starts here. -;; -;; This file is built into mcron.c.template by the makefile, which stringifies -;; the whole lot, and escapes quotation marks and escape characters -;; accordingly. Bear this in mind when considering literal multi-line strings. -;; -;; (l0ad "crontab.scm") (sic) is inlined by the makefile. All other -;; functionality comes through modules in .../share/guile/site/mcron/*.scm. - - - -;; Pull in some constants set by the builder (via autoconf) at configuration -;; time. Turn debugging on if indicated. - -(use-modules (mcron config)) -(if config-debug (begin (debug-enable 'debug) - (debug-enable 'backtrace))) - - - -;; To determine the name of the program, scan the first item of the command line -;; backwards for the first non-alphabetic character. This allows names like -;; in.cron to be accepted as an invocation of the cron command. - -(use-modules (ice-9 regex) (ice-9 rdelim)) - -(define command-name (match:substring (regexp-exec (make-regexp "[[:alpha:]]*$") - (car (command-line))))) - - - -;; Code contributed by Sergey Poznyakoff. Print an error message (made up from -;; the parts of rest), and if the error is fatal (present and non-zero) then -;; exit to the system with this code. - -(define (mcron-error exit-code . rest) - (with-output-to-port (current-error-port) - (lambda () - (for-each display (append (list command-name ": ") rest)) - (newline))) - (if (and exit-code (not (eq? exit-code 0))) - (primitive-exit exit-code))) - - - -;; Code contributed by Sergey Poznyakoff. Execute body. If an 'mcron-error -;; exception occurs, print its diagnostics and exit with its error code. - -(defmacro catch-mcron-error (. body) - `(catch 'mcron-error - (lambda () - ,@body) - (lambda (key exit-code . msg) - (apply mcron-error exit-code msg)))) - - - -;; We will be doing a lot of testing of the command name, so it makes sense to -;; perform the string comparisons once and for all here. - -(define command-type (cond ((string=? command-name "mcron") 'mcron) - ((or (string=? command-name "cron") - (string=? command-name "crond")) 'cron) - ((string=? command-name "crontab") 'crontab) - (else - (mcron-error 12 "The command name is invalid.")))) - - - -;; 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. - -(use-modules (ice-9 getopt-long)) - -(define options - (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)))))) - -;; If the user asked for the version of this program, give it to him and get -;; out. - -(if (option-ref options 'version #f) - (begin - (display (string-append "\n -" command-name " (" config-package-string ")\n -Written by Dale Mellor\n -\n -Copyright (C) 2003, 2006, 2014 Dale Mellor\n -This is free software; see the source for copying conditions. There is NO\n -warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.\n -")) - (quit))) - - - -;; Likewise if the user requested the help text. - -(if (option-ref options 'help #f) - (begin - (display (string-append " -Usage: " (car (command-line)) -(case command-type - - ((mcron) -" [OPTIONS] [FILES]\n -Run an mcron process according to the specifications in the FILES (`-' for\n -standard input), or use all the files in ~/.config/cron (or the \n -deprecated ~/.cron) with .guile or .vixie extensions.\n -\n - -v, --version Display version\n - -h, --help Display this help message\n - -sN, --schedule[=]N Display the next N jobs that will be run by mcron\n - -d, --daemon Immediately detach the program from the terminal\n - and run as a daemon process\n - -i, --stdin=(guile|vixie) Format of data passed as standard input or\n - file arguments (default guile)") - - ((cron) -" [OPTIONS]\n -Unless an option is specified, run a cron daemon as a detached process, \n -reading all the information in the users' crontabs and in /etc/crontab.\n -\n - -v, --version Display version\n - -h, --help Display this help message\n - -sN, --schedule[=]N Display the next N jobs that will be run by cron\n - -n, --noetc Do not check /etc/crontab for updates (HIGHLY\n - RECOMMENDED).") - - ((crontab) - (string-append " [-u user] file\n" - " " (car (command-line)) " [-u user] { -e | -l | -r }\n" - " (default operation is replace, per 1003.2)\n" - " -e (edit user's crontab)\n" - " -l (list user's crontab)\n" - " -r (delete user's crontab)\n")) - - (else "rubbish")) - -"\n\n -Report bugs to " config-package-bugreport ".\n -")) - (quit))) - - - -;; This is called from the C front-end whenever a terminal signal is -;; received. We remove the /var/run/cron.pid file so that crontab and other -;; invocations of cron don't get the wrong idea that a daemon is currently -;; running. - -(define (delete-run-file) - (catch #t (lambda () (delete-file config-pid-file) - (delete-file config-socket-file)) - noop) - (quit)) - - - -;; 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). - -(if (eq? command-type 'cron) - (begin - (if (not (eqv? (getuid) 0)) - (mcron-error 16 - "This program must be run by the root user (and should " - "have been installed as such).")) - (if (access? config-pid-file F_OK) - (mcron-error 1 - "A cron daemon is already running.\n" - " (If you are sure this is not true, remove the file\n" - " " - config-pid-file - ".)")) - (if (not (option-ref options 'schedule #f)) - (with-output-to-file config-pid-file noop)) - (setenv "MAILTO" #f) - (c-set-cron-signals))) - - - -;; Define the functions available to the configuration files. While we're here, -;; we'll get the core loaded as well. - -(use-modules (mcron core) - (mcron job-specifier) - (mcron vixie-specification)) - - - -;; Procedure to slurp the standard input into a string. - -(define (stdin->string) - (with-output-to-string (lambda () (do ((in (read-char) (read-char))) - ((eof-object? in)) - (display in))))) - - - -;; 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. - -(if (eq? command-type 'crontab) - (begin - (load "crontab.scm") - (quit))) - - - -;; Code contributed by Sergey Poznyakoff. Determine if the given file is a -;; regular file or not. - -(define (regular-file? file) - (catch 'system-error - (lambda () - (eq? (stat:type (stat file)) 'regular)) - (lambda (key call fmt args . rest) - (mcron-error 0 (apply format (append (list #f fmt) args))) - #f))) - - - -;; Procedure which processes any configuration file according to the -;; extension. If a file is not recognized, it is silently ignored (this deals -;; properly with most editors' backup files, for instance). - -(define guile-file-regexp (make-regexp "\\.gui(le)?$")) -(define vixie-file-regexp (make-regexp "\\.vix(ie)?$")) - -(define (process-user-file file-path . assume-guile) - (cond ((string=? file-path "-") - (if (string=? (option-ref options 'stdin "guile") "vixie") - (read-vixie-port (current-input-port)) - (eval-string (stdin->string)))) - ((or (not (null? assume-guile)) - (regexp-exec guile-file-regexp file-path)) - (load file-path)) - ((regexp-exec vixie-file-regexp file-path) - (read-vixie-file file-path)))) - - - -;; Procedure to run through all the files in a user's ~/.cron and/or -;; $XDG_CONFIG_HOME/cron or ~/.config/cron directories (only happens under the -;; mcron personality). - -(define (process-files-in-user-directory) - (let ((errors 0) - (home-directory (passwd:dir (getpw (getuid))))) - (map (lambda (config-directory) - (catch #t - (lambda () - (let ((directory (opendir config-directory))) - (do ((file-name (readdir directory) (readdir directory))) - ((eof-object? file-name) (closedir directory)) - (process-user-file (string-append config-directory - "/" - file-name))))) - (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"))) - (if (eq? 2 errors) - (mcron-error 13 - "Cannot read files in your ~/.config/cron (or ~/.cron) " - "directory.")))) - - - -;; Procedure to check that a user name is in the passwd database (it may happen -;; that a user is removed after creating a crontab). If the user name is valid, -;; the full passwd entry for that user is returned to the caller. - -(define (valid-user user-name) - (setpwent) - (do ((entry (getpw) (getpw))) - ((or (not entry) - (string=? (passwd:name entry) user-name)) - (endpwent) - entry))) - - - -;; Procedure to process all the files in the crontab directory, making sure that -;; each file is for a legitimate user and setting the configuration-user to that -;; user. In this way, when the job procedure is run on behalf of the -;; configuration files, the jobs are registered with the system with the -;; appropriate user. Note that only the root user should be able to perform this -;; operation, but we leave it to the permissions on the /var/cron/tabs directory -;; to enforce this. - -(use-modules (srfi srfi-2)) ;; For and-let*. - -(define (process-files-in-system-directory) - (catch #t - (lambda () - (let ((directory (opendir config-spool-dir))) - (do ((file-name (readdir directory) (readdir directory))) - ((eof-object? file-name)) - (and-let* ((user (valid-user file-name))) - (set-configuration-user user) ;; / ?? !!!! - (catch-mcron-error - (read-vixie-file (string-append config-spool-dir - "/" - file-name))))))) - (lambda (key . args) - (mcron-error - 4 - "You do not have permission to access the system crontabs.")))) - - - -;; 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) - (if (not (option-ref options 'noetc #f)) - (begin - (display -"WARNING: cron will check for updates to /etc/crontab EVERY MINUTE. If you do\n -not use this file, or you are prepared to manually restart cron whenever you\n -make a change, then it is HIGHLY RECOMMENDED that you use the --noetc\n -option.\n") - (set-configuration-user "root") - (job '(- (next-minute-from (next-minute)) 6) - check-system-crontab - "/etc/crontab update checker."))))) - - - -;; 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. - -(if (option-ref options 'daemon (eq? command-type 'cron)) - (begin - (if (not (eqv? (primitive-fork) 0)) - (quit)) - (setsid) - (if (eq? command-type 'cron) - (with-output-to-file config-pid-file - (lambda () (display (getpid)) (newline)))))) - - - -;; If we are running as cron or crond, we establish a socket to listen for -;; updates from a crontab program. This is put into fd-list so that we can -;; inform the main wait-run-wait execution loop to listen for incoming messages -;; on this socket. - -(define fd-list '()) - -(if (eq? command-type 'cron) - (catch #t - (lambda () - (let ((socket (socket AF_UNIX SOCK_STREAM 0))) - (bind socket AF_UNIX config-socket-file) - (listen socket 5) - (set! fd-list (list socket)))) - (lambda (key . args) - (delete-file config-pid-file) - (mcron-error 1 - "Cannot bind to UNIX socket " - config-socket-file)))) - - - - -;; This function is called whenever a message comes in on the above socket. We -;; 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 we drop all the system jobs and -;; re-read the /etc/crontab file. - -(define (process-update-request) - (let* ((socket (car (accept (car fd-list)))) - (user-name (read-line socket))) - (close socket) - (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))))))) - - - -;; Added by Sergey Poznyakoff. This no-op will collect zombie child processes -;; as soon as they die. This is a big improvement as previously they stayed -;; around the system until the next time mcron wakes to fire a new job off. - -;; Unfortunately it seems to interact badly with the select system call, -;; wreaking havoc... - -;; (sigaction SIGCHLD (lambda (sig) noop) SA_RESTART) - - - -;; Now the main loop. Forever execute the run-job-loop procedure in the mcron -;; core, and when it drops out (can only be because a message has come in on the -;; socket) we process the socket request before restarting the loop again. -;; Sergey Poznyakoff: we can also drop out of run-job-loop because of a SIGCHLD, -;; so must test fd-list. - -(catch-mcron-error - (while #t - (run-job-loop fd-list) - (if (not (null? fd-list)) - (process-update-request)))) diff --git a/makefile.am b/makefile.am index 85610df..a7f0e75 100644 --- a/makefile.am +++ b/makefile.am @@ -18,40 +18,33 @@ ## Process this file with automake to produce Makefile.in +SUBDIRS = scm/mcron . + ED = @ED@ # !!!! Are these needed? CP = @CP@ MAINTAINERCLEANFILES = configure makefile makefile.in config.guess config.sub \ install-sh missing texinfo.tex INSTALL \ - aclocal.m4 compile depcomp + aclocal.m4 compile depcomp mcron.1 CLEANFILES = mcron.c core.scm -EXTRA_DIST = makefile.ed main.scm mcron-core.scm vixie-specification.scm \ - crontab.scm environment.scm job-specifier.scm redirect.scm \ - vixie-time.scm mcron.c.template BUGS +EXTRA_DIST = makefile.ed mcron.c.template BUGS info_TEXINFOS = mcron.texinfo -dist_man1_MANS = mcron.1 +man_MANS = mcron.1 bin_PROGRAMS = mcron mcron_SOURCES = mcron.c mcron_LDADD = @GUILE_LIBS@ -mcron_CFLAGS = @GUILE_CFLAGS@ -DGUILE_LOAD_PATH=\"$(datadir)\" - -pkgdata_DATA = core.scm environment.scm job-specifier.scm redirect.scm \ - vixie-time.scm vixie-specification.scm config.scm - -# If you're wondering, the configure script keeps deleting all files with a name -# like core.*, so we have to keep re-making it (I lost a good day's work because -# of this). +# The second option is so that we can execute the binary in the local directory, +# in turn so that we can do mcron --help during the build process. +mcron_CFLAGS = @GUILE_CFLAGS@ -DGUILE_LOAD_PATH=\"$(datadir):./scm:...\" -core.scm : mcron-core.scm - $(CP) mcron-core.scm core.scm -mcron.c : main.scm crontab.scm makefile.ed mcron.c.template +mcron.c : scm/mcron/main.scm scm/mcron/crontab.scm makefile.ed mcron.c.template @echo 'Building mcron.c...' @$(ED) < makefile.ed > /dev/null 2>&1 @rm -f mcron.escaped.scm > /dev/null 2>&1 @@ -76,9 +69,6 @@ install-exec-hook: else \ echo "+++ WARNING: NON-ROOT INSTALL: ONLY mcron WILL BE INSTALLED, NOT ANY OF THE VIXIE REPLACEMENT PROGRAMS"; \ fi - @echo - @echo " AFTER INSTALLATION, CONSIDER RUNNING make cook-up-man" - @echo uninstall-hook: @@ -89,7 +79,6 @@ uninstall-hook: # Not part of formal package building, but a rule for manual use to get the # elemental man page. Will only work once the mcron program is installed. -cook-up-man: - help2man -n 'a program to run tasks at regular (or not) intervals' \ - $(fpp)mcron > mcron.1 - $(MAKE) install +mcron.1 : mcron.c + $(HELP2MAN) -n 'a program to run tasks at regular (or not) intervals' \ + ./mcron > mcron.1 diff --git a/makefile.ed b/makefile.ed index 5c89344..7047ec7 100644 --- a/makefile.ed +++ b/makefile.ed @@ -17,9 +17,9 @@ # # # -e main.scm +e scm/mcron/main.scm /\(load "crontab.scm"\)/d --1r crontab.scm +-1r scm/mcron/crontab.scm %s/\\/\\\\/g %s/"/\\"/g %s/ *;;.*$/ /g diff --git a/mcron-core.scm b/mcron-core.scm deleted file mode 100644 index 518bcac..0000000 --- a/mcron-core.scm +++ /dev/null @@ -1,271 +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 . - - - -(define-module (mcron core) - #:use-module (mcron environment) - #:export (add-job - remove-user-jobs - get-schedule - run-job-loop - ;; These three are deprecated and not documented. - use-system-job-list - use-user-job-list - clear-system-jobs) - #:re-export (clear-environment-mods - append-environment-mods)) - - -(use-modules (srfi srfi-1) ;; For remove. - (srfi srfi-2)) ;; For and-let*. - - - -;; The list of all jobs known to the system. Each element of the list is -;; -;; (vector user next-time-function action environment displayable next-time) -;; -;; where action 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)) - - - -;; Convenience functions for getting and setting the elements of a job object. - -(define (job:user job) (vector-ref job 0)) -(define (job:next-time-function job) (vector-ref job 1)) -(define (job:action job) (vector-ref job 2)) -(define (job:environment job) (vector-ref job 3)) -(define (job:displayable job) (vector-ref job 4)) -(define (job:next-time job) (vector-ref job 5)) - - - -;; 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 (vector 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) - (vector-set! job - 5 - ((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)) - (vector-set! job - 5 - ((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/mcron.1 b/mcron.1 deleted file mode 100644 index e69de29..0000000 diff --git a/redirect.scm b/redirect.scm deleted file mode 100644 index 312b768..0000000 --- a/redirect.scm +++ /dev/null @@ -1,189 +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 . - - - -;; 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 ((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/config.scm.in b/scm/mcron/config.scm.in new file mode 100644 index 0000000..6a0a85d --- /dev/null +++ b/scm/mcron/config.scm.in @@ -0,0 +1,35 @@ +;; -*-scheme-*- + +;; 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 . + + +;; Some constants set by the configuration process. + +(define-module (mcron config)) + +(define-public config-debug @CONFIG_DEBUG@) +(define-public config-package-string "@PACKAGE_STRING@") +(define-public config-package-bugreport "@PACKAGE_BUGREPORT@") +(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 new file mode 100644 index 0000000..30e5592 --- /dev/null +++ b/scm/mcron/crontab.scm @@ -0,0 +1,228 @@ +;; 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 . + + +;; 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 new file mode 100644 index 0000000..9f694f1 --- /dev/null +++ b/scm/mcron/environment.scm @@ -0,0 +1,105 @@ +;; 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 . + + + +;; 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)) + + + + +;; The env-alist is an association list of variable names and values. Variables +;; later in the list will take precedence over variables before. We return a +;; fixed-up version in which some variables are given specific default values +;; (which the user can override), and two variables which the user is not +;; allowed to control are added at the end of the list. + +(define (impose-default-environment env-alist passwd-entry) + (append `(("HOME" . ,(passwd:dir passwd-entry)) + ("CWD" . ,(passwd:dir passwd-entry)) + ("SHELL" . ,(passwd:shell passwd-entry)) + ("TERM" . #f) + ("TERMCAP" . #f)) + env-alist + `(("LOGNAME" . ,(passwd:name passwd-entry)) + ("USER" . ,(passwd:name passwd-entry))))) + + + + +;; Modify the UNIX environment for the current process according to the given +;; association list of variables, with the default variable values imposed. + +(define (modify-environment env-alist passwd-entry) + (for-each (lambda (variable) + (setenv (car variable) (cdr variable))) + (impose-default-environment env-alist passwd-entry))) + + + + +;; 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) diff --git a/scm/mcron/job-specifier.scm b/scm/mcron/job-specifier.scm new file mode 100644 index 0000000..cce948c --- /dev/null +++ b/scm/mcron/job-specifier.scm @@ -0,0 +1,272 @@ +;; 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 . + + + +;; 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) + #: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 + find-best-next) + #:use-module (mcron core) + #:use-module (mcron environment) + #:use-module (mcron vixie-time) + #:re-export (append-environment-mods)) + + + +;; Function (available to user configuration files) which 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). + +(define (range start end . step) + (let ((step (if (or (null? step) + (<= (car step) 0)) + 1 + (car step)))) + (let loop ((start start)) + (if (>= start end) '() + (cons start + (loop (+ start step))))))) + + + +;; Internal function (not supposed to be used directly in configuration files; +;; it is exported from the module for the convenience of other parts of the +;; mcron implementation) which 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 list, and the smallest element larger than the current +;; value. If an example of the latter cannot be found, 9999 will be returned. + +(define (find-best-next current next-list) + (let ((current-best (cons 9999 9999))) + (for-each (lambda (allowed-time) + (if (< allowed-time (car current-best)) + (set-car! current-best allowed-time)) + (if (and (> allowed-time current) + (< allowed-time (cdr current-best))) + (set-cdr! current-best allowed-time))) + next-list) + current-best)) + + + +;; 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 new file mode 100644 index 0000000..36adef9 --- /dev/null +++ b/scm/mcron/main.scm @@ -0,0 +1,503 @@ +;; 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 . + + + +;; This is the 'main' routine for the whole system; the top of this file is the +;; global entry point (after the minimal C wrapper, mcron.c.template); to all +;; intents and purposes the program is pure Guile and starts here. +;; +;; This file is built into mcron.c.template by the makefile, which stringifies +;; the whole lot, and escapes quotation marks and escape characters +;; accordingly. Bear this in mind when considering literal multi-line strings. +;; +;; (l0ad "crontab.scm") (sic) is inlined by the makefile. All other +;; functionality comes through modules in .../share/guile/site/mcron/*.scm. + + + +;; Pull in some constants set by the builder (via autoconf) at configuration +;; time. Turn debugging on if indicated. + +(use-modules (mcron config)) +(if config-debug (begin (debug-enable 'debug) + (debug-enable 'backtrace))) + + + +;; To determine the name of the program, scan the first item of the command line +;; backwards for the first non-alphabetic character. This allows names like +;; in.cron to be accepted as an invocation of the cron command. + +(use-modules (ice-9 regex) (ice-9 rdelim)) + +(define command-name (match:substring (regexp-exec (make-regexp "[[:alpha:]]*$") + (car (command-line))))) + + + +;; Code contributed by Sergey Poznyakoff. Print an error message (made up from +;; the parts of rest), and if the error is fatal (present and non-zero) then +;; exit to the system with this code. + +(define (mcron-error exit-code . rest) + (with-output-to-port (current-error-port) + (lambda () + (for-each display (append (list command-name ": ") rest)) + (newline))) + (if (and exit-code (not (eq? exit-code 0))) + (primitive-exit exit-code))) + + + +;; Code contributed by Sergey Poznyakoff. Execute body. If an 'mcron-error +;; exception occurs, print its diagnostics and exit with its error code. + +(defmacro catch-mcron-error (. body) + `(catch 'mcron-error + (lambda () + ,@body) + (lambda (key exit-code . msg) + (apply mcron-error exit-code msg)))) + + + +;; We will be doing a lot of testing of the command name, so it makes sense to +;; perform the string comparisons once and for all here. + +(define command-type (cond ((string=? command-name "mcron") 'mcron) + ((or (string=? command-name "cron") + (string=? command-name "crond")) 'cron) + ((string=? command-name "crontab") 'crontab) + (else + (mcron-error 12 "The command name is invalid.")))) + + + +;; 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. + +(use-modules (ice-9 getopt-long)) + +(define options + (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)))))) + +;; If the user asked for the version of this program, give it to him and get +;; out. + +(if (option-ref options 'version #f) + (begin + (display (string-append "\n +" command-name " (" config-package-string ")\n +Written by Dale Mellor\n +\n +Copyright (C) 2003, 2006, 2014 Dale Mellor\n +This is free software; see the source for copying conditions. There is NO\n +warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.\n +")) + (quit))) + + + +;; Likewise if the user requested the help text. + +(if (option-ref options 'help #f) + (begin + (display (string-append " +Usage: " (car (command-line)) +(case command-type + + ((mcron) +" [OPTIONS] [FILES]\n +Run an mcron process according to the specifications in the FILES (`-' for\n +standard input), or use all the files in ~/.config/cron (or the \n +deprecated ~/.cron) with .guile or .vixie extensions.\n +\n + -v, --version Display version\n + -h, --help Display this help message\n + -sN, --schedule[=]N Display the next N jobs that will be run by mcron\n + -d, --daemon Immediately detach the program from the terminal\n + and run as a daemon process\n + -i, --stdin=(guile|vixie) Format of data passed as standard input or\n + file arguments (default guile)") + + ((cron) +" [OPTIONS]\n +Unless an option is specified, run a cron daemon as a detached process, \n +reading all the information in the users' crontabs and in /etc/crontab.\n +\n + -v, --version Display version\n + -h, --help Display this help message\n + -sN, --schedule[=]N Display the next N jobs that will be run by cron\n + -n, --noetc Do not check /etc/crontab for updates (HIGHLY\n + RECOMMENDED).") + + ((crontab) + (string-append " [-u user] file\n" + " " (car (command-line)) " [-u user] { -e | -l | -r }\n" + " (default operation is replace, per 1003.2)\n" + " -e (edit user's crontab)\n" + " -l (list user's crontab)\n" + " -r (delete user's crontab)\n")) + + (else "rubbish")) + +"\n\n +Report bugs to " config-package-bugreport ".\n +")) + (quit))) + + + +;; This is called from the C front-end whenever a terminal signal is +;; received. We remove the /var/run/cron.pid file so that crontab and other +;; invocations of cron don't get the wrong idea that a daemon is currently +;; running. + +(define (delete-run-file) + (catch #t (lambda () (delete-file config-pid-file) + (delete-file config-socket-file)) + noop) + (quit)) + + + +;; 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). + +(if (eq? command-type 'cron) + (begin + (if (not (eqv? (getuid) 0)) + (mcron-error 16 + "This program must be run by the root user (and should " + "have been installed as such).")) + (if (access? config-pid-file F_OK) + (mcron-error 1 + "A cron daemon is already running.\n" + " (If you are sure this is not true, remove the file\n" + " " + config-pid-file + ".)")) + (if (not (option-ref options 'schedule #f)) + (with-output-to-file config-pid-file noop)) + (setenv "MAILTO" #f) + (c-set-cron-signals))) + + + +;; Define the functions available to the configuration files. While we're here, +;; we'll get the core loaded as well. + +(use-modules (mcron core) + (mcron job-specifier) + (mcron vixie-specification)) + + + +;; Procedure to slurp the standard input into a string. + +(define (stdin->string) + (with-output-to-string (lambda () (do ((in (read-char) (read-char))) + ((eof-object? in)) + (display in))))) + + + +;; 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. + +(if (eq? command-type 'crontab) + (begin + (load "crontab.scm") + (quit))) + + + +;; Code contributed by Sergey Poznyakoff. Determine if the given file is a +;; regular file or not. + +(define (regular-file? file) + (catch 'system-error + (lambda () + (eq? (stat:type (stat file)) 'regular)) + (lambda (key call fmt args . rest) + (mcron-error 0 (apply format (append (list #f fmt) args))) + #f))) + + + +;; Procedure which processes any configuration file according to the +;; extension. If a file is not recognized, it is silently ignored (this deals +;; properly with most editors' backup files, for instance). + +(define guile-file-regexp (make-regexp "\\.gui(le)?$")) +(define vixie-file-regexp (make-regexp "\\.vix(ie)?$")) + +(define (process-user-file file-path . assume-guile) + (cond ((string=? file-path "-") + (if (string=? (option-ref options 'stdin "guile") "vixie") + (read-vixie-port (current-input-port)) + (eval-string (stdin->string)))) + ((or (not (null? assume-guile)) + (regexp-exec guile-file-regexp file-path)) + (load file-path)) + ((regexp-exec vixie-file-regexp file-path) + (read-vixie-file file-path)))) + + + +;; Procedure to run through all the files in a user's ~/.cron and/or +;; $XDG_CONFIG_HOME/cron or ~/.config/cron directories (only happens under the +;; mcron personality). + +(define (process-files-in-user-directory) + (let ((errors 0) + (home-directory (passwd:dir (getpw (getuid))))) + (map (lambda (config-directory) + (catch #t + (lambda () + (let ((directory (opendir config-directory))) + (do ((file-name (readdir directory) (readdir directory))) + ((eof-object? file-name) (closedir directory)) + (process-user-file (string-append config-directory + "/" + file-name))))) + (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"))) + (if (eq? 2 errors) + (mcron-error 13 + "Cannot read files in your ~/.config/cron (or ~/.cron) " + "directory.")))) + + + +;; Procedure to check that a user name is in the passwd database (it may happen +;; that a user is removed after creating a crontab). If the user name is valid, +;; the full passwd entry for that user is returned to the caller. + +(define (valid-user user-name) + (setpwent) + (do ((entry (getpw) (getpw))) + ((or (not entry) + (string=? (passwd:name entry) user-name)) + (endpwent) + entry))) + + + +;; Procedure to process all the files in the crontab directory, making sure that +;; each file is for a legitimate user and setting the configuration-user to that +;; user. In this way, when the job procedure is run on behalf of the +;; configuration files, the jobs are registered with the system with the +;; appropriate user. Note that only the root user should be able to perform this +;; operation, but we leave it to the permissions on the /var/cron/tabs directory +;; to enforce this. + +(use-modules (srfi srfi-2)) ;; For and-let*. + +(define (process-files-in-system-directory) + (catch #t + (lambda () + (let ((directory (opendir config-spool-dir))) + (do ((file-name (readdir directory) (readdir directory))) + ((eof-object? file-name)) + (and-let* ((user (valid-user file-name))) + (set-configuration-user user) ;; / ?? !!!! + (catch-mcron-error + (read-vixie-file (string-append config-spool-dir + "/" + file-name))))))) + (lambda (key . args) + (mcron-error + 4 + "You do not have permission to access the system crontabs.")))) + + + +;; 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) + (if (not (option-ref options 'noetc #f)) + (begin + (display +"WARNING: cron will check for updates to /etc/crontab EVERY MINUTE. If you do\n +not use this file, or you are prepared to manually restart cron whenever you\n +make a change, then it is HIGHLY RECOMMENDED that you use the --noetc\n +option.\n") + (set-configuration-user "root") + (job '(- (next-minute-from (next-minute)) 6) + check-system-crontab + "/etc/crontab update checker."))))) + + + +;; 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. + +(if (option-ref options 'daemon (eq? command-type 'cron)) + (begin + (if (not (eqv? (primitive-fork) 0)) + (quit)) + (setsid) + (if (eq? command-type 'cron) + (with-output-to-file config-pid-file + (lambda () (display (getpid)) (newline)))))) + + + +;; If we are running as cron or crond, we establish a socket to listen for +;; updates from a crontab program. This is put into fd-list so that we can +;; inform the main wait-run-wait execution loop to listen for incoming messages +;; on this socket. + +(define fd-list '()) + +(if (eq? command-type 'cron) + (catch #t + (lambda () + (let ((socket (socket AF_UNIX SOCK_STREAM 0))) + (bind socket AF_UNIX config-socket-file) + (listen socket 5) + (set! fd-list (list socket)))) + (lambda (key . args) + (delete-file config-pid-file) + (mcron-error 1 + "Cannot bind to UNIX socket " + config-socket-file)))) + + + + +;; This function is called whenever a message comes in on the above socket. We +;; 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 we drop all the system jobs and +;; re-read the /etc/crontab file. + +(define (process-update-request) + (let* ((socket (car (accept (car fd-list)))) + (user-name (read-line socket))) + (close socket) + (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))))))) + + + +;; Added by Sergey Poznyakoff. This no-op will collect zombie child processes +;; as soon as they die. This is a big improvement as previously they stayed +;; around the system until the next time mcron wakes to fire a new job off. + +;; Unfortunately it seems to interact badly with the select system call, +;; wreaking havoc... + +;; (sigaction SIGCHLD (lambda (sig) noop) SA_RESTART) + + + +;; Now the main loop. Forever execute the run-job-loop procedure in the mcron +;; core, and when it drops out (can only be because a message has come in on the +;; socket) we process the socket request before restarting the loop again. +;; Sergey Poznyakoff: we can also drop out of run-job-loop because of a SIGCHLD, +;; so must test fd-list. + +(catch-mcron-error + (while #t + (run-job-loop fd-list) + (if (not (null? fd-list)) + (process-update-request)))) diff --git a/scm/mcron/mcron-core.scm b/scm/mcron/mcron-core.scm new file mode 100644 index 0000000..518bcac --- /dev/null +++ b/scm/mcron/mcron-core.scm @@ -0,0 +1,271 @@ +;; 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 . + + + +(define-module (mcron core) + #:use-module (mcron environment) + #:export (add-job + remove-user-jobs + get-schedule + run-job-loop + ;; These three are deprecated and not documented. + use-system-job-list + use-user-job-list + clear-system-jobs) + #:re-export (clear-environment-mods + append-environment-mods)) + + +(use-modules (srfi srfi-1) ;; For remove. + (srfi srfi-2)) ;; For and-let*. + + + +;; The list of all jobs known to the system. Each element of the list is +;; +;; (vector user next-time-function action environment displayable next-time) +;; +;; where action 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)) + + + +;; Convenience functions for getting and setting the elements of a job object. + +(define (job:user job) (vector-ref job 0)) +(define (job:next-time-function job) (vector-ref job 1)) +(define (job:action job) (vector-ref job 2)) +(define (job:environment job) (vector-ref job 3)) +(define (job:displayable job) (vector-ref job 4)) +(define (job:next-time job) (vector-ref job 5)) + + + +;; 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 (vector 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) + (vector-set! job + 5 + ((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)) + (vector-set! job + 5 + ((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 new file mode 100644 index 0000000..312b768 --- /dev/null +++ b/scm/mcron/redirect.scm @@ -0,0 +1,189 @@ +;; 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 . + + + +;; 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 ((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 new file mode 100644 index 0000000..ab002ba --- /dev/null +++ b/scm/mcron/vixie-specification.scm @@ -0,0 +1,209 @@ +;; 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 . + + + +;; 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 new file mode 100644 index 0000000..2f26a6d --- /dev/null +++ b/scm/mcron/vixie-time.scm @@ -0,0 +1,385 @@ +;; 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 . + + +(define-module (mcron vixie-time) + #:export (parse-vixie-time) + #:use-module (mcron job-specifier)) + + +(use-modules (srfi srfi-1) (srfi srfi-13) (srfi srfi-14) + (ice-9 regex)) + + +;; 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)) + (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] + + diff --git a/vixie-specification.scm b/vixie-specification.scm deleted file mode 100644 index ab002ba..0000000 --- a/vixie-specification.scm +++ /dev/null @@ -1,209 +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 . - - - -;; 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/vixie-time.scm b/vixie-time.scm deleted file mode 100644 index 2f26a6d..0000000 --- a/vixie-time.scm +++ /dev/null @@ -1,385 +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 . - - -(define-module (mcron vixie-time) - #:export (parse-vixie-time) - #:use-module (mcron job-specifier)) - - -(use-modules (srfi srfi-1) (srfi srfi-13) (srfi srfi-14) - (ice-9 regex)) - - -;; 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)) - (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] - - -- cgit v1.2.3