From 418b81e1af8d18c86693cb43ffe89354af28e3a8 Mon Sep 17 00:00:00 2001
From: Mathieu Lirzin <mthl@gnu.org>
Date: Sat, 7 May 2016 13:08:06 +0200
Subject: base: Rename (mcron core) module to (mcron base).
The 'configure' script deletes the 'core.*' files. Having a file named
'base.scm' instead of 'core.scm' simplifies the build process without
changing the semantics.
* src/mcron/mcron-core.scm: Rename to ...
* src/mcron/base.scm: ... this.
All module users changed.
* Makefile.am (MODULES): Add 'src/mcron/base.scm'.
(CP): Remove variable.
(src/mcron/core.scm): Remove target.
(GEN_MODULES): Remove 'src/mcron/core.scm'.
(dist_mcronmodule_DATA): Remove 'src/mcron/mcron-core.scm'
* doc/mcron.texi: Adapt to name change.
* .gitignore: Update.
---
src/mcron/base.scm | 270 ++++++++++++++++++++++++++++++++++++++
src/mcron/job-specifier.scm | 7 +-
src/mcron/main.scm | 4 +-
src/mcron/mcron-core.scm | 270 --------------------------------------
src/mcron/vixie-specification.scm | 2 +-
5 files changed, 277 insertions(+), 276 deletions(-)
create mode 100644 src/mcron/base.scm
delete mode 100644 src/mcron/mcron-core.scm
(limited to 'src/mcron')
diff --git a/src/mcron/base.scm b/src/mcron/base.scm
new file mode 100644
index 0000000..7094dbc
--- /dev/null
+++ b/src/mcron/base.scm
@@ -0,0 +1,270 @@
+;; Copyright (C) 2015, 2016 Mathieu Lirzin
+;; Copyright (C) 2003 Dale Mellor
+;;
+;; This file is part of GNU mcron.
+;;
+;; GNU mcron is free software: you can redistribute it and/or modify it under
+;; the terms of the GNU General Public License as published by the Free
+;; Software Foundation, either version 3 of the License, or (at your option)
+;; any later version.
+;;
+;; GNU mcron is distributed in the hope that it will be useful, but WITHOUT
+;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
+;; more details.
+;;
+;; You should have received a copy of the GNU General Public License along
+;; with GNU mcron. If not, see <http://www.gnu.org/licenses/>.
+
+
+
+(define-module (mcron base)
+ #:use-module (mcron environment)
+ #:use-module (srfi srfi-9)
+ #:export (add-job
+ remove-user-jobs
+ get-schedule
+ run-job-loop
+ ;; These three are deprecated and not documented.
+ use-system-job-list
+ use-user-job-list
+ clear-system-jobs)
+ #:re-export (clear-environment-mods
+ append-environment-mods))
+
+
+(use-modules (srfi srfi-1) ;; For remove.
+ (srfi srfi-2)) ;; For and-let*.
+
+
+
+;; The list of all jobs known to the system. Each element of the list is
+;;
+;; (make-job user next-time-function action environment displayable next-time)
+;;
+;; where action must be a procedure, and the environment is an alist of
+;; modifications that need making to the UNIX environment before the action is
+;; run. The next-time element is the only one that is modified during the
+;; running of a cron process (i.e. all the others are set once and for all at
+;; configuration time).
+;;
+;; The reason we maintain two lists is that jobs in /etc/crontab may be placed
+;; in one, and all other jobs go in the other. This makes it possible to remove
+;; all the jobs in the first list in one go, and separately we can remove all
+;; jobs from the second list which belong to a particular user. This behaviour
+;; is required for full vixie compatibility.
+
+(define system-job-list '())
+(define user-job-list '())
+
+(define configuration-source 'user)
+
+(define (use-system-job-list) (set! configuration-source 'system))
+(define (use-user-job-list) (set! configuration-source 'user))
+
+;; A cron job.
+(define-record-type <job>
+ (make-job user time-proc action environment displayable next-time)
+ job?
+ (user job:user) ;object : passwd entry
+ (time-proc job:next-time-function) ;proc : with one 'time' parameter
+ (action job:action) ;thunk : user's code
+ (environment job:environment) ;alist : environment variables
+ (displayable job:displayable) ;string : visible in schedule
+ (next-time job:next-time ;number : time in UNIX format
+ job:next-time-set!))
+
+;; Remove jobs from the user-job-list belonging to this user.
+
+(define (remove-user-jobs user)
+ (if (or (string? user)
+ (integer? user))
+ (set! user (getpw user)))
+ (set! user-job-list
+ (remove (lambda (job) (eqv? (passwd:uid user)
+ (passwd:uid (job:user job))))
+ user-job-list)))
+
+
+
+;; Remove all the jobs on the system job list.
+
+(define (clear-system-jobs) (set! system-job-list '()))
+
+
+
+;; Add a new job with the given specifications to the head of the appropriate
+;; jobs list.
+
+(define (add-job time-proc action displayable configuration-time
+ configuration-user)
+ (let ((entry (make-job configuration-user
+ time-proc
+ action
+ (get-current-environment-mods-copy)
+ displayable
+ (time-proc configuration-time))))
+ (if (eq? configuration-source 'user)
+ (set! user-job-list (cons entry user-job-list))
+ (set! system-job-list (cons entry system-job-list)))))
+
+
+
+;; Procedure to locate the jobs in the global job-list with the lowest
+;; (soonest) next-times. These are the jobs for which we must schedule the mcron
+;; program (under any personality) to next wake up. The return value is a cons
+;; cell consisting of the next time (maintained in the next-time variable) and a
+;; list of the job entries that are to run at this time (maintained in the
+;; next-jobs-list variable).
+;;
+;; The procedure works by first obtaining the time of the first job on the list,
+;; and setting this job in the next-jobs-list. Then for each other entry on the
+;; job-list, either the job runs earlier than any other that have been scanned,
+;; in which case the next-time and next-jobs-list are re-initialized to
+;; accomodate, or the job runs at the same time as the next job, in which case
+;; the next-jobs-list is simply augmented with the new job, or else the job runs
+;; later than others noted in which case we ignore it for now and continue to
+;; recurse the list.
+
+(define (find-next-jobs)
+ (let ((job-list (append system-job-list user-job-list)))
+
+ (if (null? job-list)
+
+ '(#f . '())
+
+ (let ((next-time 2000000000)
+ (next-jobs-list '()))
+
+ (for-each
+ (lambda (job)
+ (let ((this-time (job:next-time job)))
+ (cond ((< this-time next-time)
+ (set! next-time this-time)
+ (set! next-jobs-list (list job)))
+ ((eqv? this-time next-time)
+ (set! next-jobs-list (cons job next-jobs-list))))))
+ job-list)
+
+ (cons next-time next-jobs-list)))))
+
+
+
+;; Create a string containing a textual list of the next count jobs to run.
+;;
+;; Enter a loop of displaying the next set of jobs to run, artificially
+;; forwarding the time to the next time point (instead of waiting for it to
+;; occur as we would do in a normal run of mcron), and recurse around the loop
+;; count times.
+;;
+;; Note that this has the effect of mutating the job timings. Thus the program
+;; must exit after calling this function; the internal data state will be left
+;; unusable.
+
+(define (get-schedule count)
+ (with-output-to-string
+ (lambda ()
+ (do ((count count (- count 1)))
+ ((eqv? count 0))
+ (and-let*
+ ((next-jobs (find-next-jobs))
+ (time (car next-jobs))
+ (date-string (strftime "%c %z\n" (localtime time))))
+ (for-each (lambda (job)
+ (display date-string)
+ (display (job:displayable job))
+ (newline)(newline)
+ (job:next-time-set! job ((job:next-time-function job)
+ (job:next-time job))))
+ (cdr next-jobs)))))))
+
+
+
+;; For proper housekeeping, it is necessary to keep a record of the number of
+;; child processes we fork off to run the jobs.
+
+(define number-children 0)
+
+
+
+;; For every job on the list, fork a process to run it (noting the fact by
+;; increasing the number-children counter), and in the new process set up the
+;; run-time environment exactly as it should be before running the job proper.
+;;
+;; In the parent, update the job entry by computing the next time the job needs
+;; to run.
+
+(define (run-jobs jobs-list)
+ (for-each
+ (lambda (job)
+ (if (eqv? (primitive-fork) 0)
+ (begin
+ (setgid (passwd:gid (job:user job)))
+ (setuid (passwd:uid (job:user job)))
+ (chdir (passwd:dir (job:user job)))
+ (modify-environment (job:environment job) (job:user job))
+ ((job:action job))
+ (primitive-exit 0))
+ (begin
+ (set! number-children (+ number-children 1))
+ (job:next-time-set! job ((job:next-time-function job)
+ (current-time))))))
+ jobs-list))
+
+
+
+;; Give any zombie children a chance to die, and decrease the number known to
+;; exist.
+
+(define (child-cleanup)
+ (do () ((or (<= number-children 0)
+ (eqv? (car (waitpid WAIT_ANY WNOHANG)) 0)))
+ (set! number-children (- number-children 1))))
+
+
+
+;; Now the main loop. Loop over all job specifications, get a list of the next
+;; ones to run (may be more than one). Set an alarm and go to sleep. When we
+;; wake, run the jobs and reap any children (old jobs) that have
+;; completed. Repeat ad infinitum.
+;;
+;; Note that, if we wake ahead of time, it can only mean that a signal has been
+;; sent by a crontab job to tell us to re-read a crontab file. In this case we
+;; break out of the loop here, and let the main procedure deal with the
+;; situation (it will eventually re-call this function, thus maintaining the
+;; loop).
+
+(define (run-job-loop . fd-list)
+
+ (call-with-current-continuation
+ (lambda (break)
+
+ (let ((fd-list (if (null? fd-list) '() (car fd-list))))
+
+ (let loop ()
+
+ (let* ((next-jobs (find-next-jobs))
+ (next-time (car next-jobs))
+ (next-jobs-list (cdr next-jobs))
+ (sleep-time (if next-time (- next-time (current-time))
+ 2000000000)))
+
+ (and (> sleep-time 0)
+ (if (not (null?
+ (catch 'system-error
+ (lambda ()
+ (car (select fd-list '() '() sleep-time)))
+ (lambda (key . args) ;; Exception add by Sergey
+ ;; Poznyakoff.
+ (if (member (car (last args))
+ (list EINTR EAGAIN))
+ (begin
+ (child-cleanup) '())
+ (apply throw key args))))))
+ (break)))
+
+ (run-jobs next-jobs-list)
+
+ (child-cleanup)
+
+ (loop)))))))
diff --git a/src/mcron/job-specifier.scm b/src/mcron/job-specifier.scm
index 1c2f9d9..9e13551 100644
--- a/src/mcron/job-specifier.scm
+++ b/src/mcron/job-specifier.scm
@@ -20,12 +20,13 @@
;; 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.
+;; job procedure for registering new jobs (actually a wrapper around the
+;; base add-job function), and the procedure for declaring environment
+;; modifications.
(define-module (mcron job-specifier)
#:use-module (ice-9 match)
- #:use-module (mcron core)
+ #:use-module (mcron base)
#:use-module (mcron environment)
#:use-module (mcron vixie-time)
#:use-module (srfi srfi-1)
diff --git a/src/mcron/main.scm b/src/mcron/main.scm
index 1f2b068..db7dfd6 100644
--- a/src/mcron/main.scm
+++ b/src/mcron/main.scm
@@ -25,7 +25,7 @@
#:use-module (ice-9 rdelim)
#:use-module (ice-9 regex)
#:use-module (mcron config)
- #:use-module (mcron core)
+ #:use-module (mcron base)
#:use-module (mcron job-specifier)
#:use-module (mcron vixie-specification)
#:use-module (srfi srfi-2)
@@ -389,7 +389,7 @@ option.\n")
(lambda () (display (getpid)) (newline)))))
;; Now the main loop. Forever execute the run-job-loop procedure in the
- ;; mcron core, and when it drops out (can only be because a message has come
+ ;; mcron base, and when it drops out (can only be because a message has come
;; in on the socket) we process the socket request before restarting the
;; loop again. Sergey Poznyakoff: we can also drop out of run-job-loop
;; because of a SIGCHLD, so must test FDES-LIST.
diff --git a/src/mcron/mcron-core.scm b/src/mcron/mcron-core.scm
deleted file mode 100644
index 13781c9..0000000
--- a/src/mcron/mcron-core.scm
+++ /dev/null
@@ -1,270 +0,0 @@
-;; Copyright (C) 2015, 2016 Mathieu Lirzin
-;; Copyright (C) 2003 Dale Mellor
-;;
-;; This file is part of GNU mcron.
-;;
-;; GNU mcron is free software: you can redistribute it and/or modify it under
-;; the terms of the GNU General Public License as published by the Free
-;; Software Foundation, either version 3 of the License, or (at your option)
-;; any later version.
-;;
-;; GNU mcron is distributed in the hope that it will be useful, but WITHOUT
-;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
-;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
-;; more details.
-;;
-;; You should have received a copy of the GNU General Public License along
-;; with GNU mcron. If not, see <http://www.gnu.org/licenses/>.
-
-
-
-(define-module (mcron core)
- #:use-module (mcron environment)
- #:use-module (srfi srfi-9)
- #:export (add-job
- remove-user-jobs
- get-schedule
- run-job-loop
- ;; These three are deprecated and not documented.
- use-system-job-list
- use-user-job-list
- clear-system-jobs)
- #:re-export (clear-environment-mods
- append-environment-mods))
-
-
-(use-modules (srfi srfi-1) ;; For remove.
- (srfi srfi-2)) ;; For and-let*.
-
-
-
-;; The list of all jobs known to the system. Each element of the list is
-;;
-;; (make-job user next-time-function action environment displayable next-time)
-;;
-;; where action must be a procedure, and the environment is an alist of
-;; modifications that need making to the UNIX environment before the action is
-;; run. The next-time element is the only one that is modified during the
-;; running of a cron process (i.e. all the others are set once and for all at
-;; configuration time).
-;;
-;; The reason we maintain two lists is that jobs in /etc/crontab may be placed
-;; in one, and all other jobs go in the other. This makes it possible to remove
-;; all the jobs in the first list in one go, and separately we can remove all
-;; jobs from the second list which belong to a particular user. This behaviour
-;; is required for full vixie compatibility.
-
-(define system-job-list '())
-(define user-job-list '())
-
-(define configuration-source 'user)
-
-(define (use-system-job-list) (set! configuration-source 'system))
-(define (use-user-job-list) (set! configuration-source 'user))
-
-;; A cron job.
-(define-record-type <job>
- (make-job user time-proc action environment displayable next-time)
- job?
- (user job:user) ;object : passwd entry
- (time-proc job:next-time-function) ;proc : with one 'time' parameter
- (action job:action) ;thunk : user's code
- (environment job:environment) ;alist : environment variables
- (displayable job:displayable) ;string : visible in schedule
- (next-time job:next-time ;number : time in UNIX format
- job:next-time-set!))
-
-;; Remove jobs from the user-job-list belonging to this user.
-
-(define (remove-user-jobs user)
- (if (or (string? user)
- (integer? user))
- (set! user (getpw user)))
- (set! user-job-list
- (remove (lambda (job) (eqv? (passwd:uid user)
- (passwd:uid (job:user job))))
- user-job-list)))
-
-
-
-;; Remove all the jobs on the system job list.
-
-(define (clear-system-jobs) (set! system-job-list '()))
-
-
-
-;; Add a new job with the given specifications to the head of the appropriate
-;; jobs list.
-
-(define (add-job time-proc action displayable configuration-time
- configuration-user)
- (let ((entry (make-job configuration-user
- time-proc
- action
- (get-current-environment-mods-copy)
- displayable
- (time-proc configuration-time))))
- (if (eq? configuration-source 'user)
- (set! user-job-list (cons entry user-job-list))
- (set! system-job-list (cons entry system-job-list)))))
-
-
-
-;; Procedure to locate the jobs in the global job-list with the lowest
-;; (soonest) next-times. These are the jobs for which we must schedule the mcron
-;; program (under any personality) to next wake up. The return value is a cons
-;; cell consisting of the next time (maintained in the next-time variable) and a
-;; list of the job entries that are to run at this time (maintained in the
-;; next-jobs-list variable).
-;;
-;; The procedure works by first obtaining the time of the first job on the list,
-;; and setting this job in the next-jobs-list. Then for each other entry on the
-;; job-list, either the job runs earlier than any other that have been scanned,
-;; in which case the next-time and next-jobs-list are re-initialized to
-;; accomodate, or the job runs at the same time as the next job, in which case
-;; the next-jobs-list is simply augmented with the new job, or else the job runs
-;; later than others noted in which case we ignore it for now and continue to
-;; recurse the list.
-
-(define (find-next-jobs)
- (let ((job-list (append system-job-list user-job-list)))
-
- (if (null? job-list)
-
- '(#f . '())
-
- (let ((next-time 2000000000)
- (next-jobs-list '()))
-
- (for-each
- (lambda (job)
- (let ((this-time (job:next-time job)))
- (cond ((< this-time next-time)
- (set! next-time this-time)
- (set! next-jobs-list (list job)))
- ((eqv? this-time next-time)
- (set! next-jobs-list (cons job next-jobs-list))))))
- job-list)
-
- (cons next-time next-jobs-list)))))
-
-
-
-;; Create a string containing a textual list of the next count jobs to run.
-;;
-;; Enter a loop of displaying the next set of jobs to run, artificially
-;; forwarding the time to the next time point (instead of waiting for it to
-;; occur as we would do in a normal run of mcron), and recurse around the loop
-;; count times.
-;;
-;; Note that this has the effect of mutating the job timings. Thus the program
-;; must exit after calling this function; the internal data state will be left
-;; unusable.
-
-(define (get-schedule count)
- (with-output-to-string
- (lambda ()
- (do ((count count (- count 1)))
- ((eqv? count 0))
- (and-let*
- ((next-jobs (find-next-jobs))
- (time (car next-jobs))
- (date-string (strftime "%c %z\n" (localtime time))))
- (for-each (lambda (job)
- (display date-string)
- (display (job:displayable job))
- (newline)(newline)
- (job:next-time-set! job ((job:next-time-function job)
- (job:next-time job))))
- (cdr next-jobs)))))))
-
-
-
-;; For proper housekeeping, it is necessary to keep a record of the number of
-;; child processes we fork off to run the jobs.
-
-(define number-children 0)
-
-
-
-;; For every job on the list, fork a process to run it (noting the fact by
-;; increasing the number-children counter), and in the new process set up the
-;; run-time environment exactly as it should be before running the job proper.
-;;
-;; In the parent, update the job entry by computing the next time the job needs
-;; to run.
-
-(define (run-jobs jobs-list)
- (for-each
- (lambda (job)
- (if (eqv? (primitive-fork) 0)
- (begin
- (setgid (passwd:gid (job:user job)))
- (setuid (passwd:uid (job:user job)))
- (chdir (passwd:dir (job:user job)))
- (modify-environment (job:environment job) (job:user job))
- ((job:action job))
- (primitive-exit 0))
- (begin
- (set! number-children (+ number-children 1))
- (job:next-time-set! job ((job:next-time-function job)
- (current-time))))))
- jobs-list))
-
-
-
-;; Give any zombie children a chance to die, and decrease the number known to
-;; exist.
-
-(define (child-cleanup)
- (do () ((or (<= number-children 0)
- (eqv? (car (waitpid WAIT_ANY WNOHANG)) 0)))
- (set! number-children (- number-children 1))))
-
-
-
-;; Now the main loop. Loop over all job specifications, get a list of the next
-;; ones to run (may be more than one). Set an alarm and go to sleep. When we
-;; wake, run the jobs and reap any children (old jobs) that have
-;; completed. Repeat ad infinitum.
-;;
-;; Note that, if we wake ahead of time, it can only mean that a signal has been
-;; sent by a crontab job to tell us to re-read a crontab file. In this case we
-;; break out of the loop here, and let the main procedure deal with the
-;; situation (it will eventually re-call this function, thus maintaining the
-;; loop).
-
-(define (run-job-loop . fd-list)
-
- (call-with-current-continuation
- (lambda (break)
-
- (let ((fd-list (if (null? fd-list) '() (car fd-list))))
-
- (let loop ()
-
- (let* ((next-jobs (find-next-jobs))
- (next-time (car next-jobs))
- (next-jobs-list (cdr next-jobs))
- (sleep-time (if next-time (- next-time (current-time))
- 2000000000)))
-
- (and (> sleep-time 0)
- (if (not (null?
- (catch 'system-error
- (lambda ()
- (car (select fd-list '() '() sleep-time)))
- (lambda (key . args) ;; Exception add by Sergey
- ;; Poznyakoff.
- (if (member (car (last args))
- (list EINTR EAGAIN))
- (begin
- (child-cleanup) '())
- (apply throw key args))))))
- (break)))
-
- (run-jobs next-jobs-list)
-
- (child-cleanup)
-
- (loop)))))))
diff --git a/src/mcron/vixie-specification.scm b/src/mcron/vixie-specification.scm
index 5cd1528..f055383 100644
--- a/src/mcron/vixie-specification.scm
+++ b/src/mcron/vixie-specification.scm
@@ -30,7 +30,7 @@
read-vixie-file
check-system-crontab)
#:use-module ((mcron config) :select (config-socket-file))
- #:use-module (mcron core)
+ #:use-module (mcron base)
#:use-module (mcron job-specifier)
#:use-module (mcron redirect)
#:use-module (mcron vixie-time))
--
cgit v1.2.3