From 418b81e1af8d18c86693cb43ffe89354af28e3a8 Mon Sep 17 00:00:00 2001 From: Mathieu Lirzin 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 . + + + +(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 + (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 . - - - -(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 - (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