272 lines
11 KiB
Scheme
272 lines
11 KiB
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 <http://www.gnu.org/licenses/>.
|
|
|
|
|
|
|
|
;; This module defines all the functions that can be used by scheme mcron
|
|
;; configuration files, namely the procedures for working out next times, the
|
|
;; job procedure for registering new jobs (actually a wrapper around the core
|
|
;; add-job function), and the procedure for declaring environment modifications.
|
|
|
|
(define-module (mcron job-specifier)
|
|
#: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)))
|