From b3202cecf6a051d726f9af5d080aeb89257b0a98 Mon Sep 17 00:00:00 2001 From: Mathieu Lirzin Date: Fri, 26 Jun 2015 19:30:24 +0200 Subject: build: Add missing 'makefile.am'. * scm/mcron/makefile.am: New file. * .gitignore: Ignore 'mcron' only in the top-level directory. --- scm/mcron/makefile.am | 15 +++++++++++++++ 1 file changed, 15 insertions(+) create mode 100644 scm/mcron/makefile.am (limited to 'scm') diff --git a/scm/mcron/makefile.am b/scm/mcron/makefile.am new file mode 100644 index 0000000..931b03b --- /dev/null +++ b/scm/mcron/makefile.am @@ -0,0 +1,15 @@ +EXTRA_DIST = main.scm mcron-core.scm vixie-specification.scm \ + crontab.scm environment.scm job-specifier.scm redirect.scm \ + vixie-time.scm + +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). + +core.scm : mcron-core.scm + $(CP) mcron-core.scm core.scm + -- cgit v1.2.3 From 607d5e060df87dccf3d8fd478250c3e8832f105b Mon Sep 17 00:00:00 2001 From: Mathieu Lirzin Date: Tue, 21 Jul 2015 00:01:45 +0200 Subject: build: Add package variables. * scm/mcron/config.scm.in (config-package-name) (configure-package-version, configure-package-url): New variables. --- scm/mcron/config.scm.in | 4 ++++ 1 file changed, 4 insertions(+) (limited to 'scm') diff --git a/scm/mcron/config.scm.in b/scm/mcron/config.scm.in index 6a0a85d..db2bc32 100644 --- a/scm/mcron/config.scm.in +++ b/scm/mcron/config.scm.in @@ -1,5 +1,6 @@ ;; -*-scheme-*- +;; Copyright (C) 2015 Mathieu Lirzin ;; Copyright (C) 2003 Dale Mellor ;; ;; This file is part of GNU mcron. @@ -23,8 +24,11 @@ (define-module (mcron config)) (define-public config-debug @CONFIG_DEBUG@) +(define-public config-package-name "@PACKAGE_NAME@") +(define-public config-package-version "@PACKAGE_VERSION@") (define-public config-package-string "@PACKAGE_STRING@") (define-public config-package-bugreport "@PACKAGE_BUGREPORT@") +(define-public config-package-url "@PACKAGE_URL@") (define-public config-sendmail "@SENDMAIL@") (define-public config-spool-dir "@CONFIG_SPOOL_DIR@") -- cgit v1.2.3 From 2dd8fa9d8f4cc23f4a02a41c2b7898e5c8143e54 Mon Sep 17 00:00:00 2001 From: Mathieu Lirzin Date: Tue, 21 Jul 2015 00:53:46 +0200 Subject: main: Add 'show-version' procedure. * scm/mcron/main.scm (show-version): New procedure. --- scm/mcron/main.scm | 35 ++++++++++++++++++----------------- 1 file changed, 18 insertions(+), 17 deletions(-) (limited to 'scm') diff --git a/scm/mcron/main.scm b/scm/mcron/main.scm index 36adef9..db321cf 100644 --- a/scm/mcron/main.scm +++ b/scm/mcron/main.scm @@ -1,3 +1,4 @@ +;; Copyright (C) 2015, 2016 Mathieu Lirzin ;; Copyright (C) 2003, 2012 Dale Mellor ;; ;; This file is part of GNU mcron. @@ -122,25 +123,25 @@ (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 +(define* (show-version #:optional (command command-name)) + "Display version information for COMMAND and quit." + (let* ((name config-package-name) + (short-name (cadr (string-split name #\space))) + (version config-package-version)) + (simple-format #t "~a (~a) ~a\n +Copyright (C) 2015 the ~a authors.\n +License GPLv3+: GNU GPL version 3 or later \n +This is free software: you are free to change and redistribute it.\n +There is NO WARRANTY, to the extent permitted by law.\n" + command name version short-name) + (quit))) + +(when (option-ref options 'version #f) + (show-version)) + +;; If the user asked for the help text 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 " -- cgit v1.2.3 From 8f136b3d67966a1a72cadd74fdad850e24797a4c Mon Sep 17 00:00:00 2001 From: Mathieu Lirzin Date: Tue, 21 Jul 2015 16:23:52 +0200 Subject: main: Add 'show-package-information' procedure. * scm/mcron/main.scm (show-package-information): New procedure. --- scm/mcron/main.scm | 17 ++++++++++++----- 1 file changed, 12 insertions(+), 5 deletions(-) (limited to 'scm') diff --git a/scm/mcron/main.scm b/scm/mcron/main.scm index db321cf..f5e9e3e 100644 --- a/scm/mcron/main.scm +++ b/scm/mcron/main.scm @@ -139,6 +139,15 @@ There is NO WARRANTY, to the extent permitted by law.\n" (when (option-ref options 'version #f) (show-version)) +(define (show-package-information) + "Display where to get help and send bug reports." + (simple-format #t "\nReport bugs to: ~a.\n +~a home page: <~a>\n +General help using GNU software: \n" + config-package-bugreport + config-package-name + config-package-url)) + ;; If the user asked for the help text of this program, give it to him and get ;; out. @@ -181,11 +190,9 @@ reading all the information in the users' crontabs and in /etc/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 -")) + (else "rubbish")))) + (newline) + (show-package-information) (quit))) -- cgit v1.2.3 From cdd26d5b00a7472e7a235b473e5b3eeab5f905b9 Mon Sep 17 00:00:00 2001 From: Mathieu Lirzin Date: Tue, 21 Jul 2015 17:23:32 +0200 Subject: main: Add 'show-help' procedure. * scm/mcron/main.scm (show-help): New procedure. --- scm/mcron/main.scm | 50 ++++++++++++++++++++++---------------------------- 1 file changed, 22 insertions(+), 28 deletions(-) (limited to 'scm') diff --git a/scm/mcron/main.scm b/scm/mcron/main.scm index f5e9e3e..5f48379 100644 --- a/scm/mcron/main.scm +++ b/scm/mcron/main.scm @@ -148,17 +148,13 @@ General help using GNU software: \n" config-package-name config-package-url)) -;; If the user asked for the help text of this program, give it to him and get -;; out. - -(if (option-ref options 'help #f) - (begin - (display (string-append " -Usage: " (car (command-line)) -(case command-type - - ((mcron) -" [OPTIONS] [FILES]\n +(define* (show-help #:optional (command command-name)) + "Display informations of usage for COMMAND and quit." + (simple-format #t "Usage: ~a" command) + (display + (case command-type + ((mcron) + " [OPTIONS] [FILES]\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 @@ -170,9 +166,8 @@ deprecated ~/.cron) with .guile or .vixie extensions.\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 + ((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 @@ -181,21 +176,20 @@ reading all the information in the users' crontabs and in /etc/crontab.\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")))) - (newline) - (show-package-information) - (quit))) - + ((crontab) + " [-u user] file\n + crontab [-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") + (else "\nrubbish"))) + (newline) + (show-package-information) + (quit)) +(when (option-ref options 'help #f) + (show-help)) ;; 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 -- cgit v1.2.3 From f835793336020212b03232486aa5f76b9953a632 Mon Sep 17 00:00:00 2001 From: Mathieu Lirzin Date: Wed, 12 Aug 2015 16:02:58 +0200 Subject: main: Import the modules all together. * scm/mcron/main.scm: Gather module imports. --- scm/mcron/main.scm | 30 +++++++++--------------------- 1 file changed, 9 insertions(+), 21 deletions(-) (limited to 'scm') diff --git a/scm/mcron/main.scm b/scm/mcron/main.scm index 5f48379..ddd7619 100644 --- a/scm/mcron/main.scm +++ b/scm/mcron/main.scm @@ -29,12 +29,16 @@ ;; (l0ad "crontab.scm") (sic) is inlined by the makefile. All other ;; functionality comes through modules in .../share/guile/site/mcron/*.scm. +(use-modules (ice-9 getopt-long) + (ice-9 rdelim) + (ice-9 regex) + (mcron config) + (mcron core) + (mcron job-specifier) + (mcron vixie-specification) + (srfi srfi-2)) - -;; Pull in some constants set by the builder (via autoconf) at configuration -;; time. Turn debugging on if indicated. - -(use-modules (mcron config)) +;; Turn debugging on if indicated. (if config-debug (begin (debug-enable 'debug) (debug-enable 'backtrace))) @@ -44,8 +48,6 @@ ;; 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))))) @@ -93,8 +95,6 @@ ;; 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 @@ -234,16 +234,6 @@ reading all the information in the users' crontabs and in /etc/crontab.\n (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) @@ -349,8 +339,6 @@ reading all the information in the users' crontabs and in /etc/crontab.\n ;; 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 () -- cgit v1.2.3 From 36161428fabfdfa58518739ebcb11416ed920884 Mon Sep 17 00:00:00 2001 From: Mathieu Lirzin Date: Wed, 12 Aug 2015 17:20:51 +0200 Subject: main: Use 'when' and 'unless' special forms. * scm/mcron/main.scm: Use 'when' and 'unless' special forms. --- scm/mcron/main.scm | 117 ++++++++++++++++++++++++++--------------------------- 1 file changed, 57 insertions(+), 60 deletions(-) (limited to 'scm') diff --git a/scm/mcron/main.scm b/scm/mcron/main.scm index ddd7619..39dbe38 100644 --- a/scm/mcron/main.scm +++ b/scm/mcron/main.scm @@ -39,8 +39,9 @@ (srfi srfi-2)) ;; Turn debugging on if indicated. -(if config-debug (begin (debug-enable 'debug) - (debug-enable 'backtrace))) +(when config-debug + (debug-enable 'debug) + (debug-enable 'backtrace)) @@ -62,8 +63,8 @@ (lambda () (for-each display (append (list command-name ": ") rest)) (newline))) - (if (and exit-code (not (eq? exit-code 0))) - (primitive-exit exit-code))) + (when (and exit-code (not (eq? exit-code 0))) + (primitive-exit exit-code))) @@ -215,23 +216,22 @@ reading all the information in the users' crontabs and in /etc/crontab.\n ;; 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))) +(when (eq? command-type 'cron) + (unless (eqv? (getuid) 0) + (mcron-error 16 + "This program must be run by the root user (and should " + "have been installed as such).")) + (when (access? config-pid-file F_OK) + (mcron-error 1 + "A cron daemon is already running.\n" + " (If you are sure this is not true, remove the file\n" + " " + config-pid-file + ".)")) + (unless (option-ref options 'schedule #f) + (with-output-to-file config-pid-file noop)) + (setenv "MAILTO" #f) + (c-set-cron-signals)) ;; Procedure to slurp the standard input into a string. @@ -248,10 +248,9 @@ reading all the information in the users' crontabs and in /etc/crontab.\n ;; 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))) +(when (eq? command-type 'crontab) + (load "crontab.scm") + (quit)) @@ -310,10 +309,10 @@ reading all the information in the users' crontabs and in /etc/crontab.\n (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.")))) + (when (eq? 2 errors) + (mcron-error 13 + "Cannot read files in your ~/.config/cron (or ~/.cron) " + "directory.")))) @@ -377,17 +376,16 @@ reading all the information in the users' crontabs and in /etc/crontab.\n (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 + (unless (option-ref options 'noetc #f) + (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."))))) + (set-configuration-user "root") + (job '(- (next-minute-from (next-minute)) 6) + check-system-crontab + "/etc/crontab update checker.")))) @@ -410,14 +408,13 @@ option.\n") ;; 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)))))) +(when (option-ref options 'daemon (eq? command-type 'cron)) + (unless (eqv? (primitive-fork) 0) + (quit)) + (setsid) + (when (eq? command-type 'cron) + (with-output-to-file config-pid-file + (lambda () (display (getpid)) (newline))))) @@ -428,19 +425,19 @@ option.\n") (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)))) - +(when (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)))) + @@ -489,5 +486,5 @@ option.\n") (catch-mcron-error (while #t (run-job-loop fd-list) - (if (not (null? fd-list)) - (process-update-request)))) + (unless (null? fd-list) + (process-update-request)))) -- cgit v1.2.3 From c8a123839617aae28d87ee02066da73a451ef450 Mon Sep 17 00:00:00 2001 From: Mathieu Lirzin Date: Wed, 12 Aug 2015 18:21:36 +0200 Subject: main: Turn 'command-name' into a thunk. * scm/mcron/main.scm (command-name): Turn into a thunk. All callers changed. --- scm/mcron/main.scm | 39 ++++++++++++++++++--------------------- 1 file changed, 18 insertions(+), 21 deletions(-) (limited to 'scm') diff --git a/scm/mcron/main.scm b/scm/mcron/main.scm index 39dbe38..227bb8f 100644 --- a/scm/mcron/main.scm +++ b/scm/mcron/main.scm @@ -36,23 +36,21 @@ (mcron core) (mcron job-specifier) (mcron vixie-specification) - (srfi srfi-2)) + (srfi srfi-2) + (srfi srfi-26)) ;; Turn debugging on if indicated. (when config-debug (debug-enable 'debug) (debug-enable 'backtrace)) +(define* (command-name #:optional (command (car (command-line)))) + "Extract the actual command name from COMMAND. This returns the last part +of COMMAND without any non-alphabetic characters. For example \"in.cron\" and +\"./mcron\" will return respectively \"cron\" and \"mcron\". - -;; 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. - -(define command-name (match:substring (regexp-exec (make-regexp "[[:alpha:]]*$") - (car (command-line))))) - - +When COMMAND is not specified this uses the first element of (command-line)." + (match:substring (regexp-exec (make-regexp "[[:alpha:]]*$") command))) ;; 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 @@ -61,7 +59,7 @@ (define (mcron-error exit-code . rest) (with-output-to-port (current-error-port) (lambda () - (for-each display (append (list command-name ": ") rest)) + (for-each display (append (list (command-name) ": ") rest)) (newline))) (when (and exit-code (not (eq? exit-code 0))) (primitive-exit exit-code))) @@ -83,14 +81,13 @@ ;; 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.")))) - - +(define command-type + (let* ((command (command-name)) + (command=? (cut string=? command <>))) + (cond ((command=? "mcron") 'mcron) + ((or (command=? "cron") (command=? "crond")) 'cron) + ((command=? "crontab") 'crontab) + (else (mcron-error 12 "The command name is invalid."))))) ;; 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 @@ -124,7 +121,7 @@ (lambda (key func fmt args . rest) (mcron-error 1 (apply format (append (list #f fmt) args)))))) -(define* (show-version #:optional (command command-name)) +(define* (show-version #:optional (command (command-name))) "Display version information for COMMAND and quit." (let* ((name config-package-name) (short-name (cadr (string-split name #\space))) @@ -149,7 +146,7 @@ General help using GNU software: \n" config-package-name config-package-url)) -(define* (show-help #:optional (command command-name)) +(define* (show-help #:optional (command (command-name))) "Display informations of usage for COMMAND and quit." (simple-format #t "Usage: ~a" command) (display -- cgit v1.2.3 From 2947d841016cc225f9ca92f8d126a2fd3deaaa3e Mon Sep 17 00:00:00 2001 From: Mathieu Lirzin Date: Sat, 15 Aug 2015 00:05:22 +0200 Subject: main: Make 'catch-mcron-error' macro hygienic. * scm/mcron/main.scm (catch-mcron-error): Use 'define-syntax-rule' instead of 'defmacro'. --- scm/mcron/main.scm | 20 +++++++------------- 1 file changed, 7 insertions(+), 13 deletions(-) (limited to 'scm') diff --git a/scm/mcron/main.scm b/scm/mcron/main.scm index 227bb8f..99531a8 100644 --- a/scm/mcron/main.scm +++ b/scm/mcron/main.scm @@ -64,19 +64,13 @@ When COMMAND is not specified this uses the first element of (command-line)." (when (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)))) - - +(define-syntax-rule (catch-mcron-error exp ...) + "Evaluate EXP .... if an 'mcron-error exception occurs, print its diagnostics +and exit with its error code." + (catch 'mcron-error + (lambda () exp ...) + (lambda (key exit-code . msg) + (apply mcron-error exit-code msg)))) ;; 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. -- cgit v1.2.3 From 5e8f47fe440699ba236d8f592ddd213b75cf10e7 Mon Sep 17 00:00:00 2001 From: Mathieu Lirzin Date: Sat, 15 Aug 2015 02:32:59 +0200 Subject: main: Add docstrings. * scm/mcron/main.scm (delete-run-file, mcron-error) (process-files-in-system-directory, process-files-in-user-directory) (process-update-request, process-user-file, regular-file?) (stdin->string, valid-user): Turn comments into docstrings. (command-type, options): Move comments inside the definitions. --- scm/mcron/main.scm | 93 +++++++++++++++++++----------------------------------- 1 file changed, 32 insertions(+), 61 deletions(-) (limited to 'scm') diff --git a/scm/mcron/main.scm b/scm/mcron/main.scm index 99531a8..944ea3e 100644 --- a/scm/mcron/main.scm +++ b/scm/mcron/main.scm @@ -52,11 +52,10 @@ of COMMAND without any non-alphabetic characters. For example \"in.cron\" and When COMMAND is not specified this uses the first element of (command-line)." (match:substring (regexp-exec (make-regexp "[[:alpha:]]*$") command))) -;; 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) + "Print an error message (made up from the parts of REST), and if the +EXIT-CODE error is fatal (present and non-zero) then exit to the system with +EXIT-CODE." (with-output-to-port (current-error-port) (lambda () (for-each display (append (list (command-name) ": ") rest)) @@ -72,10 +71,9 @@ and exit with its error code." (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 + ;; We will be doing a lot of testing of the command name, so it makes sense + ;; to perform the string comparisons once and for all here. (let* ((command (command-name)) (command=? (cut string=? command <>))) (cond ((command=? "mcron") 'mcron) @@ -83,11 +81,10 @@ and exit with its error code." ((command=? "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. - (define options + ;; There are a different set of options for the crontab personality compared + ;; to all the others, with the --help and --version options common to all + ;; the personalities. (catch 'misc-error (lambda () @@ -183,12 +180,11 @@ reading all the information in the users' crontabs and in /etc/crontab.\n (when (option-ref options 'help #f) (show-help)) -;; 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) + "Remove the /var/run/cron.pid file so that crontab and other invocations of +cron don't get the wrong idea that a daemon is currently running. This +procedure is called from the C front-end whenever a terminal signal is +received." (catch #t (lambda () (delete-file config-pid-file) (delete-file config-socket-file)) noop) @@ -224,10 +220,8 @@ reading all the information in the users' crontabs and in /etc/crontab.\n (setenv "MAILTO" #f) (c-set-cron-signals)) - -;; Procedure to slurp the standard input into a string. - (define (stdin->string) + "Return standard input as a string." (with-output-to-string (lambda () (do ((in (read-char) (read-char))) ((eof-object? in)) (display in))))) @@ -243,12 +237,8 @@ reading all the information in the users' crontabs and in /etc/crontab.\n (load "crontab.scm") (quit)) - - -;; Code contributed by Sergey Poznyakoff. Determine if the given file is a -;; regular file or not. - (define (regular-file? file) + "Return true if FILE is a regular file." (catch 'system-error (lambda () (eq? (stat:type (stat file)) 'regular)) @@ -256,16 +246,14 @@ reading all the information in the users' crontabs and in /etc/crontab.\n (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) + "Process FILE-PATH according its extension. When ASSUME-GUILE is non nil, +usage of guile syntax is forced for FILE-PATH. If a file is not recognized, +it is silently ignored (this deals properly with most editors' backup files, +for instance)." (cond ((string=? file-path "-") (if (string=? (option-ref options 'stdin "guile") "vixie") (read-vixie-port (current-input-port)) @@ -276,13 +264,9 @@ reading all the information in the users' crontabs and in /etc/crontab.\n ((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) + "Process files in $XDG_CONFIG_HOME/cron and/or ~/.cron directories (if +$XDG_CONFIG_HOME is not defined uses ~/.config/cron instead)." (let ((errors 0) (home-directory (passwd:dir (getpw (getuid))))) (map (lambda (config-directory) @@ -305,13 +289,10 @@ reading all the information in the users' crontabs and in /etc/crontab.\n "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) + "Check that 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, Return the +full passwd entry for that user." (setpwent) (do ((entry (getpw) (getpw))) ((or (not entry) @@ -319,17 +300,11 @@ reading all the information in the users' crontabs and in /etc/crontab.\n (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. - (define (process-files-in-system-directory) + "Process all the files in the crontab directory. When the job procedure is +run on behalf of the configuration files, the jobs are registered on the +system with the appropriate user. Only root should be able to perform this +operation. The permissions on the /var/cron/tabs directory enforce this." (catch #t (lambda () (let ((directory (opendir config-spool-dir))) @@ -429,16 +404,12 @@ option.\n") "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) + "Read a user name from the socket, dealing with the /etc/crontab special +case, remove all the user's jobs from the job list, and then re-read the +user's updated file. In the special case drop all the system jobs and re-read +the /etc/crontab file. This function should be called whenever a message +comes in on the above socket." (let* ((socket (car (accept (car fd-list)))) (user-name (read-line socket))) (close socket) -- cgit v1.2.3 From 98d68831ba742e8b8769de3bddf7a695a09ecbbf Mon Sep 17 00:00:00 2001 From: Mathieu Lirzin Date: Sat, 15 Aug 2015 12:55:47 +0200 Subject: main: Add 'cron-file-descriptors' procedure. * scm/mcron/main.scm (fd-list): Delete variable. (cron-file-descriptors): New procedure. Return a list instead of mutating 'fd-list'. (process-update-request): Add 'fdes-list' parameter. Adapt caller by using 'cron-file-descriptors' as an effective parameter. --- scm/mcron/main.scm | 59 ++++++++++++++++++++++++++---------------------------- 1 file changed, 28 insertions(+), 31 deletions(-) (limited to 'scm') diff --git a/scm/mcron/main.scm b/scm/mcron/main.scm index 944ea3e..946ab7c 100644 --- a/scm/mcron/main.scm +++ b/scm/mcron/main.scm @@ -382,37 +382,33 @@ option.\n") (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 '()) - -(when (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)))) - -(define (process-update-request) +(define (cron-file-descriptors) + "Establish a socket to listen for updates from a crontab program, and return +a list containing the file descriptors correponding to the files read by +crontab. This requires that command-type is 'cron." + (if (eq? command-type 'cron) + (catch #t + (lambda () + (let ((sock (socket AF_UNIX SOCK_STREAM 0))) + (bind sock AF_UNIX config-socket-file) + (listen sock 5) + (list sock))) + (lambda (key . args) + (delete-file config-pid-file) + (mcron-error 1 + "Cannot bind to UNIX socket " + config-socket-file))) + '())) + +(define (process-update-request fdes-list) "Read a user name from the socket, dealing with the /etc/crontab special case, remove all the user's jobs from the job list, and then re-read the user's updated file. In the special case drop all the system jobs and re-read the /etc/crontab file. This function should be called whenever a message comes in on the above socket." - (let* ((socket (car (accept (car fd-list)))) - (user-name (read-line socket))) - (close socket) + (let* ((sock (car (accept (car fdes-list)))) + (user-name (read-line sock))) + (close sock) (set-configuration-time (current-time)) (catch-mcron-error (if (string=? user-name "/etc/crontab") @@ -443,10 +439,11 @@ comes in on the above socket." ;; 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. +;; so must test FDES-LIST. (catch-mcron-error - (while #t - (run-job-loop fd-list) - (unless (null? fd-list) - (process-update-request)))) + (let ((fdes-list (cron-file-descriptors))) + (while #t + (run-job-loop fdes-list) + (unless (null? fdes-list) + (process-update-request fdes-list))))) -- cgit v1.2.3 From 237c234f39e59966cacdab4413cc3e200ac2f491 Mon Sep 17 00:00:00 2001 From: Mathieu Lirzin Date: Sat, 15 Aug 2015 23:50:44 +0200 Subject: main: Add 'main' procedure. * scm/mcron/main.scm (main): New Thunk. Move remaining top-level code to it. --- scm/mcron/main.scm | 252 ++++++++++++++++++++++++----------------------------- 1 file changed, 115 insertions(+), 137 deletions(-) (limited to 'scm') diff --git a/scm/mcron/main.scm b/scm/mcron/main.scm index 946ab7c..a964795 100644 --- a/scm/mcron/main.scm +++ b/scm/mcron/main.scm @@ -39,11 +39,6 @@ (srfi srfi-2) (srfi srfi-26)) -;; Turn debugging on if indicated. -(when config-debug - (debug-enable 'debug) - (debug-enable 'backtrace)) - (define* (command-name #:optional (command (car (command-line)))) "Extract the actual command name from COMMAND. This returns the last part of COMMAND without any non-alphabetic characters. For example \"in.cron\" and @@ -125,9 +120,6 @@ There is NO WARRANTY, to the extent permitted by law.\n" command name version short-name) (quit))) -(when (option-ref options 'version #f) - (show-version)) - (define (show-package-information) "Display where to get help and send bug reports." (simple-format #t "\nReport bugs to: ~a.\n @@ -177,9 +169,6 @@ reading all the information in the users' crontabs and in /etc/crontab.\n (show-package-information) (quit)) -(when (option-ref options 'help #f) - (show-help)) - (define (delete-run-file) "Remove the /var/run/cron.pid file so that crontab and other invocations of cron don't get the wrong idea that a daemon is currently running. This @@ -190,53 +179,12 @@ received." 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). - -(when (eq? command-type 'cron) - (unless (eqv? (getuid) 0) - (mcron-error 16 - "This program must be run by the root user (and should " - "have been installed as such).")) - (when (access? config-pid-file F_OK) - (mcron-error 1 - "A cron daemon is already running.\n" - " (If you are sure this is not true, remove the file\n" - " " - config-pid-file - ".)")) - (unless (option-ref options 'schedule #f) - (with-output-to-file config-pid-file noop)) - (setenv "MAILTO" #f) - (c-set-cron-signals)) - (define (stdin->string) "Return standard input as a string." (with-output-to-string (lambda () (do ((in (read-char) (read-char))) ((eof-object? in)) (display in))))) - - -;; Now we have the procedures in place for dealing with the contents of -;; configuration files, the crontab personality is able to validate such -;; files. If the user requested the crontab personality, we load and run the -;; code here and then get out. - -(when (eq? command-type 'crontab) - (load "crontab.scm") - (quit)) - (define (regular-file? file) "Return true if FILE is a regular file." (catch 'system-error @@ -321,67 +269,6 @@ operation. The permissions on the /var/cron/tabs directory enforce this." 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) - (unless (option-ref options 'noetc #f) - (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. - -(when (option-ref options 'daemon (eq? command-type 'cron)) - (unless (eqv? (primitive-fork) 0) - (quit)) - (setsid) - (when (eq? command-type 'cron) - (with-output-to-file config-pid-file - (lambda () (display (getpid)) (newline))))) - (define (cron-file-descriptors) "Establish a socket to listen for updates from a crontab program, and return a list containing the file descriptors correponding to the files read by @@ -422,28 +309,119 @@ comes in on the above socket." (set-configuration-user user) (read-vixie-file (string-append config-spool-dir "/" user-name))))))) + +;;; +;;; Entry point. +;;; + +(define (main . args) + ;; Turn debugging on if indicated. + (when config-debug + (debug-enable 'debug) + (debug-enable 'backtrace)) + (when (option-ref options 'version #f) + (show-version)) + (when (option-ref options 'help #f) + (show-help)) + + ;; Setup the cron process, if appropriate. If there is already a + ;; /var/run/cron.pid file, then we must assume a cron daemon is already + ;; running and refuse to start another one. + ;; + ;; Otherwise, clear the MAILTO environment variable so that output from cron + ;; jobs is sent to the various users (this may still be overridden in the + ;; configuration files), and call the function in the C wrapper to set up + ;; terminal signal responses to vector to the procedure above. The PID file + ;; will be filled in properly later when we have forked our daemon process + ;; (but not done if we are only viewing the schedules). + (when (eq? command-type 'cron) + (unless (eqv? (getuid) 0) + (mcron-error 16 + "This program must be run by the root user (and should " + "have been installed as such).")) + (when (access? config-pid-file F_OK) + (mcron-error 1 + "A cron daemon is already running.\n" + " (If you are sure this is not true, remove the file\n" + " " + config-pid-file + ".)")) + (unless (option-ref options 'schedule #f) + (with-output-to-file config-pid-file noop)) + (setenv "MAILTO" #f) + (c-set-cron-signals)) + + ;; Now we have the procedures in place for dealing with the contents of + ;; configuration files, the crontab personality is able to validate such + ;; files. If the user requested the crontab personality, we load and run the + ;; code here and then get out. + (when (eq? command-type 'crontab) + (load "crontab.scm") + (quit)) - -;; 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 FDES-LIST. - -(catch-mcron-error - (let ((fdes-list (cron-file-descriptors))) - (while #t - (run-job-loop fdes-list) - (unless (null? fdes-list) - (process-update-request fdes-list))))) + ;; Having defined all the necessary procedures for scanning various sets of + ;; files, we perform the actual configuration of the program depending on + ;; the personality we are running as. If it is mcron, we either scan the + ;; files passed on the command line, or else all the ones in the user's + ;; .config/cron (or .cron) directory. If we are running under the cron + ;; personality, we read the /var/cron/tabs directory and also the + ;; /etc/crontab file. + (case command-type + ((mcron) + (if (null? (option-ref options '() '())) + (process-files-in-user-directory) + (for-each (lambda (file-path) (process-user-file file-path #t)) + (option-ref options '() '())))) + ((cron) + (process-files-in-system-directory) + (use-system-job-list) + (catch-mcron-error (read-vixie-file "/etc/crontab" + parse-system-vixie-line)) + (use-user-job-list) + (unless (option-ref options 'noetc #f) + (display "WARNING: +cron will check for updates to /etc/crontab EVERY MINUTE. If you do\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. + (when (option-ref options 'daemon (eq? command-type 'cron)) + (unless (eqv? (primitive-fork) 0) + (quit)) + (setsid) + (when (eq? command-type 'cron) + (with-output-to-file config-pid-file + (lambda () (display (getpid)) (newline))))) + + ;; Now the main loop. Forever execute the run-job-loop procedure in the + ;; mcron core, and when it drops out (can only be because a message has come + ;; in on the socket) we process the socket request before restarting the + ;; loop again. Sergey Poznyakoff: we can also drop out of run-job-loop + ;; because of a SIGCHLD, so must test FDES-LIST. + (catch-mcron-error + (let ((fdes-list (cron-file-descriptors))) + (while #t + (run-job-loop fdes-list) + (unless (null? fdes-list) + (process-update-request fdes-list)))))) + +(main) -- cgit v1.2.3 From 3c903bfc808b6fed0c3fff6e78689cfe280d25b3 Mon Sep 17 00:00:00 2001 From: Mathieu Lirzin Date: Sun, 16 Aug 2015 10:33:37 +0200 Subject: main: Add (mcron main) module. Remove 'ed' hack to eval content of scm/mcron/main.scm in the C wrapper. Use proper libguile functions instead. * scm/mcron/main.scm (mcron main): New module. (show-version, show-package-information, show-help, main): Remove extra newline characters in strings. * mcron.c.template: Rename to ... * mcron.c: ... this. (inner_main): Set current module to (mcron main). * makefile.ed: Delete file. * configure.ac: Remove check for 'ed'. * makefile.am: Adjust accordingly. * .gitignore: Likewise. --- .gitignore | 1 - configure.ac | 4 -- makefile.am | 11 +---- makefile.ed | 34 --------------- mcron.c | 102 +++++++++++++++++++++++++++++++++++++++++++++ mcron.c.template | 120 ----------------------------------------------------- scm/mcron/main.scm | 108 ++++++++++++++++++++++------------------------- 7 files changed, 153 insertions(+), 227 deletions(-) delete mode 100644 makefile.ed create mode 100644 mcron.c delete mode 100644 mcron.c.template (limited to 'scm') diff --git a/.gitignore b/.gitignore index 6aaa315..4505cc5 100644 --- a/.gitignore +++ b/.gitignore @@ -27,7 +27,6 @@ install-sh makefile makefile.in /mcron -mcron.c /mdate-sh *.o missing diff --git a/configure.ac b/configure.ac index 3826bad..ed6971f 100644 --- a/configure.ac +++ b/configure.ac @@ -64,10 +64,6 @@ AC_CHECK_PROGS(HEAD, head) if test "x$ac_cv_prog_HEAD" = "x"; then AC_MSG_ERROR(head not found) fi -AC_CHECK_PROGS(ED, ed) -if test "x$ac_cv_prog_ED" = "x"; then - AC_MSG_ERROR(ed not found) -fi AC_CHECK_PROGS(WHICH, which) if test "x$ac_cv_prog_WHICH" = "x"; then AC_MSG_ERROR(which not found) diff --git a/makefile.am b/makefile.am index 61fbe56..aa0b24b 100644 --- a/makefile.am +++ b/makefile.am @@ -21,12 +21,9 @@ SUBDIRS = scm/mcron . -ED = @ED@ # !!!! Are these needed? CP = @CP@ -CLEANFILES = mcron.c - -EXTRA_DIST = makefile.ed mcron.c.template BUGS ChangeLog.old +EXTRA_DIST = BUGS ChangeLog.old info_TEXINFOS = doc/mcron.texi doc_mcron_TEXINFOS = doc/fdl.texi @@ -40,12 +37,6 @@ mcron_LDADD = @GUILE_LIBS@ # in turn so that we can do mcron --help during the build process. mcron_CFLAGS = @GUILE_CFLAGS@ -DGUILE_LOAD_PATH=\"$(datadir):./scm:...\" - -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 - dist-hook: gen-ChangeLog gen_start_date = 2015-06-26 diff --git a/makefile.ed b/makefile.ed deleted file mode 100644 index 7047ec7..0000000 --- a/makefile.ed +++ /dev/null @@ -1,34 +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 . -# -# -# -e scm/mcron/main.scm -/\(load "crontab.scm"\)/d --1r scm/mcron/crontab.scm -%s/\\/\\\\/g -%s/"/\\"/g -%s/ *;;.*$/ /g -g/^ *$/d -%s/^/\"/ -%s/$/\"/ -w mcron.escaped.scm -e mcron.c.template -/GUILE_PROGRAM_GOES_HERE/d --1r mcron.escaped.scm -w mcron.c -q diff --git a/mcron.c b/mcron.c new file mode 100644 index 0000000..6c9efa4 --- /dev/null +++ b/mcron.c @@ -0,0 +1,102 @@ +/* mcron - run jobs at scheduled times + + Copyright (C) 2015, 2016 Mathieu Lirzin + 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 . */ + +/* This C code represents the thinnest possible wrapper around the Guile code + which constitutes all the functionality of the mcron program. There are + two plus one reasons why we need to do this, and one very unfortunate + consequence. + + * Firstly, SUID does not work on an executable script. In the end, it is + the execution of the translator, in our case guile, which determines the + effective user, and it is not wise to make the system guile installation + SUID root! + + * Secondly, executable scripts show up in ugly ways in listings of the + system process table. Guile in particular, with its multi-line + #! ...\ \n -s ...!# + idiosyncracies shows up in process listings in a way that is difficult + to determine what program is actually running. + + * A third reason for the C wrapper which might be mentioned is that a + security-conscious system administrator can choose to only install a + binary, thus removing the possibility of a user studying a guile script + and working out ways of hacking it to his own ends, or worse still + finding a way to modify it to his own ends. + + * Unfortunately, running the guile script from inside a C program means + that the sigaction function does not work. Instead, it is necessary to + perform the signal processing in C. */ + +#include +#include +#include + +/* This is a function designed to be installed as a signal handler, for + signals which are supposed to initiate shutdown of this program. It calls + the scheme procedure (see mcron.scm for details) to do all the work, and + then exits. */ + +void +react_to_terminal_signal (int sig) +{ + scm_c_eval_string ("(delete-run-file)"); + exit (1); +} + +/* This is a function designed to be callable from scheme, and sets up all the + signal handlers required by the cron personality. */ + +SCM +set_cron_signals () +{ + static struct sigaction sa; + + memset (&sa, 0, sizeof (sa)); + sa.sa_handler = react_to_terminal_signal; + sigaction (SIGTERM, &sa, 0); + sigaction (SIGINT, &sa, 0); + sigaction (SIGQUIT, &sa, 0); + sigaction (SIGHUP, &sa, 0); + + return SCM_BOOL_T; +} + +/* The effective main function (i.e. the one that actually does some work). + We register the function above with the guile system, and then execute the + mcron guile program. */ + +void +inner_main (void *closure, int argc, char **argv) +{ + scm_set_current_module (scm_c_resolve_module ("mcron main")); + scm_c_define_gsubr ("c-set-cron-signals", 0, 0, 0, set_cron_signals); + scm_c_eval_string ("(main)"); +} + +/* The real main function. Does nothing but start up the guile subsystem. */ + +int +main (int argc, char **argv) +{ + setenv ("GUILE_LOAD_PATH", GUILE_LOAD_PATH, 1); + scm_boot_guile (argc, argv, inner_main, 0); + + return 0; +} diff --git a/mcron.c.template b/mcron.c.template deleted file mode 100644 index e9a755d..0000000 --- a/mcron.c.template +++ /dev/null @@ -1,120 +0,0 @@ -/* -*-c-*- */ -/* - * 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 . - */ - - -/* - This C code represents the thinnest possible wrapper around the Guile code - which constitutes all the functionality of the mcron program. There are two - plus one reasons why we need to do this, and one very unfortunate - consequence. - - Firstly, SUID does not work on an executable script. In the end, it is - the execution of the translator, in our case guile, which determines the - effective user, and it is not wise to make the system guile installation - SUID root! - - Secondly, executable scripts show up in ugly ways in listings of the - system process table. Guile in particular, with its multi-line - #! ...\ \n -s ...!# - idiosyncracies shows up in process listings in a way that is difficult - to determine what program is actually running. - - A third reason for the C wrapper which might be mentioned is that a - security-conscious system administrator can choose to only install a - binary, thus removing the possibility of a user studying a guile script - and working out ways of hacking it to his own ends, or worse still - finding a way to modify it to his own ends. - - Unfortunately, running the guile script from inside a C program means - that the sigaction function does not work. Instead, it is necessary to - perform the signal processing in C. - - The guile code itself is substituted for the GU1LE_PROGRAM_GOES_HERE (sic) - token by the makefile, which processes the scheme to make it look like one - big string. -*/ - - - -#include -#include -#include - - - -/* This is a function designed to be installed as a signal handler, for signals - which are supposed to initiate shutdown of this program. It calls the scheme - procedure (see mcron.scm for details) to do all the work, and then exits. */ - -void -react_to_terminal_signal (int sig) -{ - scm_c_eval_string ("(delete-run-file)"); - exit (1); -} - - - -/* This is a function designed to be callable from scheme, and sets up all the - signal handlers required by the cron personality. */ - -SCM -set_cron_signals () -{ - static struct sigaction sa; - memset (&sa, 0, sizeof (sa)); - sa.sa_handler = react_to_terminal_signal; - sigaction (SIGTERM, &sa, 0); - sigaction (SIGINT, &sa, 0); - sigaction (SIGQUIT, &sa, 0); - sigaction (SIGHUP, &sa, 0); - - return SCM_BOOL_T; -} - - - -/* The effective main function (i.e. the one that actually does some work). We - register the function above with the guile system, and then execute the mcron - guile program. */ - -void -inner_main () -{ - scm_c_define_gsubr ("c-set-cron-signals", 0, 0, 0, set_cron_signals); - - scm_c_eval_string ( - GUILE_PROGRAM_GOES_HERE - ); -} - - - -/* The real main function. Does nothing but start up the guile subsystem. */ - -int -main (int argc, char **argv) -{ - setenv ("GUILE_LOAD_PATH", GUILE_LOAD_PATH, 1); - - scm_boot_guile (argc, argv, inner_main, 0); - - return 0; -} diff --git a/scm/mcron/main.scm b/scm/mcron/main.scm index a964795..1d8c87b 100644 --- a/scm/mcron/main.scm +++ b/scm/mcron/main.scm @@ -16,28 +16,22 @@ ;; 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. - -(use-modules (ice-9 getopt-long) - (ice-9 rdelim) - (ice-9 regex) - (mcron config) - (mcron core) - (mcron job-specifier) - (mcron vixie-specification) - (srfi srfi-2) - (srfi srfi-26)) +;;; This is the 'main' routine for the whole system; this module is the global +;;; entry point (after the minimal C wrapper); to all intents and purposes the +;;; program is pure Guile and starts here. + +(define-module (mcron main) + #:use-module (ice-9 getopt-long) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 regex) + #:use-module (mcron config) + #:use-module (mcron core) + #:use-module (mcron job-specifier) + #:use-module (mcron vixie-specification) + #:use-module (srfi srfi-2) + #:use-module (srfi srfi-26) + #:export (delete-run-file + main)) (define* (command-name #:optional (command (car (command-line)))) "Extract the actual command name from COMMAND. This returns the last part @@ -112,18 +106,18 @@ and exit with its error code." (let* ((name config-package-name) (short-name (cadr (string-split name #\space))) (version config-package-version)) - (simple-format #t "~a (~a) ~a\n -Copyright (C) 2015 the ~a authors.\n -License GPLv3+: GNU GPL version 3 or later \n -This is free software: you are free to change and redistribute it.\n + (simple-format #t "~a (~a) ~a +Copyright (C) 2015 the ~a authors. +License GPLv3+: GNU GPL version 3 or later +This is free software: you are free to change and redistribute it. There is NO WARRANTY, to the extent permitted by law.\n" command name version short-name) (quit))) (define (show-package-information) "Display where to get help and send bug reports." - (simple-format #t "\nReport bugs to: ~a.\n -~a home page: <~a>\n + (simple-format #t "\nReport bugs to: ~a. +~a home page: <~a> General help using GNU software: \n" config-package-bugreport config-package-name @@ -135,34 +129,34 @@ General help using GNU software: \n" (display (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 + " [OPTIONS] [FILES] +Run an mcron process according to the specifications in the FILES (`-' for +standard input), or use all the files in ~/.config/cron (or the +deprecated ~/.cron) with .guile or .vixie extensions. + + -v, --version Display version + -h, --help Display this help message + -sN, --schedule[=]N Display the next N jobs that will be run by mcron + -d, --daemon Immediately detach the program from the terminal + and run as a daemon process + -i, --stdin=(guile|vixie) Format of data passed as standard input or file arguments (default guile)") ((cron) - " [OPTIONS]\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 + " [OPTIONS] +Unless an option is specified, run a cron daemon as a detached process, +reading all the information in the users' crontabs and in /etc/crontab. + + -v, --version Display version + -h, --help Display this help message + -sN, --schedule[=]N Display the next N jobs that will be run by cron + -n, --noetc Do not check /etc/crontab for updates (HIGHLY RECOMMENDED).") ((crontab) - " [-u user] file\n - crontab [-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 + " [-u user] file + crontab [-u user] { -e | -l | -r } + (default operation is replace, per 1003.2) + -e (edit user's crontab) + -l (list user's crontab) -r (delete user's crontab") (else "\nrubbish"))) (newline) @@ -379,10 +373,10 @@ comes in on the above socket." parse-system-vixie-line)) (use-user-job-list) (unless (option-ref options 'noetc #f) - (display "WARNING: -cron will check for updates to /etc/crontab EVERY MINUTE. If you do\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 + (display "\ +WARNING: cron will check for updates to /etc/crontab EVERY MINUTE. If you do +not use this file, or you are prepared to manually restart cron whenever you +make a change, then it is HIGHLY RECOMMENDED that you use the --noetc option.\n") (set-configuration-user "root") (job '(- (next-minute-from (next-minute)) 6) @@ -423,5 +417,3 @@ option.\n") (run-job-loop fdes-list) (unless (null? fdes-list) (process-update-request fdes-list)))))) - -(main) -- cgit v1.2.3 From 3221c057206ca22c2da599c8c76bbcbb0f36e794 Mon Sep 17 00:00:00 2001 From: Mathieu Lirzin Date: Sun, 16 Aug 2015 15:55:35 +0200 Subject: build: Compile and install '.go' files. * configure.ac: Set and substitute 'mcronmoduledir'. Check for 'guild' which requires Guile >= 2.0.7. Use 'AC_CANONICAL_HOST'. * scm/mcron/makefile.am (.scm.go): New target. (MODULES, GEN_MODULES, GOBJECTS, CLEANFILES, SUFFIXES) (dist_mcronmodule_DATA, mcronmodule_DATA): New variables. (pkgdata_DATA, EXTRA_DIST): Remove variables. * .gitignore: Adjust accordingly. --- .gitignore | 3 +++ configure.ac | 12 ++++++++++-- scm/mcron/main.scm | 2 ++ scm/mcron/makefile.am | 48 +++++++++++++++++++++++++++++++++++++++++++----- 4 files changed, 58 insertions(+), 7 deletions(-) (limited to 'scm') diff --git a/.gitignore b/.gitignore index 4505cc5..9748b8a 100644 --- a/.gitignore +++ b/.gitignore @@ -1,9 +1,12 @@ *~ +*.go .deps INSTALL aclocal.m4 autom4te.cache /build-aux/compile +/build-aux/config.guess +/build-aux/config.sub /build-aux/depcomp /build-aux/install-sh /build-aux/mdate-sh diff --git a/configure.ac b/configure.ac index ed6971f..42dfa6e 100644 --- a/configure.ac +++ b/configure.ac @@ -26,6 +26,8 @@ AC_INIT([GNU Mcron], [1.0.8], [bug-mcron@gnu.org]) AC_CONFIG_AUX_DIR([build-aux]) AM_INIT_AUTOMAKE +mcronmoduledir="${datarootdir}/guile/site/2.0/mcron" +AC_SUBST([mcronmoduledir]) AC_MSG_CHECKING([whether debugging is requested]) AC_ARG_ENABLE(debug, @@ -45,12 +47,18 @@ AC_SUBST(CONFIG_DEBUG) # We have no interest (hence a no-op), but Debian wants this. AC_ARG_ENABLE(maintainer-mode) - +AC_CANONICAL_HOST AC_PROG_AWK AC_PROG_EGREP AM_PROG_CC_C_O -PKG_CHECK_MODULES(GUILE, guile-2.0) +PKG_CHECK_MODULES([GUILE], [guile-2.0 >= 2.0.7]) +AC_PATH_PROG([GUILE], [guile]) + +# search guild +AC_PATH_PROG([GUILD], [guild]) +AS_IF([test -z "$ac_cv_path_GUILD"], + [AC_MSG_ERROR(['guild' program cannot be found.])]) # Checks for programs. diff --git a/scm/mcron/main.scm b/scm/mcron/main.scm index 1d8c87b..6ac2116 100644 --- a/scm/mcron/main.scm +++ b/scm/mcron/main.scm @@ -343,6 +343,8 @@ comes in on the above socket." (unless (option-ref options 'schedule #f) (with-output-to-file config-pid-file noop)) (setenv "MAILTO" #f) + ;; XXX: At compile time, this yields a "possibly unbound variable" + ;; warning, but this is OK since it is bound in the C wrapper. (c-set-cron-signals)) ;; Now we have the procedures in place for dealing with the contents of diff --git a/scm/mcron/makefile.am b/scm/mcron/makefile.am index 931b03b..ab6cae2 100644 --- a/scm/mcron/makefile.am +++ b/scm/mcron/makefile.am @@ -1,10 +1,48 @@ -EXTRA_DIST = main.scm mcron-core.scm vixie-specification.scm \ - crontab.scm environment.scm job-specifier.scm redirect.scm \ - vixie-time.scm +MODULES = \ + environment.scm \ + job-specifier.scm \ + main.scm \ + redirect.scm \ + vixie-specification.scm \ + vixie-time.scm -pkgdata_DATA = core.scm environment.scm job-specifier.scm redirect.scm \ - vixie-time.scm vixie-specification.scm config.scm +GEN_MODULES = \ + config.scm \ + core.scm +GOBJECTS = \ + $(GEN_MODULES:%.scm=%.go) \ + $(MODULES:%.scm=%.go) + +mcronmodule_DATA = \ + $(GOBJECTS) \ + $(GEN_MODULES) + +dist_mcronmodule_DATA = \ + $(MODULES) \ + crontab.scm \ + mcron-core.scm + +# Unset 'GUILE_LOAD_COMPILED_PATH' altogether while compiling. Otherwise, if +# $GUILE_LOAD_COMPILED_PATH contains $(mcronmoduledir), we may find .go files +# in there that are newer than the local .scm files (for instance because the +# user ran 'make install' recently). When that happens, we end up loading +# those previously-installed .go files, which may be stale, thereby breaking +# the whole thing. +# +# XXX: Use the C locale for when Guile lacks +# . +.scm.go: + unset GUILE_LOAD_COMPILED_PATH ; \ + LC_ALL=C \ + $(GUILD) compile \ + --load-path="$(top_builddir)/scm" \ + --load-path="$(top_srcdir)/scm" \ + --warn=format --warn=unbound-variable --warn=arity-mismatch \ + --target="$(host)" --output="$@" "$<" + +SUFFIXES = .go +CLEANFILES = $(GOBJECTS) # 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 -- cgit v1.2.3 From 1712722a7b50e2f449ee94fb5d039757f2426f36 Mon Sep 17 00:00:00 2001 From: Mathieu Lirzin Date: Tue, 18 Aug 2015 17:25:21 +0200 Subject: build: Enable silent rules by default. * configure.ac (AM_SILENT_RULES): Use macro. * makefile.am (doc/mcron.1): Use $(AM_V_HELP2MAN). (AM_V_HELP2MAN, AM_V_HELP2MAN_, AM_V_HELP2MAN_): New variables. * scm/mcron/makefile.am (.scm.go): Use $(AM_V_GUILEC). (AM_V_GUILEC, AM_V_GUILEC_, AM_V_GUILEC_): New variables. --- configure.ac | 1 + makefile.am | 10 ++++++++-- scm/mcron/makefile.am | 6 ++++++ 3 files changed, 15 insertions(+), 2 deletions(-) (limited to 'scm') diff --git a/configure.ac b/configure.ac index 42dfa6e..54481dd 100644 --- a/configure.ac +++ b/configure.ac @@ -25,6 +25,7 @@ AC_PREREQ(2.61) AC_INIT([GNU Mcron], [1.0.8], [bug-mcron@gnu.org]) AC_CONFIG_AUX_DIR([build-aux]) AM_INIT_AUTOMAKE +AM_SILENT_RULES([yes]) # enables silent rules by default mcronmoduledir="${datarootdir}/guile/site/2.0/mcron" AC_SUBST([mcronmoduledir]) diff --git a/makefile.am b/makefile.am index aa0b24b..1fcf32e 100644 --- a/makefile.am +++ b/makefile.am @@ -79,9 +79,15 @@ uninstall-hook: rm -f $(fpp){cron,crontab}$(EXEEXT); \ fi +# Extend silent rules to help2man. +AM_V_HELP2MAN = $(AM_V_HELP2MAN_$(V)) +AM_V_HELP2MAN_ = $(AM_V_HELP2MAN_$(AM_DEFAULT_VERBOSITY)) +AM_V_HELP2MAN_0 = @echo " HELP2MAN" $@; # 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. doc/mcron.1: mcron.c - -$(HELP2MAN) -n 'a program to run tasks at regular (or not) intervals' \ - ./mcron > $@ + -$(AM_V_HELP2MAN)$(MKDIR_P) `dirname "$@"` ; \ + $(HELP2MAN) \ + -n 'a program to run tasks at regular (or not) intervals' \ + ./mcron > $@ diff --git a/scm/mcron/makefile.am b/scm/mcron/makefile.am index ab6cae2..cb7a6bb 100644 --- a/scm/mcron/makefile.am +++ b/scm/mcron/makefile.am @@ -23,6 +23,11 @@ dist_mcronmodule_DATA = \ crontab.scm \ mcron-core.scm +# Extend silent rules to Guile compilation. +AM_V_GUILEC = $(AM_V_GUILEC_$(V)) +AM_V_GUILEC_ = $(AM_V_GUILEC_$(AM_DEFAULT_VERBOSITY)) +AM_V_GUILEC_0 = @echo " GUILEC " $@; + # Unset 'GUILE_LOAD_COMPILED_PATH' altogether while compiling. Otherwise, if # $GUILE_LOAD_COMPILED_PATH contains $(mcronmoduledir), we may find .go files # in there that are newer than the local .scm files (for instance because the @@ -33,6 +38,7 @@ dist_mcronmodule_DATA = \ # XXX: Use the C locale for when Guile lacks # . .scm.go: + $(AM_V_GUILEC)$(MKDIR_P) `dirname "$@"` ; \ unset GUILE_LOAD_COMPILED_PATH ; \ LC_ALL=C \ $(GUILD) compile \ -- cgit v1.2.3 From c925e9ad0d5ee0160331ad69ec21df0f6113f000 Mon Sep 17 00:00:00 2001 From: Mathieu Lirzin Date: Tue, 18 Aug 2015 17:49:34 +0200 Subject: main: Remove obsolete Guile debug option. * scm/mcron/main.scm (main): Remove obsolete invocation of 'debug-enable'. --- scm/mcron/main.scm | 1 - 1 file changed, 1 deletion(-) (limited to 'scm') diff --git a/scm/mcron/main.scm b/scm/mcron/main.scm index 6ac2116..58f1efa 100644 --- a/scm/mcron/main.scm +++ b/scm/mcron/main.scm @@ -311,7 +311,6 @@ comes in on the above socket." (define (main . args) ;; Turn debugging on if indicated. (when config-debug - (debug-enable 'debug) (debug-enable 'backtrace)) (when (option-ref options 'version #f) (show-version)) -- cgit v1.2.3 From b390063628269abc4f7bbc85cf59c8835d5285db Mon Sep 17 00:00:00 2001 From: Mathieu Lirzin Date: Sun, 30 Aug 2015 11:24:43 +0200 Subject: redirect: Use module (ice-9 regex). * scm/mcron/redirect.scm: Use module (ice-9 regex) to prevent variables 'match:prefix', 'match:substring', and 'match:prefix' to be unbound. --- scm/mcron/redirect.scm | 1 + 1 file changed, 1 insertion(+) (limited to 'scm') diff --git a/scm/mcron/redirect.scm b/scm/mcron/redirect.scm index 312b768..af763cb 100644 --- a/scm/mcron/redirect.scm +++ b/scm/mcron/redirect.scm @@ -31,6 +31,7 @@ (define-module (mcron redirect) #:export (with-mail-out) + #:use-module (ice-9 regex) #:use-module ((mcron config) :select (config-sendmail)) #:use-module (mcron vixie-time)) -- cgit v1.2.3 From 805c04fb9033f0d052e3be01eeeed007f940e810 Mon Sep 17 00:00:00 2001 From: Mathieu Lirzin Date: Sun, 6 Sep 2015 03:05:33 +0200 Subject: main: Improve 'process-user-file' definition. * scm/mcron/main.scm (process-user-file): Rename parameters 'file-path' to 'file-name' and 'assume-guile' to 'guile-syntax?'. Capture 'guile-regexp' and 'vixie-regexp' bindings in the procedure scope. (guile-file-regexp, vixie-file-regexp): Delete variables. --- scm/mcron/main.scm | 32 +++++++++++++++----------------- 1 file changed, 15 insertions(+), 17 deletions(-) (limited to 'scm') diff --git a/scm/mcron/main.scm b/scm/mcron/main.scm index 58f1efa..727f013 100644 --- a/scm/mcron/main.scm +++ b/scm/mcron/main.scm @@ -188,23 +188,21 @@ received." (mcron-error 0 (apply format (append (list #f fmt) args))) #f))) -(define guile-file-regexp (make-regexp "\\.gui(le)?$")) -(define vixie-file-regexp (make-regexp "\\.vix(ie)?$")) - -(define (process-user-file file-path . assume-guile) - "Process FILE-PATH according its extension. When ASSUME-GUILE is non nil, -usage of guile syntax is forced for FILE-PATH. If a file is not recognized, -it is silently ignored (this deals properly with most editors' backup files, -for instance)." - (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)))) +(define process-user-file + (let ((guile-regexp (make-regexp "\\.gui(le)?$")) + (vixie-regexp (make-regexp "\\.vix(ie)?$"))) + (lambda* (file-name #:optional guile-syntax?) + "Process FILE-NAME according its extension. When GUILE-SYNTAX? is TRUE, +force guile syntax usage. If FILE-NAME format is not recognized, it is +silently ignored." + (cond ((string=? "-" file-name) + (if (string=? (option-ref options 'stdin "guile") "vixie") + (read-vixie-port (current-input-port)) + (eval-string (stdin->string)))) + ((or guile-syntax? (regexp-exec guile-regexp file-name)) + (load file-name)) + ((regexp-exec vixie-regexp file-name) + (read-vixie-file file-name)))))) (define (process-files-in-user-directory) "Process files in $XDG_CONFIG_HOME/cron and/or ~/.cron directories (if -- cgit v1.2.3 From 960f6e18170b77bd8b4ae999257105cac11264b6 Mon Sep 17 00:00:00 2001 From: Mathieu Lirzin Date: Sun, 6 Sep 2015 18:10:42 +0200 Subject: main: Remove unused 'regular-file?' procedure. * scm/mcron/main.scm (regular-file?): Delete procedure. --- scm/mcron/main.scm | 9 --------- 1 file changed, 9 deletions(-) (limited to 'scm') diff --git a/scm/mcron/main.scm b/scm/mcron/main.scm index 727f013..0e46945 100644 --- a/scm/mcron/main.scm +++ b/scm/mcron/main.scm @@ -179,15 +179,6 @@ received." ((eof-object? in)) (display in))))) -(define (regular-file? file) - "Return true if FILE is a regular 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))) - (define process-user-file (let ((guile-regexp (make-regexp "\\.gui(le)?$")) (vixie-regexp (make-regexp "\\.vix(ie)?$"))) -- cgit v1.2.3 From c2a1d931a6533679d0d1a7e1f9416d44078bd236 Mon Sep 17 00:00:00 2001 From: Mathieu Lirzin Date: Sat, 5 Sep 2015 21:01:49 +0200 Subject: environment: Redefine 'modify-environment'. * scm/mcron/environment.scm (modify-environment): Add docstring. Compute 'passwd:dir' and 'passwd:name' only once. (impose-default-environment): Merge it into 'modify-environment'. --- scm/mcron/environment.scm | 54 ++++++++++++++++++++--------------------------- 1 file changed, 23 insertions(+), 31 deletions(-) (limited to 'scm') diff --git a/scm/mcron/environment.scm b/scm/mcron/environment.scm index 9f694f1..b563d55 100644 --- a/scm/mcron/environment.scm +++ b/scm/mcron/environment.scm @@ -1,3 +1,4 @@ +;; Copyright (C) 2015, 2016 Mathieu Lirzin ;; Copyright (C) 2003 Dale Mellor ;; ;; This file is part of GNU mcron. @@ -36,37 +37,6 @@ 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 @@ -103,3 +73,25 @@ (set! current-environment-mods (append current-environment-mods (list (cons name value)))) #t) + +(define (modify-environment env passwd-entry) + "Modify the environment (in the UNIX sense) by setting the variables from +ENV and some default ones which are modulated by PASSWD-ENTRY. \"LOGNAME\" +and \"USER\" environment variables can't be overided by ENV. ENV must be an +alist which associate environment variables to their value. PASSWD-ENTRY must +be an object representing user information which corresponds to a valid entry +in /etc/passwd. The return value is not specified." + (for-each (lambda (pair) (setenv (car pair) (cdr pair))) + (let ((home-dir (passwd:dir passwd-entry)) + (user-name (passwd:name passwd-entry))) + (append + ;; Default environment variables which can be overided by ENV. + `(("HOME" . ,home-dir) + ("CWD" . ,home-dir) + ("SHELL" . ,(passwd:shell passwd-entry)) + ("TERM" . #f) + ("TERMCAP" . #f)) + env + ;; Environment variables with imposed values. + `(("LOGNAME" . ,user-name) + ("USER" . ,user-name)))))) -- cgit v1.2.3 From f2c56d355f883dd60aef020b4e363739aeff856c Mon Sep 17 00:00:00 2001 From: Mathieu Lirzin Date: Mon, 7 Sep 2015 00:00:31 +0200 Subject: all: Add a custom indentation rule for 'mcron-error'. * .dir-locals.el: Define a custom indentation rule for 'mcron-error'. * scm/mcron/crontab.scm: Use it. * scm/mcron/job-specifier.scm: Likewise. * scm/mcron/main.scm: Likewise. * scm/mcron/vixie-specification.scm: Likewise. --- .dir-locals.el | 5 ++++- scm/mcron/crontab.scm | 4 ++-- scm/mcron/job-specifier.scm | 14 ++++++-------- scm/mcron/main.scm | 23 ++++++++--------------- scm/mcron/vixie-specification.scm | 12 +++++------- 5 files changed, 25 insertions(+), 33 deletions(-) (limited to 'scm') diff --git a/.dir-locals.el b/.dir-locals.el index 12a5eb5..c94ea0c 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -4,4 +4,7 @@ (tab-width . 8))) (c-mode . ((c-file-style . "gnu") (indent-tabs-mode . nil))) - (scheme-mode . ((indent-tabs-mode . nil)))) + (scheme-mode + . + ((indent-tabs-mode . nil) + (eval . (put 'mcron-error 'scheme-indent-function 1))))) diff --git a/scm/mcron/crontab.scm b/scm/mcron/crontab.scm index 30e5592..6be5c61 100644 --- a/scm/mcron/crontab.scm +++ b/scm/mcron/crontab.scm @@ -221,8 +221,8 @@ ;; 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."))) + (else (mcron-error 15 + "usage error: file name must be specified for replace."))) )) ;; End of file-level let-scopes. diff --git a/scm/mcron/job-specifier.scm b/scm/mcron/job-specifier.scm index cce948c..1647ede 100644 --- a/scm/mcron/job-specifier.scm +++ b/scm/mcron/job-specifier.scm @@ -233,10 +233,9 @@ ((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)")))) + (throw 'mcron-error 2 + "job: invalid second argument (action; should be lambda " + "function, string or list)")))) (time-proc (cond ((procedure? time-proc) time-proc) @@ -244,10 +243,9 @@ ((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)"))) + (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") diff --git a/scm/mcron/main.scm b/scm/mcron/main.scm index 0e46945..9425cef 100644 --- a/scm/mcron/main.scm +++ b/scm/mcron/main.scm @@ -217,8 +217,7 @@ $XDG_CONFIG_HOME is not defined uses ~/.config/cron instead)." "/cron"))) (when (eq? 2 errors) (mcron-error 13 - "Cannot read files in your ~/.config/cron (or ~/.cron) " - "directory.")))) + "Cannot read files in your ~/.config/cron (or ~/.cron) directory.")))) (define (valid-user user-name) "Check that USER-NAME is in the passwd database (it may happen that a user @@ -248,9 +247,8 @@ operation. The permissions on the /var/cron/tabs directory enforce this." "/" file-name))))))) (lambda (key . args) - (mcron-error - 4 - "You do not have permission to access the system crontabs.")))) + (mcron-error 4 + "You do not have permission to access the system crontabs.")))) (define (cron-file-descriptors) "Establish a socket to listen for updates from a crontab program, and return @@ -265,9 +263,7 @@ crontab. This requires that command-type is 'cron." (list sock))) (lambda (key . args) (delete-file config-pid-file) - (mcron-error 1 - "Cannot bind to UNIX socket " - config-socket-file))) + (mcron-error 1 "Cannot bind to UNIX socket " config-socket-file))) '())) (define (process-update-request fdes-list) @@ -319,15 +315,12 @@ comes in on the above socket." (when (eq? command-type 'cron) (unless (eqv? (getuid) 0) (mcron-error 16 - "This program must be run by the root user (and should " - "have been installed as such).")) + "This program must be run by the root user (and should have been " + "installed as such).")) (when (access? config-pid-file F_OK) (mcron-error 1 - "A cron daemon is already running.\n" - " (If you are sure this is not true, remove the file\n" - " " - config-pid-file - ".)")) + "A cron daemon is already running.\n (If you are sure this is not" + " true, remove the file\n " config-pid-file ".)")) (unless (option-ref options 'schedule #f) (with-output-to-file config-pid-file noop)) (setenv "MAILTO" #f) diff --git a/scm/mcron/vixie-specification.scm b/scm/mcron/vixie-specification.scm index ab002ba..5cd1528 100644 --- a/scm/mcron/vixie-specification.scm +++ b/scm/mcron/vixie-specification.scm @@ -162,13 +162,11 @@ (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))))))))) + (throw 'mcron-error exit-code + (apply string-append + (number->string report-line) + ": " + msg))))))))) -- cgit v1.2.3 From 4da7aec83b6f8f854568ac150ed129502486bf14 Mon Sep 17 00:00:00 2001 From: Mathieu Lirzin Date: Mon, 7 Sep 2015 00:50:14 +0200 Subject: main: Add 'for-each-file' procedure. * scm/mcron/main.scm (for-each-file): New procedure. (process-files-in-user-directory, process-files-in-system-directory): Use it. --- scm/mcron/main.scm | 61 +++++++++++++++++++++++++++++------------------------- 1 file changed, 33 insertions(+), 28 deletions(-) (limited to 'scm') diff --git a/scm/mcron/main.scm b/scm/mcron/main.scm index 9425cef..a84f82f 100644 --- a/scm/mcron/main.scm +++ b/scm/mcron/main.scm @@ -179,6 +179,15 @@ received." ((eof-object? in)) (display in))))) +(define (for-each-file proc directory) + "Apply PROC to each file in DIRECTORY. DIRECTORY must be a valid directory name. +PROC must be a procedure that take one file name argument. The return value +is not specified" + (let ((dir (opendir directory))) + (do ((file-name (readdir dir) (readdir dir))) + ((eof-object? file-name) (closedir dir)) + (proc file-name)))) + (define process-user-file (let ((guile-regexp (make-regexp "\\.gui(le)?$")) (vixie-regexp (make-regexp "\\.vix(ie)?$"))) @@ -200,21 +209,19 @@ silently ignored." $XDG_CONFIG_HOME is not defined uses ~/.config/cron instead)." (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"))) + (map (lambda (dir) + (catch #t + (lambda () + (for-each-file + (lambda (file) + (process-user-file (string-append dir "/" file))) + dir)) + (lambda (key . args) + (set! errors (1+ errors))))) + (list (string-append home-directory "/.cron") + (string-append (or (getenv "XDG_CONFIG_HOME") + (string-append home-directory "/.config")) + "/cron"))) (when (eq? 2 errors) (mcron-error 13 "Cannot read files in your ~/.config/cron (or ~/.cron) directory.")))) @@ -236,19 +243,17 @@ run on behalf of the configuration files, the jobs are registered on the system with the appropriate user. Only root should be able to perform this operation. The permissions on the /var/cron/tabs directory enforce this." (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.")))) + (lambda () + (for-each-file + (lambda (user) + (and-let* ((user* (valid-user user))) ;crontab without user? + (set-configuration-user user*) + (catch-mcron-error + (read-vixie-file (string-append config-spool-dir "/" user))))) + config-spool-dir)) + (lambda (key . args) + (mcron-error 4 + "You do not have permission to access the system crontabs.")))) (define (cron-file-descriptors) "Establish a socket to listen for updates from a crontab program, and return -- cgit v1.2.3 From fdbaa674a73c04681d574a4eabf5a723dc716d38 Mon Sep 17 00:00:00 2001 From: Mathieu Lirzin Date: Mon, 7 Sep 2015 00:54:45 +0200 Subject: main: Remove 'valid-user' procedure. * scm/mcron/main.scm (valid-user): Delete procedure. (process-files-in-system-directory): Adjust accordingly by using a local definition. --- scm/mcron/main.scm | 20 +++++++------------- 1 file changed, 7 insertions(+), 13 deletions(-) (limited to 'scm') diff --git a/scm/mcron/main.scm b/scm/mcron/main.scm index a84f82f..1f2b068 100644 --- a/scm/mcron/main.scm +++ b/scm/mcron/main.scm @@ -226,28 +226,22 @@ $XDG_CONFIG_HOME is not defined uses ~/.config/cron instead)." (mcron-error 13 "Cannot read files in your ~/.config/cron (or ~/.cron) directory.")))) -(define (valid-user user-name) - "Check that 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, Return the -full passwd entry for that user." - (setpwent) - (do ((entry (getpw) (getpw))) - ((or (not entry) - (string=? (passwd:name entry) user-name)) - (endpwent) - entry))) - (define (process-files-in-system-directory) "Process all the files in the crontab directory. When the job procedure is run on behalf of the configuration files, the jobs are registered on the system with the appropriate user. Only root should be able to perform this operation. The permissions on the /var/cron/tabs directory enforce this." + + (define (user-entry name) + ;; Return the user database entry if NAME is valid, otherwise #f. + (false-if-exception (getpwnam name))) + (catch #t (lambda () (for-each-file (lambda (user) - (and-let* ((user* (valid-user user))) ;crontab without user? - (set-configuration-user user*) + (and-let* ((entry (user-entry user))) ;crontab without user? + (set-configuration-user entry) (catch-mcron-error (read-vixie-file (string-append config-spool-dir "/" user))))) config-spool-dir)) -- cgit v1.2.3 From 589d5ff8d152be5d21c49790dff92ccb27d6c291 Mon Sep 17 00:00:00 2001 From: Mathieu Lirzin Date: Wed, 23 Sep 2015 22:09:23 +0200 Subject: core: Use SRFI-9 records for the job data structure. * scm/mcron/mcron-core.scm : New record type. This Replaces a vector data structure. All consumers changed. --- scm/mcron/mcron-core.scm | 93 ++++++++++++++++++++++++------------------------ 1 file changed, 46 insertions(+), 47 deletions(-) (limited to 'scm') diff --git a/scm/mcron/mcron-core.scm b/scm/mcron/mcron-core.scm index 518bcac..13781c9 100644 --- a/scm/mcron/mcron-core.scm +++ b/scm/mcron/mcron-core.scm @@ -1,3 +1,4 @@ +;; Copyright (C) 2015, 2016 Mathieu Lirzin ;; Copyright (C) 2003 Dale Mellor ;; ;; This file is part of GNU mcron. @@ -19,6 +20,7 @@ (define-module (mcron core) #:use-module (mcron environment) + #:use-module (srfi srfi-9) #:export (add-job remove-user-jobs get-schedule @@ -38,7 +40,7 @@ ;; 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) +;; (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 @@ -60,18 +62,17 @@ (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)) - - +;; 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. @@ -97,12 +98,12 @@ (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)))) + (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))))) @@ -165,18 +166,17 @@ (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))))))) + (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))))))) @@ -195,22 +195,21 @@ ;; 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)) + (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)) -- cgit v1.2.3 From b59f2f5ea6f99681ca61f9342206c11f3a165b2c Mon Sep 17 00:00:00 2001 From: Mathieu Lirzin Date: Sat, 17 Oct 2015 19:56:03 +0200 Subject: build: Use a non-recursive makefile. * configure.ac (AM_INIT_AUTOMAKE): Use 'subdir-objects' option. (AC_CONFIG_FILES): Remove 'scm/mcron/makefile' and 'makefile'. Add 'Makefile'. * makefile.am: Delete file. Move its content into ... * scm/mcron/makefile.am: Likewise. * Makefile.am: ... this. New file. * .gitignore: Update. --- .gitignore | 30 +++++------ Makefile.am | 145 ++++++++++++++++++++++++++++++++++++++++++++++++++ configure.ac | 5 +- makefile.am | 93 -------------------------------- scm/mcron/makefile.am | 59 -------------------- 5 files changed, 162 insertions(+), 170 deletions(-) create mode 100644 Makefile.am delete mode 100644 makefile.am delete mode 100644 scm/mcron/makefile.am (limited to 'scm') diff --git a/.gitignore b/.gitignore index 9748b8a..3aa3599 100644 --- a/.gitignore +++ b/.gitignore @@ -1,9 +1,7 @@ -*~ *.go +*.o +*~ .deps -INSTALL -aclocal.m4 -autom4te.cache /build-aux/compile /build-aux/config.guess /build-aux/config.sub @@ -12,6 +10,19 @@ autom4te.cache /build-aux/mdate-sh /build-aux/missing /build-aux/texinfo.tex +/doc/.dirstamp +/doc/config.texi +/doc/mcron.1 +/doc/mcron.info +/doc/stamp-vti +/doc/version.texi +/mcron +/mdate-sh +INSTALL +Makefile +Makefile.in +aclocal.m4 +autom4te.cache compile config.cache config.log @@ -20,17 +31,6 @@ config.status configure core.scm depcomp -/doc/.dirstamp -/doc/config.texi -/doc/mcron.info -/doc/mcron.1 -/doc/stamp-vti -/doc/version.texi install-sh -makefile -makefile.in -/mcron -/mdate-sh -*.o missing texinfo.tex diff --git a/Makefile.am b/Makefile.am new file mode 100644 index 0000000..8c7b4d0 --- /dev/null +++ b/Makefile.am @@ -0,0 +1,145 @@ +## Process this file with automake to produce Makefile.in. + +# Copyright (C) 2003 Dale Mellor +# Copyright (C) 2015, 2016 Mathieu Lirzin +# +# This program 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. +# +# This program 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 this program. If not, see . + +bin_PROGRAMS = mcron +mcron_SOURCES = mcron.c +mcron_CFLAGS = @GUILE_CFLAGS@ -DGUILE_LOAD_PATH=\"$(datadir):./scm:...\" +mcron_DEPENDENCIES = $(GOBJECTS) # Build Guile modules before linking. +mcron_LDADD = @GUILE_LIBS@ + +MODULES = \ + scm/mcron/environment.scm \ + scm/mcron/job-specifier.scm \ + scm/mcron/main.scm \ + scm/mcron/redirect.scm \ + scm/mcron/vixie-specification.scm \ + scm/mcron/vixie-time.scm + +GEN_MODULES = \ + scm/mcron/config.scm \ + scm/mcron/core.scm + +CP = @CP@ +# XXX: Prevent the 'configure' script to delete the 'core.*' files. +scm/mcron/core.scm: scm/mcron/mcron-core.scm + $(CP) $< $@ + +GOBJECTS = \ + $(GEN_MODULES:%.scm=%.go) \ + $(MODULES:%.scm=%.go) + +mcronmodule_DATA = \ + $(GOBJECTS) \ + $(GEN_MODULES) + +dist_mcronmodule_DATA = \ + $(MODULES) \ + scm/mcron/crontab.scm \ + scm/mcron/mcron-core.scm + +# Unset 'GUILE_LOAD_COMPILED_PATH' altogether while compiling. Otherwise, if +# $GUILE_LOAD_COMPILED_PATH contains $(mcronmoduledir), we may find .go files +# in there that are newer than the local .scm files (for instance because the +# user ran 'make install' recently). When that happens, we end up loading +# those previously-installed .go files, which may be stale, thereby breaking +# the whole thing. +# +# XXX: Use the C locale for when Guile lacks +# . +.scm.go: + $(AM_V_GUILEC)$(MKDIR_P) `dirname "$@"` ; \ + unset GUILE_LOAD_COMPILED_PATH ; \ + LC_ALL=C \ + $(GUILD) compile \ + --load-path="$(top_builddir)/scm" \ + --load-path="$(top_srcdir)/scm" \ + --warn=format --warn=unbound-variable --warn=arity-mismatch \ + --target="$(host)" --output="$@" "$<" + +SUFFIXES = .go + +dist-hook: gen-ChangeLog + +gen_start_date = 2015-06-26 +.PHONY: gen-ChangeLog +gen-ChangeLog: + $(AM_V_GEN)if test -d $(srcdir)/.git; then \ + log_fix="$(srcdir)/build-aux/git-log-fix"; \ + test -e "$$log_fix" \ + && amend_git_log="--amend=$$log_fix" \ + || amend_git_log=; \ + $(top_srcdir)/build-aux/gitlog-to-changelog \ + $$amend_git_log --since=$(gen_start_date) > $(distdir)/cl-t && \ + { rm -f $(distdir)/ChangeLog && \ + mv $(distdir)/cl-t $(distdir)/ChangeLog; } \ + fi + +#full program prefix +fpp = $(DESTDIR)$(bindir)/@real_program_prefix@ + +install-exec-hook: + @if [ "x@NO_VIXIE_CLOBBER@" != "xyes" -a "`id -u`" -eq "0" ]; then \ + rm -f $(fpp)cron$(EXEEXT) > /dev/null 2>&1; \ + $(INSTALL) --mode='u=rwx' mcron$(EXEEXT) $(fpp)cron$(EXEEXT); \ + rm -f $(fpp)crontab$(EXEEXT) > /dev/null 2>&1; \ + $(INSTALL) --mode='u=rwxs,og=rx' mcron$(EXEEXT) $(fpp)crontab$(EXEEXT); \ + $(INSTALL) -d --mode='u=rwx' $(DESTDIR)/var/cron; \ + $(INSTALL) -d --mode='u=rwx,og=rx' $(DESTDIR)/var/run; \ + $(INSTALL) -d --mode='u=rwx,og=rx' $(DESTDIR)@GUILE_SITE@; \ + $(INSTALL) -d --mode='u=rwx,og=rx' $(DESTDIR)@GUILE_SITE@/mcron; \ + elif [ "x@NO_VIXIE_CLOBBER@" = "xyes" ]; then \ + echo "Not installing Vixie-style programs"; \ + else \ + echo "+++ WARNING: NON-ROOT INSTALL: ONLY mcron WILL BE INSTALLED, NOT ANY OF THE VIXIE REPLACEMENT PROGRAMS"; \ + fi + +uninstall-hook: + if [ "`id -u`" -eq "0" ]; then \ + rm -f $(fpp){cron,crontab}$(EXEEXT); \ + fi + +EXTRA_DIST = BUGS +CLEANFILES = $(GOBJECTS) + +## --------------- ## +## Documentation. ## +## --------------- ## + +info_TEXINFOS = doc/mcron.texi +doc_mcron_TEXINFOS = doc/fdl.texi +dist_man_MANS = doc/mcron.1 + +# 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. +doc/mcron.1: mcron.c + -$(AM_V_HELP2MAN)$(MKDIR_P) `dirname "$@"` ; \ + $(HELP2MAN) \ + -n 'a program to run tasks at regular (or not) intervals' \ + ./mcron > $@ + +## -------------- ## +## Silent rules. ## +## -------------- ## + +AM_V_GUILEC = $(AM_V_GUILEC_$(V)) +AM_V_GUILEC_ = $(AM_V_GUILEC_$(AM_DEFAULT_VERBOSITY)) +AM_V_GUILEC_0 = @echo " GUILEC " $@; + +AM_V_HELP2MAN = $(AM_V_HELP2MAN_$(V)) +AM_V_HELP2MAN_ = $(AM_V_HELP2MAN_$(AM_DEFAULT_VERBOSITY)) +AM_V_HELP2MAN_0 = @echo " HELP2MAN" $@; diff --git a/configure.ac b/configure.ac index 54481dd..9972ad5 100644 --- a/configure.ac +++ b/configure.ac @@ -24,7 +24,7 @@ AC_PREREQ(2.61) AC_INIT([GNU Mcron], [1.0.8], [bug-mcron@gnu.org]) AC_CONFIG_AUX_DIR([build-aux]) -AM_INIT_AUTOMAKE +AM_INIT_AUTOMAKE([subdir-objects]) AM_SILENT_RULES([yes]) # enables silent rules by default mcronmoduledir="${datarootdir}/guile/site/2.0/mcron" @@ -182,7 +182,6 @@ real_program_prefix=`echo $program_prefix | sed s/NONE//` AC_SUBST(real_program_prefix) AC_CONFIG_FILES([doc/config.texi - makefile - scm/mcron/makefile + Makefile scm/mcron/config.scm]) AC_OUTPUT diff --git a/makefile.am b/makefile.am deleted file mode 100644 index 1fcf32e..0000000 --- a/makefile.am +++ /dev/null @@ -1,93 +0,0 @@ -## Makefile for the toplevel directory of mcron. -## Copyright (C) 2003 Dale Mellor -## Copyright (C) 2015 Mathieu Lirzin -## -# This file is part of GNU mcron. -# -# GNU mcron is free software: you can redistribute it and/or modify it under -# the terms of the GNU General Public License as published by the Free -# Software Foundation, either version 3 of the License, or (at your option) -# any later version. -# -# GNU mcron is distributed in the hope that it will be useful, but WITHOUT -# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for -# more details. -# -# You should have received a copy of the GNU General Public License along -# with GNU mcron. If not, see . - -## Process this file with automake to produce Makefile.in - -SUBDIRS = scm/mcron . - -CP = @CP@ - -EXTRA_DIST = BUGS ChangeLog.old - -info_TEXINFOS = doc/mcron.texi -doc_mcron_TEXINFOS = doc/fdl.texi -dist_man_MANS = doc/mcron.1 - -bin_PROGRAMS = mcron -mcron_SOURCES = mcron.c -mcron_LDADD = @GUILE_LIBS@ - -# 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:...\" - -dist-hook: gen-ChangeLog - -gen_start_date = 2015-06-26 -.PHONY: gen-ChangeLog -gen-ChangeLog: - $(AM_V_GEN)if test -d $(srcdir)/.git; then \ - log_fix="$(srcdir)/build-aux/git-log-fix"; \ - test -e "$$log_fix" \ - && amend_git_log="--amend=$$log_fix" \ - || amend_git_log=; \ - $(top_srcdir)/build-aux/gitlog-to-changelog \ - $$amend_git_log --since=$(gen_start_date) > $(distdir)/cl-t && \ - { rm -f $(distdir)/ChangeLog && \ - mv $(distdir)/cl-t $(distdir)/ChangeLog; } \ - fi - -#full program prefix -fpp = $(DESTDIR)$(bindir)/@real_program_prefix@ - - -install-exec-hook: - @if [ "x@NO_VIXIE_CLOBBER@" != "xyes" -a "`id -u`" -eq "0" ]; then \ - rm -f $(fpp)cron$(EXEEXT) > /dev/null 2>&1; \ - $(INSTALL) --mode='u=rwx' mcron$(EXEEXT) $(fpp)cron$(EXEEXT); \ - rm -f $(fpp)crontab$(EXEEXT) > /dev/null 2>&1; \ - $(INSTALL) --mode='u=rwxs,og=rx' mcron$(EXEEXT) $(fpp)crontab$(EXEEXT); \ - $(INSTALL) -d --mode='u=rwx' $(DESTDIR)/var/cron; \ - $(INSTALL) -d --mode='u=rwx,og=rx' $(DESTDIR)/var/run; \ - $(INSTALL) -d --mode='u=rwx,og=rx' $(DESTDIR)@GUILE_SITE@; \ - $(INSTALL) -d --mode='u=rwx,og=rx' $(DESTDIR)@GUILE_SITE@/mcron; \ - elif [ "x@NO_VIXIE_CLOBBER@" = "xyes" ]; then \ - echo "Not installing Vixie-style programs"; \ - else \ - echo "+++ WARNING: NON-ROOT INSTALL: ONLY mcron WILL BE INSTALLED, NOT ANY OF THE VIXIE REPLACEMENT PROGRAMS"; \ - fi - - -uninstall-hook: - if [ "`id -u`" -eq "0" ]; then \ - rm -f $(fpp){cron,crontab}$(EXEEXT); \ - fi - -# Extend silent rules to help2man. -AM_V_HELP2MAN = $(AM_V_HELP2MAN_$(V)) -AM_V_HELP2MAN_ = $(AM_V_HELP2MAN_$(AM_DEFAULT_VERBOSITY)) -AM_V_HELP2MAN_0 = @echo " HELP2MAN" $@; - -# 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. -doc/mcron.1: mcron.c - -$(AM_V_HELP2MAN)$(MKDIR_P) `dirname "$@"` ; \ - $(HELP2MAN) \ - -n 'a program to run tasks at regular (or not) intervals' \ - ./mcron > $@ diff --git a/scm/mcron/makefile.am b/scm/mcron/makefile.am deleted file mode 100644 index cb7a6bb..0000000 --- a/scm/mcron/makefile.am +++ /dev/null @@ -1,59 +0,0 @@ -MODULES = \ - environment.scm \ - job-specifier.scm \ - main.scm \ - redirect.scm \ - vixie-specification.scm \ - vixie-time.scm - -GEN_MODULES = \ - config.scm \ - core.scm - -GOBJECTS = \ - $(GEN_MODULES:%.scm=%.go) \ - $(MODULES:%.scm=%.go) - -mcronmodule_DATA = \ - $(GOBJECTS) \ - $(GEN_MODULES) - -dist_mcronmodule_DATA = \ - $(MODULES) \ - crontab.scm \ - mcron-core.scm - -# Extend silent rules to Guile compilation. -AM_V_GUILEC = $(AM_V_GUILEC_$(V)) -AM_V_GUILEC_ = $(AM_V_GUILEC_$(AM_DEFAULT_VERBOSITY)) -AM_V_GUILEC_0 = @echo " GUILEC " $@; - -# Unset 'GUILE_LOAD_COMPILED_PATH' altogether while compiling. Otherwise, if -# $GUILE_LOAD_COMPILED_PATH contains $(mcronmoduledir), we may find .go files -# in there that are newer than the local .scm files (for instance because the -# user ran 'make install' recently). When that happens, we end up loading -# those previously-installed .go files, which may be stale, thereby breaking -# the whole thing. -# -# XXX: Use the C locale for when Guile lacks -# . -.scm.go: - $(AM_V_GUILEC)$(MKDIR_P) `dirname "$@"` ; \ - unset GUILE_LOAD_COMPILED_PATH ; \ - LC_ALL=C \ - $(GUILD) compile \ - --load-path="$(top_builddir)/scm" \ - --load-path="$(top_srcdir)/scm" \ - --warn=format --warn=unbound-variable --warn=arity-mismatch \ - --target="$(host)" --output="$@" "$<" - -SUFFIXES = .go -CLEANFILES = $(GOBJECTS) - -# 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). - -core.scm : mcron-core.scm - $(CP) mcron-core.scm core.scm - -- cgit v1.2.3 From 5da0024b934513aa76a2cb32dc8f6cb00370262a Mon Sep 17 00:00:00 2001 From: Mathieu Lirzin Date: Wed, 20 Apr 2016 02:53:22 +0200 Subject: job-specifier: Rewrite 'range' procedure. * scm/mcron/job-specifier.scm (range): Use 'unfold'. --- scm/mcron/job-specifier.scm | 25 ++++++++----------------- 1 file changed, 8 insertions(+), 17 deletions(-) (limited to 'scm') diff --git a/scm/mcron/job-specifier.scm b/scm/mcron/job-specifier.scm index 1647ede..3f73b82 100644 --- a/scm/mcron/job-specifier.scm +++ b/scm/mcron/job-specifier.scm @@ -1,4 +1,5 @@ ;; Copyright (C) 2003 Dale Mellor +;; Copyright (C) 2016 Mathieu Lirzin ;; ;; This file is part of GNU mcron. ;; @@ -37,26 +38,16 @@ #:use-module (mcron core) #:use-module (mcron environment) #:use-module (mcron vixie-time) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) #:re-export (append-environment-mods)) - -;; 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))))))) - - +(define* (range start end #:optional (step 1)) + "Produces a list of values from START up to (but not including) END. An +optional STEP may be supplied, and (if positive) only every step'th value will +go into the list. For example, (range 1 6 2) returns '(1 3 5)." + (unfold (cut >= <> end) identity (cute + <> (max step 1)) start)) ;; 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 -- cgit v1.2.3 From 5097e30babe31a40a3fb8e281fee2a472414e5f8 Mon Sep 17 00:00:00 2001 From: Mathieu Lirzin Date: Wed, 20 Apr 2016 04:31:52 +0200 Subject: job-specifier: Add '%find-best-next' procedure. * scm/mcron/job-specifier.scm (find-best-next): Rename to ... (%find-best-next): ... this. Rewrite it using a functional style. All callers changed. --- scm/mcron/job-specifier.scm | 50 +++++++++++++++++++-------------------------- scm/mcron/vixie-time.scm | 25 +++++++++++------------ 2 files changed, 33 insertions(+), 42 deletions(-) (limited to 'scm') diff --git a/scm/mcron/job-specifier.scm b/scm/mcron/job-specifier.scm index 3f73b82..1c2f9d9 100644 --- a/scm/mcron/job-specifier.scm +++ b/scm/mcron/job-specifier.scm @@ -24,6 +24,13 @@ ;; add-job function), and the procedure for declaring environment modifications. (define-module (mcron job-specifier) + #:use-module (ice-9 match) + #:use-module (mcron core) + #:use-module (mcron environment) + #:use-module (mcron vixie-time) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:re-export (append-environment-mods) #:export (range next-year-from next-year next-month-from next-month @@ -33,15 +40,7 @@ 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) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-26) - #:re-export (append-environment-mods)) - + job)) (define* (range start end #:optional (step 1)) "Produces a list of values from START up to (but not including) END. An @@ -49,25 +48,18 @@ optional STEP may be supplied, and (if positive) only every step'th value will go into the list. For example, (range 1 6 2) returns '(1 3 5)." (unfold (cut >= <> end) identity (cute + <> (max step 1)) start)) -;; 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)) - - +(define (%find-best-next current next-list) + ;; Takes a value and a list of possible next values (all assumed less than + ;; 9999). It returns a pair consisting of the smallest element of the + ;; NEXT-LIST, and the smallest element larger than the CURRENT value. If an + ;; example of the latter cannot be found, 9999 will be returned. + (let loop ((smallest 9999) (closest+ 9999) (lst next-list)) + (match lst + (() (cons smallest closest+)) + ((time . rest) + (loop (min time smallest) + (if (> time current) (min time closest+) closest+) + rest))))) ;; Internal function to return the time corresponding to some near future ;; hour. If hour-list is not supplied, the time returned corresponds to the @@ -89,7 +81,7 @@ go into the list. For example, (range 1 6 2) returns '(1 3 5)." 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)))) + (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)) diff --git a/scm/mcron/vixie-time.scm b/scm/mcron/vixie-time.scm index 2f26a6d..a91fa89 100644 --- a/scm/mcron/vixie-time.scm +++ b/scm/mcron/vixie-time.scm @@ -15,15 +15,13 @@ ;; 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)) - + #:use-module (ice-9 regex) + #:use-module (mcron job-specifier) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-13) + #:use-module (srfi srfi-14) + #:export (parse-vixie-time)) ;; In Vixie-style time specifications three-letter symbols are allowed to stand ;; for the numbers corresponding to months and days of the week. We deal with @@ -179,11 +177,12 @@ ;; 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))) + (let* ((time-list (time-spec:list time-spec)) + (getter (time-spec:getter time-spec)) + (setter (time-spec:setter time-spec)) + (find-best-next (@@ (mcron job-specifier) %find-best-next)) + (next-best (find-best-next (getter time) time-list)) + (wrap-around (eqv? (cdr next-best) 9999))) (setter time ((if wrap-around car cdr) next-best)) wrap-around)) -- cgit v1.2.3 From 995bc9ca6ebf6880d7e7e6f3d1baa2941758fc47 Mon Sep 17 00:00:00 2001 From: Mathieu Lirzin Date: Sat, 7 May 2016 11:09:44 +0200 Subject: all: Rename 'scm' directory to 'src'. * scm/mcron/config.scm.in: Rename to ... * src/mcron/config.scm.in: ... this. * scm/mcron/crontab.scm: Rename to ... * src/mcron/crontab.scm: ... this. * scm/mcron/environment.scm: Rename to ... * src/mcron/environment.scm: ... this. * scm/mcron/job-specifier.scm: Rename to ... * src/mcron/job-specifier.scm: ... this. * scm/mcron/main.scm: Rename to ... * src/mcron/main.scm: ... this. * scm/mcron/mcron-core.scm: Rename to ... * src/mcron/mcron-core.scm: ... this. * scm/mcron/redirect.scm: Rename to ... * src/mcron/redirect.scm: ... this. * scm/mcron/vixie-specification.scm: Rename to ... * src/mcron/vixie-specification.scm: ... this. * scm/mcron/vixie-time.scm: Rename to ... * src/mcron/vixie-time.scm: ... this. * mcron.c: Rename to ... * src/mcron.c: ... this. * Makefile.am: Adapt to them. * build-aux/pre-inst-env.in: Likewise. * configure.ac (AC_CONFIG_FILES): Likewise. (AC_CONFIG_HEADER): Set to 'src/config.h'. * .gitignore: Update. --- .gitignore | 2 +- Makefile.am | 30 +-- build-aux/pre-inst-env.in | 4 +- configure.ac | 4 +- mcron.c | 87 --------- scm/mcron/config.scm.in | 39 ---- scm/mcron/crontab.scm | 228 ---------------------- scm/mcron/environment.scm | 97 --------- scm/mcron/job-specifier.scm | 253 ------------------------ scm/mcron/main.scm | 401 -------------------------------------- scm/mcron/mcron-core.scm | 270 ------------------------- scm/mcron/redirect.scm | 190 ------------------ scm/mcron/vixie-specification.scm | 207 -------------------- scm/mcron/vixie-time.scm | 384 ------------------------------------ src/mcron.c | 87 +++++++++ src/mcron/config.scm.in | 39 ++++ src/mcron/crontab.scm | 228 ++++++++++++++++++++++ src/mcron/environment.scm | 97 +++++++++ src/mcron/job-specifier.scm | 253 ++++++++++++++++++++++++ src/mcron/main.scm | 401 ++++++++++++++++++++++++++++++++++++++ src/mcron/mcron-core.scm | 270 +++++++++++++++++++++++++ src/mcron/redirect.scm | 190 ++++++++++++++++++ src/mcron/vixie-specification.scm | 207 ++++++++++++++++++++ src/mcron/vixie-time.scm | 384 ++++++++++++++++++++++++++++++++++++ 24 files changed, 2176 insertions(+), 2176 deletions(-) delete mode 100644 mcron.c delete mode 100644 scm/mcron/config.scm.in delete mode 100644 scm/mcron/crontab.scm delete mode 100644 scm/mcron/environment.scm delete mode 100644 scm/mcron/job-specifier.scm delete mode 100644 scm/mcron/main.scm delete mode 100644 scm/mcron/mcron-core.scm delete mode 100644 scm/mcron/redirect.scm delete mode 100644 scm/mcron/vixie-specification.scm delete mode 100644 scm/mcron/vixie-time.scm create mode 100644 src/mcron.c create mode 100644 src/mcron/config.scm.in create mode 100644 src/mcron/crontab.scm create mode 100644 src/mcron/environment.scm create mode 100644 src/mcron/job-specifier.scm create mode 100644 src/mcron/main.scm create mode 100644 src/mcron/mcron-core.scm create mode 100644 src/mcron/redirect.scm create mode 100644 src/mcron/vixie-specification.scm create mode 100644 src/mcron/vixie-time.scm (limited to 'scm') diff --git a/.gitignore b/.gitignore index 17829a7..8bffc85 100644 --- a/.gitignore +++ b/.gitignore @@ -2,6 +2,7 @@ *.o *~ .deps +.dirstamp /build-aux/compile /build-aux/config.guess /build-aux/config.sub @@ -10,7 +11,6 @@ /build-aux/mdate-sh /build-aux/missing /build-aux/texinfo.tex -/doc/.dirstamp /doc/config.texi /doc/mcron.1 /doc/mcron.info diff --git a/Makefile.am b/Makefile.am index 4f11c0f..1b5317c 100644 --- a/Makefile.am +++ b/Makefile.am @@ -17,26 +17,26 @@ # along with this program. If not, see . bin_PROGRAMS = mcron -mcron_SOURCES = mcron.c +mcron_SOURCES = src/mcron.c mcron_CFLAGS = @GUILE_CFLAGS@ mcron_DEPENDENCIES = $(GOBJECTS) # Build Guile modules before linking. mcron_LDADD = @GUILE_LIBS@ MODULES = \ - scm/mcron/environment.scm \ - scm/mcron/job-specifier.scm \ - scm/mcron/main.scm \ - scm/mcron/redirect.scm \ - scm/mcron/vixie-specification.scm \ - scm/mcron/vixie-time.scm + src/mcron/environment.scm \ + src/mcron/job-specifier.scm \ + src/mcron/main.scm \ + src/mcron/redirect.scm \ + src/mcron/vixie-specification.scm \ + src/mcron/vixie-time.scm GEN_MODULES = \ - scm/mcron/config.scm \ - scm/mcron/core.scm + src/mcron/config.scm \ + src/mcron/core.scm CP = @CP@ # XXX: Prevent the 'configure' script to delete the 'core.*' files. -scm/mcron/core.scm: scm/mcron/mcron-core.scm +src/mcron/core.scm: src/mcron/mcron-core.scm $(CP) $< $@ GOBJECTS = \ @@ -49,8 +49,8 @@ mcronmodule_DATA = \ dist_mcronmodule_DATA = \ $(MODULES) \ - scm/mcron/crontab.scm \ - scm/mcron/mcron-core.scm + src/mcron/crontab.scm \ + src/mcron/mcron-core.scm # Unset 'GUILE_LOAD_COMPILED_PATH' altogether while compiling. Otherwise, if # $GUILE_LOAD_COMPILED_PATH contains $(mcronmoduledir), we may find .go files @@ -67,8 +67,8 @@ dist_mcronmodule_DATA = \ export GUILE_AUTO_COMPILE=0 ; unset GUILE_LOAD_COMPILED_PATH ; \ LC_ALL=C \ $(top_builddir)/pre-inst-env $(GUILD) compile \ - --load-path="$(top_builddir)/scm" \ - --load-path="$(top_srcdir)/scm" \ + --load-path="$(top_builddir)/src" \ + --load-path="$(top_srcdir)/src" \ --warn=format --warn=unbound-variable --warn=arity-mismatch \ --target="$(host)" --output="$@" "$<" @@ -134,7 +134,7 @@ TEXI2DVI = texi2dvi -I doc # 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. -doc/mcron.1: mcron.c +doc/mcron.1: src/mcron.c -$(AM_V_HELP2MAN)$(MKDIR_P) `dirname "$@"` ; \ $(top_builddir)/pre-inst-env $(HELP2MAN) \ -n 'a program to run tasks at regular (or not) intervals' \ diff --git a/build-aux/pre-inst-env.in b/build-aux/pre-inst-env.in index 7e69b44..ea866ee 100644 --- a/build-aux/pre-inst-env.in +++ b/build-aux/pre-inst-env.in @@ -20,8 +20,8 @@ abs_top_srcdir="`cd "@abs_top_srcdir@" > /dev/null; pwd`" abs_top_builddir="`cd "@abs_top_builddir@" > /dev/null; pwd`" -GUILE_LOAD_COMPILED_PATH="$abs_top_builddir/scm${GUILE_LOAD_COMPILED_PATH:+:}$GUILE_LOAD_COMPILED_PATH" -GUILE_LOAD_PATH="$abs_top_builddir/scm:$abs_top_srcdir/scm${GUILE_LOAD_PATH:+:}:$GUILE_LOAD_PATH" +GUILE_LOAD_COMPILED_PATH="$abs_top_builddir/src${GUILE_LOAD_COMPILED_PATH:+:}$GUILE_LOAD_COMPILED_PATH" +GUILE_LOAD_PATH="$abs_top_builddir/src:$abs_top_srcdir/src${GUILE_LOAD_PATH:+:}:$GUILE_LOAD_PATH" export GUILE_LOAD_COMPILED_PATH GUILE_LOAD_PATH PATH="$abs_top_builddir:$PATH" diff --git a/configure.ac b/configure.ac index d6262f2..175ba16 100644 --- a/configure.ac +++ b/configure.ac @@ -23,7 +23,7 @@ AC_PREREQ(2.61) AC_INIT([GNU Mcron], [1.0.8], [bug-mcron@gnu.org]) -AC_CONFIG_HEADER([config.h]) +AC_CONFIG_HEADER([src/config.h]) AC_CONFIG_AUX_DIR([build-aux]) AM_INIT_AUTOMAKE([subdir-objects]) AM_SILENT_RULES([yes]) # enables silent rules by default @@ -187,5 +187,5 @@ AC_CONFIG_FILES([pre-inst-env:build-aux/pre-inst-env.in], [chmod +x pre-inst-env]) AC_CONFIG_FILES([doc/config.texi Makefile - scm/mcron/config.scm]) + src/mcron/config.scm]) AC_OUTPUT diff --git a/mcron.c b/mcron.c deleted file mode 100644 index 92e1a37..0000000 --- a/mcron.c +++ /dev/null @@ -1,87 +0,0 @@ -/* mcron - run jobs at scheduled times - - Copyright (C) 2015, 2016 Mathieu Lirzin - 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 . */ - -/* This C code represents a thin wrapper around the Guile code of Mcron. It - is needed because the crontab personality requires SUID which is not - permitted for executable scripts. */ - -#include "config.h" -#include -#include -#include -#include - -/* Forward declarations. */ -static void inner_main (void *closure, int argc, char **argv); -static void react_to_terminal_signal (int sig); -static SCM set_cron_signals (void); - -int -main (int argc, char **argv) -{ - scm_boot_guile (argc, argv, inner_main, 0); - - return EXIT_SUCCESS; -} - -/* Launch the Mcron Guile main program. */ -static void -inner_main (void *closure, int argc, char **argv) -{ - /* Set Guile load paths to ensure that Mcron modules will be found. */ - if (getenv ("MCRON_UNINSTALLED") == NULL) - { - scm_c_eval_string ("(set! %load-path (cons \"" - PACKAGE_LOAD_PATH "\" %load-path))"); - scm_c_eval_string ("(set! %load-compiled-path (cons \"" - PACKAGE_LOAD_PATH "\" %load-compiled-path))"); - } - scm_set_current_module (scm_c_resolve_module ("mcron main")); - /* Register set_cron_signals to be called from Guile. */ - scm_c_define_gsubr ("c-set-cron-signals", 0, 0, 0, set_cron_signals); - scm_c_eval_string ("(main)"); -} - -/* Set up all the signal handlers as required by the cron personality. This - is necessary to perform the signal processing in C because the sigaction - function won't work when called from Guile. */ -static SCM -set_cron_signals () -{ - static struct sigaction sa; - - memset (&sa, 0, sizeof (sa)); - sa.sa_handler = react_to_terminal_signal; - sigaction (SIGTERM, &sa, 0); - sigaction (SIGINT, &sa, 0); - sigaction (SIGQUIT, &sa, 0); - sigaction (SIGHUP, &sa, 0); - - return SCM_BOOL_T; -} - -/* Handle signal SIG and exit. All signals that mcron handles will produce - the same behavior so we don't need to use SIG in the implementation. */ -static void -react_to_terminal_signal (int sig) -{ - scm_c_eval_string ("(delete-run-file)"); - exit (EXIT_FAILURE); -} diff --git a/scm/mcron/config.scm.in b/scm/mcron/config.scm.in deleted file mode 100644 index db2bc32..0000000 --- a/scm/mcron/config.scm.in +++ /dev/null @@ -1,39 +0,0 @@ -;; -*-scheme-*- - -;; Copyright (C) 2015 Mathieu Lirzin -;; Copyright (C) 2003 Dale Mellor -;; -;; This file is part of GNU mcron. -;; -;; GNU mcron is free software: you can redistribute it and/or modify it under -;; the terms of the GNU General Public License as published by the Free -;; Software Foundation, either version 3 of the License, or (at your option) -;; any later version. -;; -;; GNU mcron is distributed in the hope that it will be useful, but WITHOUT -;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for -;; more details. -;; -;; You should have received a copy of the GNU General Public License along -;; with GNU mcron. If not, see . - - -;; Some constants set by the configuration process. - -(define-module (mcron config)) - -(define-public config-debug @CONFIG_DEBUG@) -(define-public config-package-name "@PACKAGE_NAME@") -(define-public config-package-version "@PACKAGE_VERSION@") -(define-public config-package-string "@PACKAGE_STRING@") -(define-public config-package-bugreport "@PACKAGE_BUGREPORT@") -(define-public config-package-url "@PACKAGE_URL@") -(define-public config-sendmail "@SENDMAIL@") - -(define-public config-spool-dir "@CONFIG_SPOOL_DIR@") -(define-public config-socket-file "@CONFIG_SOCKET_FILE@") -(define-public config-allow-file "@CONFIG_ALLOW_FILE@") -(define-public config-deny-file "@CONFIG_DENY_FILE@") -(define-public config-pid-file "@CONFIG_PID_FILE@") -(define-public config-tmp-dir "@CONFIG_TMP_DIR@") diff --git a/scm/mcron/crontab.scm b/scm/mcron/crontab.scm deleted file mode 100644 index 6be5c61..0000000 --- a/scm/mcron/crontab.scm +++ /dev/null @@ -1,228 +0,0 @@ -;; Copyright (C) 2003, 2014 Dale Mellor -;; -;; This file is part of GNU mcron. -;; -;; GNU mcron is free software: you can redistribute it and/or modify it under -;; the terms of the GNU General Public License as published by the Free -;; Software Foundation, either version 3 of the License, or (at your option) -;; any later version. -;; -;; GNU mcron is distributed in the hope that it will be useful, but WITHOUT -;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for -;; more details. -;; -;; You should have received a copy of the GNU General Public License along -;; with GNU mcron. If not, see . - - -;; Apart from the collecting of options and the handling of --help and --version -;; (which are done in the main.scm file), this file provides all the -;; functionality of the crontab personality. It is designed to be loaded and run -;; once, and then the calling program can exit and the crontab program will have -;; completed its function. - - - -;; Procedure to communicate with running cron daemon that a user has modified -;; his crontab. The user name is written to the /var/cron/socket UNIX socket. - -(let ((hit-server - (lambda (user-name) - (catch #t (lambda () - (let ((socket (socket AF_UNIX SOCK_STREAM 0))) - (connect socket AF_UNIX config-socket-file) - (display user-name socket) - (close socket))) - (lambda (key . args) - (display "Warning: a cron daemon is not running.\n"))))) - - - -;; Procedure to scan a file containing one user name per line (such as -;; /var/cron/allow and /var/cron/deny), and determine if the given name is in -;; there. The procedure returns #t, #f, or '() if the file does not exist. - - (in-access-file? - (lambda (file name) - (catch #t (lambda () - (with-input-from-file - file - (lambda () - (let loop ((input (read-line))) - (if (eof-object? input) - #f - (if (string=? input name) - #t - (loop (read-line)))))))) - (lambda (key . args) '())))) - - - - ;; This program should have been installed SUID root. Here we get the - ;; passwd entry for the real user who is running this program. - - (crontab-real-user (passwd:name (getpw (getuid))))) - - - - ;; If the real user is not allowed to use crontab due to the /var/cron/allow - ;; and/or /var/cron/deny files, bomb out now. - - (if (or (eq? (in-access-file? config-allow-file crontab-real-user) #f) - (eq? (in-access-file? config-deny-file crontab-real-user) #t)) - (mcron-error 6 "Access denied by system operator.")) - - - - ;; Check that no more than one of the mutually exclusive options are being - ;; used. - - (if (> (+ (if (option-ref options 'edit #f) 1 0) - (if (option-ref options 'list #f) 1 0) - (if (option-ref options 'remove #f) 1 0)) - 1) - (mcron-error 7 "Only one of options -e, -l or -r can be used.")) - - - - ;; Check that a non-root user is trying to read someone else's files. - - (if (and (not (eqv? (getuid) 0)) - (option-ref options 'user #f)) - (mcron-error 8 "Only root can use the -u option.")) - - - - (let ( - - - ;; Iff the --user option is given, the crontab-user may be different - ;; from the real user. - - (crontab-user (option-ref options 'user crontab-real-user)) - - - ;; So now we know which crontab file we will be manipulating. - - (crontab-file (string-append config-spool-dir "/" crontab-user)) - - - - ;; Display the prompt and wait for user to type his choice. Return #t if - ;; the answer begins with 'y' or 'Y', return #f if it begins with 'n' or - ;; 'N', otherwise ask again. - - (get-yes-no (lambda (prompt . re-prompt) - (if (not (null? re-prompt)) - (display "Please answer y or n.\n")) - (display (string-append prompt " ")) - (let ((r (read-line))) - (if (not (string-null? r)) - (case (string-ref r 0) - ((#\y #\Y) #t) - ((#\n #\N) #f) - (else (get-yes-no prompt #t))) - (get-yes-no prompt #t)))))) - - - - ;; There are four possible sub-personalities to the crontab personality: - ;; list, remove, edit and replace (when the user uses no options but - ;; supplies file names on the command line). - - (cond - - - ;; In the list personality, we simply open the crontab and copy it - ;; character-by-character to the standard output. If anything goes wrong, it - ;; can only mean that this user does not have a crontab file. - - ((option-ref options 'list #f) - (catch #t (lambda () - (with-input-from-file crontab-file (lambda () - (do ((input (read-char) (read-char))) - ((eof-object? input)) - (display input))))) - (lambda (key . args) - (display (string-append "No crontab for " - crontab-user - " exists.\n"))))) - - - ;; In the edit personality, we determine the name of a temporary file and an - ;; editor command, copy an existing crontab file (if it is there) to the - ;; temporary file, making sure the ownership is set so the real user can edit - ;; it; once the editor returns we try to read the file to check that it is - ;; parseable (but do nothing more with the configuration), and if it is okay - ;; (this program is still running!) we move the temporary file to the real - ;; crontab, wake the cron daemon up, and remove the temporary file. If the - ;; parse fails, we give user a choice of editing the file again or quitting - ;; the program and losing all changes made. - - ((option-ref options 'edit #f) - (let ((temp-file (string-append config-tmp-dir - "/crontab." - (number->string (getpid))))) - (catch #t (lambda () (copy-file crontab-file temp-file)) - (lambda (key . args) (with-output-to-file temp-file noop))) - (chown temp-file (getuid) (getgid)) - (let retry () - (system (string-append - (or (getenv "VISUAL") (getenv "EDITOR") "vi") - " " - temp-file)) - (catch 'mcron-error - (lambda () (read-vixie-file temp-file)) - (lambda (key exit-code . msg) - (apply mcron-error 0 msg) - (if (get-yes-no "Edit again?") - (retry) - (begin - (mcron-error 0 "Crontab not changed") - (primitive-exit 0)))))) - (copy-file temp-file crontab-file) - (delete-file temp-file) - (hit-server crontab-user))) - - - ;; In the remove personality we simply make an effort to delete the crontab and - ;; wake the daemon. No worries if this fails. - - ((option-ref options 'remove #f) - (catch #t (lambda () (delete-file crontab-file) - (hit-server crontab-user)) - noop)) - - - ;; !!!! This comment is wrong. - - ;; In the case of the replace personality we loop over all the arguments on the - ;; command line, and for each one parse the file to make sure it is parseable - ;; (but subsequently ignore the configuration), and all being well we copy it - ;; to the crontab location; we deal with the standard input in the same way but - ;; different. :-) In either case the server is woken so that it will read the - ;; newly installed crontab. - - ((not (null? (option-ref options '() '()))) - (let ((input-file (car (option-ref options '() '())))) - (catch-mcron-error - (if (string=? input-file "-") - (let ((input-string (stdin->string))) - (read-vixie-port (open-input-string input-string)) - (with-output-to-file crontab-file (lambda () - (display input-string)))) - (begin - (read-vixie-file input-file) - (copy-file input-file crontab-file)))) - (hit-server crontab-user))) - - - ;; The user is being silly. The message here is identical to the one Vixie cron - ;; used to put out, for total compatibility. - - (else (mcron-error 15 - "usage error: file name must be specified for replace."))) - - -)) ;; End of file-level let-scopes. diff --git a/scm/mcron/environment.scm b/scm/mcron/environment.scm deleted file mode 100644 index b563d55..0000000 --- a/scm/mcron/environment.scm +++ /dev/null @@ -1,97 +0,0 @@ -;; Copyright (C) 2015, 2016 Mathieu Lirzin -;; Copyright (C) 2003 Dale Mellor -;; -;; This file is part of GNU mcron. -;; -;; GNU mcron is free software: you can redistribute it and/or modify it under -;; the terms of the GNU General Public License as published by the Free -;; Software Foundation, either version 3 of the License, or (at your option) -;; any later version. -;; -;; GNU mcron is distributed in the hope that it will be useful, but WITHOUT -;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for -;; more details. -;; -;; You should have received a copy of the GNU General Public License along -;; with GNU mcron. If not, see . - - - -;; This file defines the variable current-environment-mods, and the procedures -;; append-environment-mods (which is available to user configuration files), -;; clear-environment-mods and modify-environment. The idea is that the -;; current-environment-mods is a list of pairs of environment names and values, -;; and represents the cumulated environment settings in a configuration -;; file. When a job definition is seen in a configuration file, the -;; current-environment-mods are copied into the internal job description, and -;; when the job actually runs these environment modifications are applied to -;; the UNIX environment in which the job runs. - - - - -(define-module (mcron environment) - #:export (modify-environment - clear-environment-mods - append-environment-mods - get-current-environment-mods-copy)) - - - -;; As we parse configuration files, we build up an alist of environment -;; variables here. - -(define current-environment-mods '()) - - - -;; Each time a job is added to the system, we take a snapshot of the current -;; set of environment modifiers. - -(define (get-current-environment-mods-copy) - (list-copy current-environment-mods)) - - - -;; When we start to parse a new configuration file, we want to start with a -;; fresh environment (actually an umodified version of the pervading mcron -;; environment). - -(define (clear-environment-mods) - (set! current-environment-mods '())) - - - -;; Procedure to add another environment setting to the alist above. This is -;; used both implicitly by the Vixie parser, and can be used directly by users -;; in scheme configuration files. The return value is purely for the -;; convenience of the parse-vixie-environment in the vixie-specification module -;; (yuk). - -(define (append-environment-mods name value) - (set! current-environment-mods (append current-environment-mods - (list (cons name value)))) - #t) - -(define (modify-environment env passwd-entry) - "Modify the environment (in the UNIX sense) by setting the variables from -ENV and some default ones which are modulated by PASSWD-ENTRY. \"LOGNAME\" -and \"USER\" environment variables can't be overided by ENV. ENV must be an -alist which associate environment variables to their value. PASSWD-ENTRY must -be an object representing user information which corresponds to a valid entry -in /etc/passwd. The return value is not specified." - (for-each (lambda (pair) (setenv (car pair) (cdr pair))) - (let ((home-dir (passwd:dir passwd-entry)) - (user-name (passwd:name passwd-entry))) - (append - ;; Default environment variables which can be overided by ENV. - `(("HOME" . ,home-dir) - ("CWD" . ,home-dir) - ("SHELL" . ,(passwd:shell passwd-entry)) - ("TERM" . #f) - ("TERMCAP" . #f)) - env - ;; Environment variables with imposed values. - `(("LOGNAME" . ,user-name) - ("USER" . ,user-name)))))) diff --git a/scm/mcron/job-specifier.scm b/scm/mcron/job-specifier.scm deleted file mode 100644 index 1c2f9d9..0000000 --- a/scm/mcron/job-specifier.scm +++ /dev/null @@ -1,253 +0,0 @@ -;; Copyright (C) 2003 Dale Mellor -;; Copyright (C) 2016 Mathieu Lirzin -;; -;; This file is part of GNU mcron. -;; -;; GNU mcron is free software: you can redistribute it and/or modify it under -;; the terms of the GNU General Public License as published by the Free -;; Software Foundation, either version 3 of the License, or (at your option) -;; any later version. -;; -;; GNU mcron is distributed in the hope that it will be useful, but WITHOUT -;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for -;; more details. -;; -;; You should have received a copy of the GNU General Public License along -;; with GNU mcron. If not, see . - - - -;; This module defines all the functions that can be used by scheme mcron -;; configuration files, namely the procedures for working out next times, the -;; job procedure for registering new jobs (actually a wrapper around the core -;; add-job function), and the procedure for declaring environment modifications. - -(define-module (mcron job-specifier) - #:use-module (ice-9 match) - #:use-module (mcron core) - #:use-module (mcron environment) - #:use-module (mcron vixie-time) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-26) - #:re-export (append-environment-mods) - #:export (range - next-year-from next-year - next-month-from next-month - next-day-from next-day - next-hour-from next-hour - next-minute-from next-minute - next-second-from next-second - set-configuration-user - set-configuration-time - job)) - -(define* (range start end #:optional (step 1)) - "Produces a list of values from START up to (but not including) END. An -optional STEP may be supplied, and (if positive) only every step'th value will -go into the list. For example, (range 1 6 2) returns '(1 3 5)." - (unfold (cut >= <> end) identity (cute + <> (max step 1)) start)) - -(define (%find-best-next current next-list) - ;; Takes a value and a list of possible next values (all assumed less than - ;; 9999). It returns a pair consisting of the smallest element of the - ;; NEXT-LIST, and the smallest element larger than the CURRENT value. If an - ;; example of the latter cannot be found, 9999 will be returned. - (let loop ((smallest 9999) (closest+ 9999) (lst next-list)) - (match lst - (() (cons smallest closest+)) - ((time . rest) - (loop (min time smallest) - (if (> time current) (min time closest+) closest+) - rest))))) - -;; Internal function to return the time corresponding to some near future -;; hour. If hour-list is not supplied, the time returned corresponds to the -;; start of the next hour of the day. -;; -;; If the hour-list is supplied the time returned corresponds to the first hour -;; of the day in the future which is contained in the list. If all the values in -;; the list are less than the current hour, then the time returned will -;; correspond to the first hour in the list *on the following day*. -;; -;; ... except that the function is actually generalized to deal with seconds, -;; minutes, etc., in an obvious way :-) -;; -;; Note that value-list always comes from an optional argument to a procedure, -;; so is wrapped up as the first element of a list (i.e. it is a list inside a -;; list). - -(define (bump-time time value-list component higher-component - set-component! set-higher-component!) - (if (null? value-list) - (set-component! time (+ (component time) 1)) - (let ((best-next (%find-best-next (component time) (car value-list)))) - (if (eqv? 9999 (cdr best-next)) - (begin - (set-higher-component! time (+ (higher-component time) 1)) - (set-component! time (car best-next))) - (set-component! time (cdr best-next))))) - (car (mktime time))) - - - - -;; Set of configuration methods which use the above general function to bump -;; specific components of time to the next legitimate value. In each case, all -;; the components smaller than that of interest are taken to zero, so that for -;; example the time of the next year will be the time at which the next year -;; actually starts. - -(define (next-year-from current-time . year-list) - (let ((time (localtime current-time))) - (set-tm:mon time 0) - (set-tm:mday time 1) - (set-tm:hour time 0) - (set-tm:min time 0) - (set-tm:sec time 0) - (bump-time time year-list tm:year tm:year set-tm:year set-tm:year))) - -(define (next-month-from current-time . month-list) - (let ((time (localtime current-time))) - (set-tm:mday time 1) - (set-tm:hour time 0) - (set-tm:min time 0) - (set-tm:sec time 0) - (bump-time time month-list tm:mon tm:year set-tm:mon set-tm:year))) - -(define (next-day-from current-time . day-list) - (let ((time (localtime current-time))) - (set-tm:hour time 0) - (set-tm:min time 0) - (set-tm:sec time 0) - (bump-time time day-list tm:mday tm:mon set-tm:mday set-tm:mon))) - -(define (next-hour-from current-time . hour-list) - (let ((time (localtime current-time))) - (set-tm:min time 0) - (set-tm:sec time 0) - (bump-time time hour-list tm:hour tm:mday set-tm:hour set-tm:mday))) - -(define (next-minute-from current-time . minute-list) - (let ((time (localtime current-time))) - (set-tm:sec time 0) - (bump-time time minute-list tm:min tm:hour set-tm:min set-tm:hour))) - -(define (next-second-from current-time . second-list) - (let ((time (localtime current-time))) - (bump-time time second-list tm:sec tm:min set-tm:sec set-tm:min))) - - - -;; The current-action-time is the time a job was last run, the time from which -;; the next time to run a job must be computed. (When the program is first run, -;; this time is set to the configuration time so that jobs run from that moment -;; forwards.) Once we have this, we supply versions of the time computation -;; commands above which implicitly assume this value. - -(define current-action-time 0) - - - -;; We want to provide functions which take a single optional argument (as well -;; as implicitly the current action time), but unlike usual scheme behaviour if -;; the argument is missing we want to act like it is really missing, and if it -;; is there we want to act like it is a genuine argument, not a list of -;; optionals. - -(define (maybe-args function args) - (if (null? args) - (function current-action-time) - (function current-action-time (car args)))) - - - -;; These are the convenience functions we were striving to define for the -;; configuration files. They are wrappers for the next-X-from functions above, -;; but implicitly use the current-action-time for the time argument. - -(define (next-year . args) (maybe-args next-year-from args)) -(define (next-month . args) (maybe-args next-month-from args)) -(define (next-day . args) (maybe-args next-day-from args)) -(define (next-hour . args) (maybe-args next-hour-from args)) -(define (next-minute . args) (maybe-args next-minute-from args)) -(define (next-second . args) (maybe-args next-second-from args)) - - - -;; The default user for running jobs is the current one (who invoked this -;; program). There are exceptions: when cron parses /etc/crontab the user is -;; specified on each individual line; when cron parses /var/cron/tabs/* the user -;; is derived from the filename of the crontab. These cases are dealt with by -;; mutating this variable. Note that the variable is only used at configuration -;; time; a UID is stored with each job and it is that which takes effect when -;; the job actually runs. - -(define configuration-user (getpw (getuid))) -(define configuration-time (current-time)) - -(define (set-configuration-user user) - (set! configuration-user (if (or (string? user) - (integer? user)) - (getpw user) - user))) -(define (set-configuration-time time) (set! configuration-time time)) - - - -;; The job function, available to configuration files for adding a job rule to -;; the system. -;; -;; Here we must 'normalize' the next-time-function so that it is always a lambda -;; function which takes one argument (the last time the job ran) and returns a -;; single value (the next time the job should run). If the input value is a -;; string this is parsed as a Vixie-style time specification, and if it is a -;; list then we arrange to eval it (but note that such lists are expected to -;; ignore the function parameter - the last run time is always read from the -;; current-action-time global variable). A similar normalization is applied to -;; the action. -;; -;; Here we also compute the first time that the job is supposed to run, by -;; finding the next legitimate time from the current configuration time (set -;; right at the top of this program). - -(define (job time-proc action . displayable) - (let ((action (cond ((procedure? action) action) - ((list? action) (lambda () (primitive-eval action))) - ((string? action) (lambda () (system action))) - (else - (throw 'mcron-error 2 - "job: invalid second argument (action; should be lambda " - "function, string or list)")))) - - (time-proc - (cond ((procedure? time-proc) time-proc) - ((string? time-proc) (parse-vixie-time time-proc)) - ((list? time-proc) (lambda (current-time) - (primitive-eval time-proc))) - (else - (throw 'mcron-error 3 - "job: invalid first argument (next-time-function; " - "should be function, string or list)")))) - (displayable - (cond ((not (null? displayable)) (car displayable)) - ((procedure? action) "Lambda function") - ((string? action) action) - ((list? action) (with-output-to-string - (lambda () (display action))))))) - (add-job (lambda (current-time) - (set! current-action-time current-time) ;; ?? !!!! Code - - ;; Contributed by Sergey Poznyakoff to allow for daylight savings - ;; time changes. - (let* ((next (time-proc current-time)) - (gmtoff (tm:gmtoff (localtime next))) - (d (+ next (- gmtoff - (tm:gmtoff (localtime current-time)))))) - (if (eqv? (tm:gmtoff (localtime d)) gmtoff) - d - next))) - action - displayable - configuration-time - configuration-user))) diff --git a/scm/mcron/main.scm b/scm/mcron/main.scm deleted file mode 100644 index 1f2b068..0000000 --- a/scm/mcron/main.scm +++ /dev/null @@ -1,401 +0,0 @@ -;; Copyright (C) 2015, 2016 Mathieu Lirzin -;; Copyright (C) 2003, 2012 Dale Mellor -;; -;; This file is part of GNU mcron. -;; -;; GNU mcron is free software: you can redistribute it and/or modify it under -;; the terms of the GNU General Public License as published by the Free -;; Software Foundation, either version 3 of the License, or (at your option) -;; any later version. -;; -;; GNU mcron is distributed in the hope that it will be useful, but WITHOUT -;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for -;; more details. -;; -;; You should have received a copy of the GNU General Public License along -;; with GNU mcron. If not, see . - -;;; This is the 'main' routine for the whole system; this module is the global -;;; entry point (after the minimal C wrapper); to all intents and purposes the -;;; program is pure Guile and starts here. - -(define-module (mcron main) - #:use-module (ice-9 getopt-long) - #:use-module (ice-9 rdelim) - #:use-module (ice-9 regex) - #:use-module (mcron config) - #:use-module (mcron core) - #:use-module (mcron job-specifier) - #:use-module (mcron vixie-specification) - #:use-module (srfi srfi-2) - #:use-module (srfi srfi-26) - #:export (delete-run-file - main)) - -(define* (command-name #:optional (command (car (command-line)))) - "Extract the actual command name from COMMAND. This returns the last part -of COMMAND without any non-alphabetic characters. For example \"in.cron\" and -\"./mcron\" will return respectively \"cron\" and \"mcron\". - -When COMMAND is not specified this uses the first element of (command-line)." - (match:substring (regexp-exec (make-regexp "[[:alpha:]]*$") command))) - -(define (mcron-error exit-code . rest) - "Print an error message (made up from the parts of REST), and if the -EXIT-CODE error is fatal (present and non-zero) then exit to the system with -EXIT-CODE." - (with-output-to-port (current-error-port) - (lambda () - (for-each display (append (list (command-name) ": ") rest)) - (newline))) - (when (and exit-code (not (eq? exit-code 0))) - (primitive-exit exit-code))) - -(define-syntax-rule (catch-mcron-error exp ...) - "Evaluate EXP .... if an 'mcron-error exception occurs, print its diagnostics -and exit with its error code." - (catch 'mcron-error - (lambda () exp ...) - (lambda (key exit-code . msg) - (apply mcron-error exit-code msg)))) - -(define command-type - ;; We will be doing a lot of testing of the command name, so it makes sense - ;; to perform the string comparisons once and for all here. - (let* ((command (command-name)) - (command=? (cut string=? command <>))) - (cond ((command=? "mcron") 'mcron) - ((or (command=? "cron") (command=? "crond")) 'cron) - ((command=? "crontab") 'crontab) - (else (mcron-error 12 "The command name is invalid."))))) - -(define options - ;; There are a different set of options for the crontab personality compared - ;; to all the others, with the --help and --version options common to all - ;; the personalities. - (catch - 'misc-error - (lambda () - (getopt-long (command-line) - (append - (case command-type - ((crontab) - '((user (single-char #\u) (value #t)) - (edit (single-char #\e) (value #f)) - (list (single-char #\l) (value #f)) - (remove (single-char #\r) (value #f)))) - (else `((schedule (single-char #\s) (value #t) - (predicate - ,(lambda (value) - (string->number value)))) - (daemon (single-char #\d) (value #f)) - (noetc (single-char #\n) (value #f)) - (stdin (single-char #\i) (value #t) - (predicate - ,(lambda (value) - (or (string=? "vixie" value) - (string=? "guile" value)))))))) - '((version (single-char #\v) (value #f)) - (help (single-char #\h) (value #f)))))) - (lambda (key func fmt args . rest) - (mcron-error 1 (apply format (append (list #f fmt) args)))))) - -(define* (show-version #:optional (command (command-name))) - "Display version information for COMMAND and quit." - (let* ((name config-package-name) - (short-name (cadr (string-split name #\space))) - (version config-package-version)) - (simple-format #t "~a (~a) ~a -Copyright (C) 2015 the ~a authors. -License GPLv3+: GNU GPL version 3 or later -This is free software: you are free to change and redistribute it. -There is NO WARRANTY, to the extent permitted by law.\n" - command name version short-name) - (quit))) - -(define (show-package-information) - "Display where to get help and send bug reports." - (simple-format #t "\nReport bugs to: ~a. -~a home page: <~a> -General help using GNU software: \n" - config-package-bugreport - config-package-name - config-package-url)) - -(define* (show-help #:optional (command (command-name))) - "Display informations of usage for COMMAND and quit." - (simple-format #t "Usage: ~a" command) - (display - (case command-type - ((mcron) - " [OPTIONS] [FILES] -Run an mcron process according to the specifications in the FILES (`-' for -standard input), or use all the files in ~/.config/cron (or the -deprecated ~/.cron) with .guile or .vixie extensions. - - -v, --version Display version - -h, --help Display this help message - -sN, --schedule[=]N Display the next N jobs that will be run by mcron - -d, --daemon Immediately detach the program from the terminal - and run as a daemon process - -i, --stdin=(guile|vixie) Format of data passed as standard input or - file arguments (default guile)") - ((cron) - " [OPTIONS] -Unless an option is specified, run a cron daemon as a detached process, -reading all the information in the users' crontabs and in /etc/crontab. - - -v, --version Display version - -h, --help Display this help message - -sN, --schedule[=]N Display the next N jobs that will be run by cron - -n, --noetc Do not check /etc/crontab for updates (HIGHLY - RECOMMENDED).") - ((crontab) - " [-u user] file - crontab [-u user] { -e | -l | -r } - (default operation is replace, per 1003.2) - -e (edit user's crontab) - -l (list user's crontab) - -r (delete user's crontab") - (else "\nrubbish"))) - (newline) - (show-package-information) - (quit)) - -(define (delete-run-file) - "Remove the /var/run/cron.pid file so that crontab and other invocations of -cron don't get the wrong idea that a daemon is currently running. This -procedure is called from the C front-end whenever a terminal signal is -received." - (catch #t (lambda () (delete-file config-pid-file) - (delete-file config-socket-file)) - noop) - (quit)) - -(define (stdin->string) - "Return standard input as a string." - (with-output-to-string (lambda () (do ((in (read-char) (read-char))) - ((eof-object? in)) - (display in))))) - -(define (for-each-file proc directory) - "Apply PROC to each file in DIRECTORY. DIRECTORY must be a valid directory name. -PROC must be a procedure that take one file name argument. The return value -is not specified" - (let ((dir (opendir directory))) - (do ((file-name (readdir dir) (readdir dir))) - ((eof-object? file-name) (closedir dir)) - (proc file-name)))) - -(define process-user-file - (let ((guile-regexp (make-regexp "\\.gui(le)?$")) - (vixie-regexp (make-regexp "\\.vix(ie)?$"))) - (lambda* (file-name #:optional guile-syntax?) - "Process FILE-NAME according its extension. When GUILE-SYNTAX? is TRUE, -force guile syntax usage. If FILE-NAME format is not recognized, it is -silently ignored." - (cond ((string=? "-" file-name) - (if (string=? (option-ref options 'stdin "guile") "vixie") - (read-vixie-port (current-input-port)) - (eval-string (stdin->string)))) - ((or guile-syntax? (regexp-exec guile-regexp file-name)) - (load file-name)) - ((regexp-exec vixie-regexp file-name) - (read-vixie-file file-name)))))) - -(define (process-files-in-user-directory) - "Process files in $XDG_CONFIG_HOME/cron and/or ~/.cron directories (if -$XDG_CONFIG_HOME is not defined uses ~/.config/cron instead)." - (let ((errors 0) - (home-directory (passwd:dir (getpw (getuid))))) - (map (lambda (dir) - (catch #t - (lambda () - (for-each-file - (lambda (file) - (process-user-file (string-append dir "/" file))) - dir)) - (lambda (key . args) - (set! errors (1+ errors))))) - (list (string-append home-directory "/.cron") - (string-append (or (getenv "XDG_CONFIG_HOME") - (string-append home-directory "/.config")) - "/cron"))) - (when (eq? 2 errors) - (mcron-error 13 - "Cannot read files in your ~/.config/cron (or ~/.cron) directory.")))) - -(define (process-files-in-system-directory) - "Process all the files in the crontab directory. When the job procedure is -run on behalf of the configuration files, the jobs are registered on the -system with the appropriate user. Only root should be able to perform this -operation. The permissions on the /var/cron/tabs directory enforce this." - - (define (user-entry name) - ;; Return the user database entry if NAME is valid, otherwise #f. - (false-if-exception (getpwnam name))) - - (catch #t - (lambda () - (for-each-file - (lambda (user) - (and-let* ((entry (user-entry user))) ;crontab without user? - (set-configuration-user entry) - (catch-mcron-error - (read-vixie-file (string-append config-spool-dir "/" user))))) - config-spool-dir)) - (lambda (key . args) - (mcron-error 4 - "You do not have permission to access the system crontabs.")))) - -(define (cron-file-descriptors) - "Establish a socket to listen for updates from a crontab program, and return -a list containing the file descriptors correponding to the files read by -crontab. This requires that command-type is 'cron." - (if (eq? command-type 'cron) - (catch #t - (lambda () - (let ((sock (socket AF_UNIX SOCK_STREAM 0))) - (bind sock AF_UNIX config-socket-file) - (listen sock 5) - (list sock))) - (lambda (key . args) - (delete-file config-pid-file) - (mcron-error 1 "Cannot bind to UNIX socket " config-socket-file))) - '())) - -(define (process-update-request fdes-list) - "Read a user name from the socket, dealing with the /etc/crontab special -case, remove all the user's jobs from the job list, and then re-read the -user's updated file. In the special case drop all the system jobs and re-read -the /etc/crontab file. This function should be called whenever a message -comes in on the above socket." - (let* ((sock (car (accept (car fdes-list)))) - (user-name (read-line sock))) - (close sock) - (set-configuration-time (current-time)) - (catch-mcron-error - (if (string=? user-name "/etc/crontab") - (begin - (clear-system-jobs) - (use-system-job-list) - (read-vixie-file "/etc/crontab" parse-system-vixie-line) - (use-user-job-list)) - (let ((user (getpw user-name))) - (remove-user-jobs user) - (set-configuration-user user) - (read-vixie-file (string-append config-spool-dir "/" user-name))))))) - - -;;; -;;; Entry point. -;;; - -(define (main . args) - ;; Turn debugging on if indicated. - (when config-debug - (debug-enable 'backtrace)) - (when (option-ref options 'version #f) - (show-version)) - (when (option-ref options 'help #f) - (show-help)) - - ;; Setup the cron process, if appropriate. If there is already a - ;; /var/run/cron.pid file, then we must assume a cron daemon is already - ;; running and refuse to start another one. - ;; - ;; Otherwise, clear the MAILTO environment variable so that output from cron - ;; jobs is sent to the various users (this may still be overridden in the - ;; configuration files), and call the function in the C wrapper to set up - ;; terminal signal responses to vector to the procedure above. The PID file - ;; will be filled in properly later when we have forked our daemon process - ;; (but not done if we are only viewing the schedules). - (when (eq? command-type 'cron) - (unless (eqv? (getuid) 0) - (mcron-error 16 - "This program must be run by the root user (and should have been " - "installed as such).")) - (when (access? config-pid-file F_OK) - (mcron-error 1 - "A cron daemon is already running.\n (If you are sure this is not" - " true, remove the file\n " config-pid-file ".)")) - (unless (option-ref options 'schedule #f) - (with-output-to-file config-pid-file noop)) - (setenv "MAILTO" #f) - ;; XXX: At compile time, this yields a "possibly unbound variable" - ;; warning, but this is OK since it is bound in the C wrapper. - (c-set-cron-signals)) - - ;; Now we have the procedures in place for dealing with the contents of - ;; configuration files, the crontab personality is able to validate such - ;; files. If the user requested the crontab personality, we load and run the - ;; code here and then get out. - (when (eq? command-type 'crontab) - (load "crontab.scm") - (quit)) - - ;; Having defined all the necessary procedures for scanning various sets of - ;; files, we perform the actual configuration of the program depending on - ;; the personality we are running as. If it is mcron, we either scan the - ;; files passed on the command line, or else all the ones in the user's - ;; .config/cron (or .cron) directory. If we are running under the cron - ;; personality, we read the /var/cron/tabs directory and also the - ;; /etc/crontab file. - (case command-type - ((mcron) - (if (null? (option-ref options '() '())) - (process-files-in-user-directory) - (for-each (lambda (file-path) (process-user-file file-path #t)) - (option-ref options '() '())))) - ((cron) - (process-files-in-system-directory) - (use-system-job-list) - (catch-mcron-error (read-vixie-file "/etc/crontab" - parse-system-vixie-line)) - (use-user-job-list) - (unless (option-ref options 'noetc #f) - (display "\ -WARNING: cron will check for updates to /etc/crontab EVERY MINUTE. If you do -not use this file, or you are prepared to manually restart cron whenever you -make a change, then it is HIGHLY RECOMMENDED that you use the --noetc -option.\n") - (set-configuration-user "root") - (job '(- (next-minute-from (next-minute)) 6) - check-system-crontab - "/etc/crontab update checker.")))) - - ;; If the user has requested a schedule of jobs that will run, we provide - ;; the information here and then get out. Start by determining the number - ;; of time points in the future that output is required for. This may be - ;; provided on the command line as a parameter to the --schedule option, or - ;; else we assume a default of 8. Finally, ensure that the count is some - ;; positive integer. - (and-let* ((count (option-ref options 'schedule #f))) - (set! count (string->number count)) - (display (get-schedule (if (<= count 0) 1 count))) - (quit)) - - ;; If we are supposed to run as a daemon process (either a --daemon option - ;; has been explicitly used, or we are running as cron or crond), detach - ;; from the terminal now. If we are running as cron, we can now write the - ;; PID file. - (when (option-ref options 'daemon (eq? command-type 'cron)) - (unless (eqv? (primitive-fork) 0) - (quit)) - (setsid) - (when (eq? command-type 'cron) - (with-output-to-file config-pid-file - (lambda () (display (getpid)) (newline))))) - - ;; Now the main loop. Forever execute the run-job-loop procedure in the - ;; mcron core, and when it drops out (can only be because a message has come - ;; in on the socket) we process the socket request before restarting the - ;; loop again. Sergey Poznyakoff: we can also drop out of run-job-loop - ;; because of a SIGCHLD, so must test FDES-LIST. - (catch-mcron-error - (let ((fdes-list (cron-file-descriptors))) - (while #t - (run-job-loop fdes-list) - (unless (null? fdes-list) - (process-update-request fdes-list)))))) diff --git a/scm/mcron/mcron-core.scm b/scm/mcron/mcron-core.scm deleted file mode 100644 index 13781c9..0000000 --- a/scm/mcron/mcron-core.scm +++ /dev/null @@ -1,270 +0,0 @@ -;; Copyright (C) 2015, 2016 Mathieu Lirzin -;; Copyright (C) 2003 Dale Mellor -;; -;; This file is part of GNU mcron. -;; -;; GNU mcron is free software: you can redistribute it and/or modify it under -;; the terms of the GNU General Public License as published by the Free -;; Software Foundation, either version 3 of the License, or (at your option) -;; any later version. -;; -;; GNU mcron is distributed in the hope that it will be useful, but WITHOUT -;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for -;; more details. -;; -;; You should have received a copy of the GNU General Public License along -;; with GNU mcron. If not, see . - - - -(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/scm/mcron/redirect.scm b/scm/mcron/redirect.scm deleted file mode 100644 index af763cb..0000000 --- a/scm/mcron/redirect.scm +++ /dev/null @@ -1,190 +0,0 @@ -;; Copyright (C) 2003 Dale Mellor -;; -;; This file is part of GNU mcron. -;; -;; GNU mcron is free software: you can redistribute it and/or modify it under -;; the terms of the GNU General Public License as published by the Free -;; Software Foundation, either version 3 of the License, or (at your option) -;; any later version. -;; -;; GNU mcron is distributed in the hope that it will be useful, but WITHOUT -;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for -;; more details. -;; -;; You should have received a copy of the GNU General Public License along -;; with GNU mcron. If not, see . - - - -;; This module provides the (with-mail-out action . user) procedure. This -;; procedure runs the action in a child process, allowing the user control over -;; the input and output (including standard error). The input is governed (only -;; in the case of a string action) by the placing of percentage signs in the -;; string; the first delimits the true action from the standard input, and -;; subsequent ones denote newlines to be placed into the input. The output (if -;; there actually is any) is controlled by the MAILTO environment variable. If -;; this is not defined, output is e-mailed to the user passed as argument, if -;; any, or else the owner of the action; if defined but empty then any output is -;; sunk to /dev/null; otherwise output is e-mailed to the address held in the -;; MAILTO variable. - -(define-module (mcron redirect) - #:export (with-mail-out) - #:use-module (ice-9 regex) - #:use-module ((mcron config) :select (config-sendmail)) - #:use-module (mcron vixie-time)) - - - -;; An action string consists of a sequence of characters forming a command -;; executable by the shell, possibly followed by an non-escaped percentage -;; sign. The text after the percentage sign is to be fed to the command's -;; standard input, with further unescaped percents being substituted with -;; newlines. The escape character can itself be escaped. -;; -;; This regexp separates the two halves of the string, and indeed determines if -;; the second part is present. - -(define action-string-regexp (make-regexp "((\\\\%|[^%])*)%(.*)$")) - - - -;; This regexp identifies an escaped percentage sign. - -(define e-percent (make-regexp "\\\\%")) - - -;; Function to execute some action (this may be a shell command, lamdba function -;; or list of scheme procedures) in a forked process, with the input coming from -;; the string, and output (including the error output) being sent to a pipe -;; opened on a mail transport. - -(use-modules (ice-9 popen)) - -(define (with-mail-out action . user) - - ;; Determine the name of the user who is to recieve the mail, looking for a - ;; name in the optional user argument, then in the MAILTO environment - ;; variable, and finally in the LOGNAME environment variable. (The case - ;; MAILTO="" is dealt with specially below.) - - (let* ((mailto (getenv "MAILTO")) - (user (cond (mailto mailto) - ((not (null? user)) (car user)) - (else (getenv "LOGNAME")))) - (parent->child (pipe)) - (child->parent (pipe)) - (child-pid (primitive-fork))) - - - ;; The child process. Close redundant ends of pipes, remap the standard - ;; streams, and run the action, taking care to chop off the input part of an - ;; action string. - - (if (eqv? child-pid 0) - (begin - (close (cdr parent->child)) - (close (car child->parent)) - - (dup2 (port->fdes (car parent->child)) 0) - (close (car parent->child)) - (dup2 (port->fdes (cdr child->parent)) 1) - (close (cdr child->parent)) - (dup2 1 2) - - (cond ((string? action) - (let ((match (regexp-exec action-string-regexp action))) - (system (if match - (let ((action (match:substring match 1))) - (do ((match (regexp-exec e-percent action) - (regexp-exec e-percent action))) - ((not match)) - (set! action (string-append - (match:prefix match) - "%" - (match:suffix match)))) - action) - action)))) - - ((procedure? action) (action)) - ((list? action) (primitive-eval action))) - - (primitive-exit 0))) - - - ;; The parent process. Get rid of redundant pipe ends. - - (close (car parent->child)) - (close (cdr child->parent)) - - - ;; Put stuff to child from after '%' in command line, replacing - ;; other %'s with newlines. Ugly or what? - - (if (string? action) - (let ((port (cdr parent->child)) - (match (regexp-exec action-string-regexp action))) - (if (and match - (match:substring match 3)) - (with-input-from-string (match:substring match 3) - (lambda () - (let loop () - (let ((next-char (read-char))) - (if (not (eof-object? next-char)) - (cond - ((char=? next-char #\%) - (newline port) - (loop)) - ((char=? next-char #\\) - (let ((escape (read-char))) - (if (eof-object? escape) - (display #\\ port) - (if (char=? escape #\%) - (begin - (display #\% port) - (loop)) - (begin - (display #\\ port) - (display escape port) - (loop)))))) - (else - (display next-char port) - (loop))))))))))) - - - ;; So the child process doesn't hang on to its input expecting more stuff. - - (close (cdr parent->child)) - - - ;; That's got streaming into the child's input out of the way, now we stream - ;; the child's output to a mail sink, but only if there is something there - ;; in the first place. - - (if (eof-object? (peek-char (car child->parent))) - - (read-char (car child->parent)) - - (begin - (set-current-output-port (if (and (string? mailto) - (string=? mailto "")) - (open-output-file "/dev/null") - (open-output-pipe - (string-append config-sendmail - " " - user)))) - (set-current-input-port (car child->parent)) - (display "To: ") (display user) (newline) - (display "From: mcron") (newline) - (display (string-append "Subject: " user "@" (gethostname))) - (newline) - (newline) - - (do ((next-char (read-char) (read-char))) - ((eof-object? next-char)) - (display next-char)))) - - (close (car child->parent)) - - (waitpid child-pid))) diff --git a/scm/mcron/vixie-specification.scm b/scm/mcron/vixie-specification.scm deleted file mode 100644 index 5cd1528..0000000 --- a/scm/mcron/vixie-specification.scm +++ /dev/null @@ -1,207 +0,0 @@ -;; Copyright (C) 2003 Dale Mellor -;; -;; This file is part of GNU mcron. -;; -;; GNU mcron is free software: you can redistribute it and/or modify it under -;; the terms of the GNU General Public License as published by the Free -;; Software Foundation, either version 3 of the License, or (at your option) -;; any later version. -;; -;; GNU mcron is distributed in the hope that it will be useful, but WITHOUT -;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for -;; more details. -;; -;; You should have received a copy of the GNU General Public License along -;; with GNU mcron. If not, see . - - - -;; This file provides methods for reading a complete Vixie-style configuration -;; file, either from a real file or an already opened port. It also exposes the -;; method for parsing the time-specification part of a Vixie string, so that -;; these can be used to form the next-time-function of a job in a Guile -;; configuration file. - -(define-module (mcron vixie-specification) - #:export (parse-user-vixie-line - parse-system-vixie-line - read-vixie-port - read-vixie-file - check-system-crontab) - #:use-module ((mcron config) :select (config-socket-file)) - #:use-module (mcron core) - #:use-module (mcron job-specifier) - #:use-module (mcron redirect) - #:use-module (mcron vixie-time)) - - -(use-modules (ice-9 regex) (ice-9 rdelim) - (srfi srfi-1) (srfi srfi-2) (srfi srfi-13) (srfi srfi-14)) - - - -;; A line in a Vixie-style crontab file which gives a command specification -;; carries two pieces of information: a time specification consisting of five -;; space-separated items, and a command which is also separated from the time -;; specification by a space. The line is broken into the two components, and the -;; job procedure run to add the two pieces of information to the job list (this -;; will in turn use the above function to turn the time specification into a -;; function for computing future run times of the command). - -(define parse-user-vixie-line-regexp - (make-regexp "^[[:space:]]*(([^[:space:]]+[[:space:]]+){5})(.*)$")) - -(define (parse-user-vixie-line line) - (let ((match (regexp-exec parse-user-vixie-line-regexp line))) - (if (not match) - (throw 'mcron-error 10 "Bad job line in Vixie file.")) - (job (match:substring match 1) - (lambda () (with-mail-out (match:substring match 3))) - (match:substring match 3)))) - - - -;; The case of reading a line from /etc/crontab is similar to above but the user -;; ID appears in the sixth field, before the action. - -(define parse-system-vixie-line-regexp - (make-regexp (string-append "^[[:space:]]*(([^[:space:]]+[[:space:]]+){5})" - "([[:alpha:]][[:alnum:]_]*)[[:space:]]+(.*)$"))) - -(define (parse-system-vixie-line line) - (let ((match (regexp-exec parse-system-vixie-line-regexp line))) - (if (not match) - (throw 'mcron-error 11 "Bad job line in /etc/crontab.")) - (let ((user (match:substring match 3))) - (set-configuration-user user) - (job (match:substring match 1) - (lambda () (with-mail-out (match:substring match 4) - user)) - (match:substring match 4))))) - - - -;; Procedure to act on an environment variable specification in a Vixie-style -;; configuration file, by adding an entry to the alist above. Returns #t if the -;; operation was successful, #f if the line could not be interpreted as an -;; environment specification. - -(define parse-vixie-environment-regexp1 - (make-regexp - "^[ \t]*([[:alpha:]_][[:alnum:]_]*)[ \t]*=[ \t]*\"(.*)\"[ \t]*$")) -(define parse-vixie-environment-regexp2 - (make-regexp - "^[ \t]*([[:alpha:]_][[:alnum:]_]*)[ \t]*=[ \t]*'(.*)'[ \t]*$")) -(define parse-vixie-environment-regexp3 - (make-regexp - "^[ \t]*([[:alpha:]_][[:alnum:]_]*)[ \t]*=[ \t]*(.*[^ \t])[ \t]*$")) -(define parse-vixie-environment-regexp4 - (make-regexp - "^[ \t]*([[:alpha:]_][[:alnum:]_]*)[ \t]*=[ \t]*$")) - - -(define (parse-vixie-environment string) - (let ((match (or (regexp-exec parse-vixie-environment-regexp1 string) - (regexp-exec parse-vixie-environment-regexp2 string) - (regexp-exec parse-vixie-environment-regexp3 string)))) - (if match - (append-environment-mods (match:substring match 1) - (match:substring match 2)) - (and-let* ((match (regexp-exec parse-vixie-environment-regexp4 string))) - (append-environment-mods (match:substring match 1) #f))))) - - - - -;; The next procedure reads an entire Vixie-style file. For each line in the -;; file there are three possibilities (after continuation lines have been -;; appended): the line is blank or contains only a comment, the line contains an -;; environment modifier which will be handled in the mcron environment module, -;; or the line contains a command specification in which case we use the -;; procedure above to add an entry to the internal job list. -;; -;; Note that the environment modifications are cleared, so that there is no -;; interference between crontab files (this might lead to unpredictable -;; behaviour because the order in which crontab files are processed, if there is -;; more than one, is generally undefined). - -(define read-vixie-file-comment-regexp - (make-regexp "^[[:space:]]*(#.*)?$")) - - -(define (read-vixie-port port . parse-vixie-line) - (clear-environment-mods) - (if port - (let ((parse-vixie-line - (if (null? parse-vixie-line) parse-user-vixie-line - (car parse-vixie-line)))) - (do ((line (read-line port) (read-line port)) - (line-number 1 (1+ line-number))) - ((eof-object? line)) - - (let ((report-line line-number)) - ;; If the line ends with \, append the next line. - (while (and (>= (string-length line) 1) - (char=? (string-ref line - (- (string-length line) 1)) - #\\)) - (let ((next-line (read-line port))) - (if (eof-object? next-line) - (set! next-line "")) - (set! line-number (1+ line-number)) - (set! line - (string-append - (substring line 0 (- (string-length line) 1)) - next-line)))) - - (catch 'mcron-error - (lambda () - ;; Consider the three cases mentioned in the description. - (or (regexp-exec read-vixie-file-comment-regexp line) - (parse-vixie-environment line) - (parse-vixie-line line))) - (lambda (key exit-code . msg) - (throw 'mcron-error exit-code - (apply string-append - (number->string report-line) - ": " - msg))))))))) - - - -;; If a file cannot be opened, we must silently ignore it because it may have -;; been removed by crontab. However, if the file is there it must be parseable, -;; otherwise the error must be propagated to the caller. - -(define (read-vixie-file file-path . parse-vixie-line) - (let ((port #f)) - (catch #t (lambda () (set! port (open-input-file file-path))) - (lambda (key . args) (set! port #f))) - (if port - (catch 'mcron-error - (lambda () - (if (null? parse-vixie-line) - (read-vixie-port port) - (read-vixie-port port (car parse-vixie-line))) - (close port)) - (lambda (key exit-code . msg) - (close port) - (throw 'mcron-error exit-code - (apply string-append file-path ":" msg))))))) - - -;; A procedure which determines if the /etc/crontab file has been recently -;; modified, and, if so, signals the main routine to re-read the file. We run -;; under the with-mail-to command so that the process runs as a child, -;; preventing lockup. If cron is supposed to check for updates to /etc/crontab, -;; then this procedure will be called about 5 seconds before every minute. - -(define (check-system-crontab) - (with-mail-out (lambda () - (let ((mtime (stat:mtime (stat "/etc/crontab")))) - (if (> mtime (- (current-time) 60)) - (let ((socket (socket AF_UNIX SOCK_STREAM 0))) - (connect socket AF_UNIX config-socket-file) - (display "/etc/crontab" socket) - (close socket))))))) diff --git a/scm/mcron/vixie-time.scm b/scm/mcron/vixie-time.scm deleted file mode 100644 index a91fa89..0000000 --- a/scm/mcron/vixie-time.scm +++ /dev/null @@ -1,384 +0,0 @@ -;; Copyright (C) 2003 Dale Mellor -;; -;; This file is part of GNU mcron. -;; -;; GNU mcron is free software: you can redistribute it and/or modify it under -;; the terms of the GNU General Public License as published by the Free -;; Software Foundation, either version 3 of the License, or (at your option) -;; any later version. -;; -;; GNU mcron is distributed in the hope that it will be useful, but WITHOUT -;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for -;; more details. -;; -;; You should have received a copy of the GNU General Public License along -;; with GNU mcron. If not, see . - -(define-module (mcron vixie-time) - #:use-module (ice-9 regex) - #:use-module (mcron job-specifier) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-13) - #:use-module (srfi srfi-14) - #:export (parse-vixie-time)) - -;; In Vixie-style time specifications three-letter symbols are allowed to stand -;; for the numbers corresponding to months and days of the week. We deal with -;; this by making a textual substitution early on in the processing of the -;; strings. -;; -;; We start by defining, once and for all, a list of cons cells consisting of -;; regexps which will match the symbols - which allow an arbitrary number of -;; other letters to appear after them (so that the user can optionally complete -;; the month and day names; this is an extension of Vixie) - and the value which -;; is to replace the symbol. -;; -;; The procedure then takes a string, and then for each symbol in the -;; parse-symbols list attempts to locate an instance and replace it with an -;; ASCII representation of the value it stands for. The procedure returns the -;; modified string. (Note that each symbol can appear only once, which meets the -;; Vixie specifications technically but still allows silly users to mess things -;; up). - -(define parse-symbols - (map (lambda (symbol-cell) - (cons (make-regexp (string-append (car symbol-cell) "[[:alpha:]]*") - regexp/icase) - (cdr symbol-cell))) - '(("jan" . "0") ("feb" . "1") ("mar" . "2") ("apr" . "3") - ("may" . "4") ("jun" . "5") ("jul" . "6") ("aug" . "7") - ("sep" . "8") ("oct" . "9") ("nov" . "10") ("dec" . "11") - - ("sun" . "0") ("mon" . "1") ("tue" . "2") ("wed" . "3") - ("thu" . "4") ("fri" . "5") ("sat" . "6") ))) - -(define (vixie-substitute-parse-symbols string) - (for-each (lambda (symbol-cell) - (let ((match (regexp-exec (car symbol-cell) string))) - (if match - (set! string (string-append (match:prefix match) - (cdr symbol-cell) - (match:suffix match)))))) - parse-symbols) - string) - - - -;; A Vixie time specification is made up of a space-separated list of elements, -;; and the elements consist of a comma-separated list of subelements. The -;; procedure below takes a string holding a subelement, which should have no -;; spaces or symbols (see above) in it, and returns a list of all values which -;; that subelement indicates. There are five distinct cases which must be dealt -;; with: [1] a single '*' which returns a list of all values; [2] a '*' followed -;; by a step specifier; [3] a range and step specifier; [4] a range; and [5] a -;; single number. -;; -;; To perform the computation required for the '*' cases, we need to pass the -;; limit of the allowable range for this subelement as the third argument. As -;; days of the month start at 1 while all the other time components start at 0, -;; we must pass the base of the range to deal with this case also. - -(define parse-vixie-subelement-regexp - (make-regexp "^([[:digit:]]+)(-([[:digit:]]+)(/([[:digit:]]+))?)?$")) - -(define (parse-vixie-subelement string base limit) - (if (char=? (string-ref string 0) #\*) - (range base limit (if (> (string-length string) 1) - (string->number (substring string 2)) ;; [2] - 1)) ;; [1] - (let ((match (regexp-exec parse-vixie-subelement-regexp string))) - (cond ((not match) - (throw 'mcron-error 9 - "Bad Vixie-style time specification.")) - ((match:substring match 5) - (range (string->number (match:substring match 1)) - (+ 1 (string->number (match:substring match 3))) - (string->number (match:substring match 5)))) ;; [3] - ((match:substring match 3) - (range (string->number (match:substring match 1)) - (+ 1 (string->number (match:substring match 3))))) ;; [4] - (else - (list (string->number (match:substring match 1)))))))) ;; [5] - - - -;; A Vixie element contains the entire specification, without spaces or symbols, -;; of the acceptable values for one of the time components (minutes, hours, -;; days, months, week days). Here we break the comma-separated list into -;; subelements, and process each with the procedure above. The return value is a -;; list of all the valid values of all the subcomponents. -;; -;; The second and third arguments are the base and upper limit on the values -;; that can be accepted for this time element. -;; -;; The effect of the 'apply append' is to merge a list of lists into a single -;; list. - -(define (parse-vixie-element string base limit) - (apply append - (map (lambda (sub-element) - (parse-vixie-subelement sub-element base limit)) - (string-tokenize string (char-set-complement (char-set #\,)))))) - - - -;; Consider there are two lists, one of days in the month, the other of days in -;; the week. This procedure returns an augmented list of days in the month with -;; weekdays accounted for. - -(define (interpolate-weekdays mday-list wday-list month year) - (let ((t (localtime 0))) - (set-tm:mday t 1) - (set-tm:mon t month) - (set-tm:year t year) - (let ((first-day (tm:wday (cdr (mktime t))))) - (apply append - mday-list - (map (lambda (wday) - (let ((first (- wday first-day))) - (if (< first 0) (set! first (+ first 7))) - (range (+ 1 first) 32 7))) - wday-list))))) - - - -;; Return the number of days in a month. Fix up a tm object for the zero'th day -;; of the next month, rationalize the object and extract the day. - -(define (days-in-month month year) - (let ((t (localtime 0))) (set-tm:mday t 0) - (set-tm:mon t (+ month 1)) - (set-tm:year t year) - (tm:mday (cdr (mktime t))))) - - - -;; We will be working with a list of time-spec's, one for each element of a time -;; specification (minute, hour, ...). Each time-spec holds three pieces of -;; information: a list of acceptable values for this time component, a procedure -;; to get the component from a tm object, and a procedure to set the component -;; in a tm object. - -(define (time-spec:list time-spec) (vector-ref time-spec 0)) -(define (time-spec:getter time-spec) (vector-ref time-spec 1)) -(define (time-spec:setter time-spec) (vector-ref time-spec 2)) - - - -;; This procedure modifies the time tm object by setting the component referred -;; to by the time-spec object to its next acceptable value. If this value is not -;; greater than the original (because we have wrapped around the top of the -;; acceptable values list), then the function returns #t, otherwise it returns -;; #f. Thus, if the return value is true then it will be necessary for the -;; caller to increment the next coarser time component as well. -;; -;; The first part of the let block is a concession to humanity; the procedure is -;; simply unreadable without all of these aliases. - -(define (increment-time-component time time-spec) - (let* ((time-list (time-spec:list time-spec)) - (getter (time-spec:getter time-spec)) - (setter (time-spec:setter time-spec)) - (find-best-next (@@ (mcron job-specifier) %find-best-next)) - (next-best (find-best-next (getter time) time-list)) - (wrap-around (eqv? (cdr next-best) 9999))) - (setter time ((if wrap-around car cdr) next-best)) - wrap-around)) - - - -;; There now follows a set of procedures for adjusting an element of time, -;; i.e. taking it to the next acceptable value. In each case, the head of the -;; time-spec-list is expected to correspond to the component of time in -;; question. If the adjusted value wraps around its allowed range, then the next -;; biggest element of time must be adjusted, and so on. - -;; There is no specification allowed for the year component of -;; time. Therefore, if we have to make an adjustment (presumably because a -;; monthly adjustment has wrapped around the top of its range) we can simply -;; go to the next year. - -(define (nudge-year! time) - (set-tm:year time (+ (tm:year time) 1))) - - -;; We nudge the month by finding the next allowable value, and if it wraps -;; around we also nudge the year. The time-spec-list will have time-spec -;; objects for month and weekday. - -(define (nudge-month! time time-spec-list) - (and (increment-time-component time (car time-spec-list)) - (nudge-year! time))) - - -;; Try to increment the day component of the time according to the combination -;; of the mday-list and the wday-list. If this wraps around the range, or if -;; this falls outside the current month (31st February, for example), then -;; bump the month, set the day to zero, and recurse on this procedure to find -;; the next day in the new month. -;; -;; The time-spec-list will have time-spec entries for mday, month, and -;; weekday. - -(define (nudge-day! time time-spec-list) - (if (or (increment-time-component - time - (vector - (interpolate-weekdays (time-spec:list (car time-spec-list)) - (time-spec:list (caddr time-spec-list)) - (tm:mon time) - (tm:year time)) - tm:mday - set-tm:mday)) - (> (tm:mday time) (days-in-month (tm:mon time) (tm:year time)))) - (begin - (nudge-month! time (cdr time-spec-list)) - (set-tm:mday time 0) - (nudge-day! time time-spec-list)))) - - - -;; The hour is bumped to the next accceptable value, and the day is bumped if -;; the hour wraps around. -;; -;; The time-spec-list holds specifications for hour, mday, month and weekday. - -(define (nudge-hour! time time-spec-list) - (and (increment-time-component time (car time-spec-list)) - (nudge-day! time (cdr time-spec-list)))) - - - -;; The minute is bumped to the next accceptable value, and the hour is bumped -;; if the minute wraps around. -;; -;; The time-spec-list holds specifications for minute, hour, day-date, month -;; and weekday. - -(define (nudge-min! time time-spec-list) - (and (increment-time-component time (car time-spec-list)) - (nudge-hour! time (cdr time-spec-list)))) - - - - -;; This is a procedure which returns a procedure which computes the next time a -;; command should run after the current time, based on the information in the -;; Vixie-style time specification. -;; -;; We start by computing a list of time-spec objects (described above) for the -;; minute, hour, date, month, year and weekday components of the overall time -;; specification [1]. Special care is taken to produce proper values for -;; fields 2 and 4: according to Vixie specification "If both fields are -;; restricted (ie, aren't *), the command will be run when _either_ field -;; matches the current time." This implies that if one of these fields is *, -;; while the other is not, its value should be '() [0], otherwise -;; interpolate-weekdays below will produce incorrect results. - -;; When we create the return procedure, it is this list to -;; which references to a time-spec-list will be bound. It will be used by the -;; returned procedure [3] to compute the next time a function should run. Any -;; 7's in the weekday component of the list (the last one) are folded into 0's -;; (both values represent sunday) [2]. Any 0's in the month-day component of the -;; list are removed (this allows a solitary zero to be used to indicate that -;; jobs should only run on certain days of the _week_) [2.1]. -;; -;; The returned procedure itself:- -;; -;; Starts by obtaining the current broken-down time [4], and fixing it to -;; ensure that it is an acceptable value, as follows. Each component from the -;; biggest down is checked for acceptability, and if it is not acceptable it -;; is bumped to the next acceptable value (this may cause higher components to -;; also be bumped if there is range wrap-around) and all the lower components -;; are set to -1 so that it can successfully be bumped up to zero if this is -;; an allowed value. The -1 value will be bumped up subsequently to an allowed -;; value [5]. -;; -;; Once it has been asserted that the current time is acceptable, or has been -;; adjusted to one minute before the next acceptable time, the minute -;; component is then bumped to the next acceptable time, which may ripple -;; through the higher components if necessary [6]. We now have the next time -;; the command needs to run. -;; -;; The new time is then converted back into a UNIX time and returned [7]. - -(define (parse-vixie-time string) - (let ((tokens (string-tokenize (vixie-substitute-parse-symbols string)))) - (cond - ((> (length tokens) 5) - (throw 'mcron-error 9 - "Too many fields in Vixie-style time specification")) - ((< (length tokens) 5) - (throw 'mcron-error 9 - "Not enough fields in Vixie-style time specification"))) - (let ((time-spec-list - (map-in-order (lambda (x) (vector - (let* ((n (vector-ref x 0)) - (tok (list-ref tokens n))) - (cond - ((and (= n 4) - (string=? tok "*") - (not (string=? - (list-ref tokens 2) "*"))) - '()) - ((and (= n 2) - (string=? tok "*") - (not (string=? - (list-ref tokens 4) "*"))) - '()) - (else - (parse-vixie-element - tok - (vector-ref x 1) - (vector-ref x 2))))) ; [0] - (vector-ref x 3) - (vector-ref x 4))) - ;; token range-top+1 getter setter - `( #( 0 0 60 ,tm:min ,set-tm:min ) - #( 1 0 24 ,tm:hour ,set-tm:hour ) - #( 2 1 32 ,tm:mday ,set-tm:mday ) - #( 3 0 12 ,tm:mon ,set-tm:mon ) - #( 4 0 7 ,tm:wday ,set-tm:wday ))))) ;; [1] - - (vector-set! (car (last-pair time-spec-list)) - 0 - (map (lambda (time-spec) - (if (eqv? time-spec 7) 0 time-spec)) - (vector-ref (car (last-pair time-spec-list)) 0))) ;; [2] - - (vector-set! (caddr time-spec-list) - 0 - (remove (lambda (day) (eqv? day 0)) - (vector-ref (caddr time-spec-list) 0))) ;; [2.1] - - - (lambda (current-time) ;; [3] - (let ((time (localtime current-time))) ;; [4] - - (if (not (member (tm:mon time) - (time-spec:list (cadddr time-spec-list)))) - (begin - (nudge-month! time (cdddr time-spec-list)) - (set-tm:mday time 0))) - (if (or (eqv? (tm:mday time) 0) - (not (member (tm:mday time) - (interpolate-weekdays - (time-spec:list (caddr time-spec-list)) - (time-spec:list (caddr (cddr time-spec-list))) - (tm:mon time) - (tm:year time))))) - (begin - (nudge-day! time (cddr time-spec-list)) - (set-tm:hour time -1))) - (if (not (member (tm:hour time) - (time-spec:list (cadr time-spec-list)))) - (begin - (nudge-hour! time (cdr time-spec-list)) - (set-tm:min time -1))) ;; [5] - - (set-tm:sec time 0) - (nudge-min! time time-spec-list) ;; [6] - (car (mktime time))))))) ;; [7] - - diff --git a/src/mcron.c b/src/mcron.c new file mode 100644 index 0000000..92e1a37 --- /dev/null +++ b/src/mcron.c @@ -0,0 +1,87 @@ +/* mcron - run jobs at scheduled times + + Copyright (C) 2015, 2016 Mathieu Lirzin + 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 . */ + +/* This C code represents a thin wrapper around the Guile code of Mcron. It + is needed because the crontab personality requires SUID which is not + permitted for executable scripts. */ + +#include "config.h" +#include +#include +#include +#include + +/* Forward declarations. */ +static void inner_main (void *closure, int argc, char **argv); +static void react_to_terminal_signal (int sig); +static SCM set_cron_signals (void); + +int +main (int argc, char **argv) +{ + scm_boot_guile (argc, argv, inner_main, 0); + + return EXIT_SUCCESS; +} + +/* Launch the Mcron Guile main program. */ +static void +inner_main (void *closure, int argc, char **argv) +{ + /* Set Guile load paths to ensure that Mcron modules will be found. */ + if (getenv ("MCRON_UNINSTALLED") == NULL) + { + scm_c_eval_string ("(set! %load-path (cons \"" + PACKAGE_LOAD_PATH "\" %load-path))"); + scm_c_eval_string ("(set! %load-compiled-path (cons \"" + PACKAGE_LOAD_PATH "\" %load-compiled-path))"); + } + scm_set_current_module (scm_c_resolve_module ("mcron main")); + /* Register set_cron_signals to be called from Guile. */ + scm_c_define_gsubr ("c-set-cron-signals", 0, 0, 0, set_cron_signals); + scm_c_eval_string ("(main)"); +} + +/* Set up all the signal handlers as required by the cron personality. This + is necessary to perform the signal processing in C because the sigaction + function won't work when called from Guile. */ +static SCM +set_cron_signals () +{ + static struct sigaction sa; + + memset (&sa, 0, sizeof (sa)); + sa.sa_handler = react_to_terminal_signal; + sigaction (SIGTERM, &sa, 0); + sigaction (SIGINT, &sa, 0); + sigaction (SIGQUIT, &sa, 0); + sigaction (SIGHUP, &sa, 0); + + return SCM_BOOL_T; +} + +/* Handle signal SIG and exit. All signals that mcron handles will produce + the same behavior so we don't need to use SIG in the implementation. */ +static void +react_to_terminal_signal (int sig) +{ + scm_c_eval_string ("(delete-run-file)"); + exit (EXIT_FAILURE); +} diff --git a/src/mcron/config.scm.in b/src/mcron/config.scm.in new file mode 100644 index 0000000..db2bc32 --- /dev/null +++ b/src/mcron/config.scm.in @@ -0,0 +1,39 @@ +;; -*-scheme-*- + +;; Copyright (C) 2015 Mathieu Lirzin +;; Copyright (C) 2003 Dale Mellor +;; +;; This file is part of GNU mcron. +;; +;; GNU mcron is free software: you can redistribute it and/or modify it under +;; the terms of the GNU General Public License as published by the Free +;; Software Foundation, either version 3 of the License, or (at your option) +;; any later version. +;; +;; GNU mcron is distributed in the hope that it will be useful, but WITHOUT +;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for +;; more details. +;; +;; You should have received a copy of the GNU General Public License along +;; with GNU mcron. If not, see . + + +;; Some constants set by the configuration process. + +(define-module (mcron config)) + +(define-public config-debug @CONFIG_DEBUG@) +(define-public config-package-name "@PACKAGE_NAME@") +(define-public config-package-version "@PACKAGE_VERSION@") +(define-public config-package-string "@PACKAGE_STRING@") +(define-public config-package-bugreport "@PACKAGE_BUGREPORT@") +(define-public config-package-url "@PACKAGE_URL@") +(define-public config-sendmail "@SENDMAIL@") + +(define-public config-spool-dir "@CONFIG_SPOOL_DIR@") +(define-public config-socket-file "@CONFIG_SOCKET_FILE@") +(define-public config-allow-file "@CONFIG_ALLOW_FILE@") +(define-public config-deny-file "@CONFIG_DENY_FILE@") +(define-public config-pid-file "@CONFIG_PID_FILE@") +(define-public config-tmp-dir "@CONFIG_TMP_DIR@") diff --git a/src/mcron/crontab.scm b/src/mcron/crontab.scm new file mode 100644 index 0000000..6be5c61 --- /dev/null +++ b/src/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/src/mcron/environment.scm b/src/mcron/environment.scm new file mode 100644 index 0000000..b563d55 --- /dev/null +++ b/src/mcron/environment.scm @@ -0,0 +1,97 @@ +;; 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 . + + + +;; This file defines the variable current-environment-mods, and the procedures +;; append-environment-mods (which is available to user configuration files), +;; clear-environment-mods and modify-environment. The idea is that the +;; current-environment-mods is a list of pairs of environment names and values, +;; and represents the cumulated environment settings in a configuration +;; file. When a job definition is seen in a configuration file, the +;; current-environment-mods are copied into the internal job description, and +;; when the job actually runs these environment modifications are applied to +;; the UNIX environment in which the job runs. + + + + +(define-module (mcron environment) + #:export (modify-environment + clear-environment-mods + append-environment-mods + get-current-environment-mods-copy)) + + + +;; As we parse configuration files, we build up an alist of environment +;; variables here. + +(define current-environment-mods '()) + + + +;; Each time a job is added to the system, we take a snapshot of the current +;; set of environment modifiers. + +(define (get-current-environment-mods-copy) + (list-copy current-environment-mods)) + + + +;; When we start to parse a new configuration file, we want to start with a +;; fresh environment (actually an umodified version of the pervading mcron +;; environment). + +(define (clear-environment-mods) + (set! current-environment-mods '())) + + + +;; Procedure to add another environment setting to the alist above. This is +;; used both implicitly by the Vixie parser, and can be used directly by users +;; in scheme configuration files. The return value is purely for the +;; convenience of the parse-vixie-environment in the vixie-specification module +;; (yuk). + +(define (append-environment-mods name value) + (set! current-environment-mods (append current-environment-mods + (list (cons name value)))) + #t) + +(define (modify-environment env passwd-entry) + "Modify the environment (in the UNIX sense) by setting the variables from +ENV and some default ones which are modulated by PASSWD-ENTRY. \"LOGNAME\" +and \"USER\" environment variables can't be overided by ENV. ENV must be an +alist which associate environment variables to their value. PASSWD-ENTRY must +be an object representing user information which corresponds to a valid entry +in /etc/passwd. The return value is not specified." + (for-each (lambda (pair) (setenv (car pair) (cdr pair))) + (let ((home-dir (passwd:dir passwd-entry)) + (user-name (passwd:name passwd-entry))) + (append + ;; Default environment variables which can be overided by ENV. + `(("HOME" . ,home-dir) + ("CWD" . ,home-dir) + ("SHELL" . ,(passwd:shell passwd-entry)) + ("TERM" . #f) + ("TERMCAP" . #f)) + env + ;; Environment variables with imposed values. + `(("LOGNAME" . ,user-name) + ("USER" . ,user-name)))))) diff --git a/src/mcron/job-specifier.scm b/src/mcron/job-specifier.scm new file mode 100644 index 0000000..1c2f9d9 --- /dev/null +++ b/src/mcron/job-specifier.scm @@ -0,0 +1,253 @@ +;; Copyright (C) 2003 Dale Mellor +;; Copyright (C) 2016 Mathieu Lirzin +;; +;; This file is part of GNU mcron. +;; +;; GNU mcron is free software: you can redistribute it and/or modify it under +;; the terms of the GNU General Public License as published by the Free +;; Software Foundation, either version 3 of the License, or (at your option) +;; any later version. +;; +;; GNU mcron is distributed in the hope that it will be useful, but WITHOUT +;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for +;; more details. +;; +;; You should have received a copy of the GNU General Public License along +;; with GNU mcron. If not, see . + + + +;; This module defines all the functions that can be used by scheme mcron +;; configuration files, namely the procedures for working out next times, the +;; job procedure for registering new jobs (actually a wrapper around the core +;; add-job function), and the procedure for declaring environment modifications. + +(define-module (mcron job-specifier) + #:use-module (ice-9 match) + #:use-module (mcron core) + #:use-module (mcron environment) + #:use-module (mcron vixie-time) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:re-export (append-environment-mods) + #:export (range + next-year-from next-year + next-month-from next-month + next-day-from next-day + next-hour-from next-hour + next-minute-from next-minute + next-second-from next-second + set-configuration-user + set-configuration-time + job)) + +(define* (range start end #:optional (step 1)) + "Produces a list of values from START up to (but not including) END. An +optional STEP may be supplied, and (if positive) only every step'th value will +go into the list. For example, (range 1 6 2) returns '(1 3 5)." + (unfold (cut >= <> end) identity (cute + <> (max step 1)) start)) + +(define (%find-best-next current next-list) + ;; Takes a value and a list of possible next values (all assumed less than + ;; 9999). It returns a pair consisting of the smallest element of the + ;; NEXT-LIST, and the smallest element larger than the CURRENT value. If an + ;; example of the latter cannot be found, 9999 will be returned. + (let loop ((smallest 9999) (closest+ 9999) (lst next-list)) + (match lst + (() (cons smallest closest+)) + ((time . rest) + (loop (min time smallest) + (if (> time current) (min time closest+) closest+) + rest))))) + +;; Internal function to return the time corresponding to some near future +;; hour. If hour-list is not supplied, the time returned corresponds to the +;; start of the next hour of the day. +;; +;; If the hour-list is supplied the time returned corresponds to the first hour +;; of the day in the future which is contained in the list. If all the values in +;; the list are less than the current hour, then the time returned will +;; correspond to the first hour in the list *on the following day*. +;; +;; ... except that the function is actually generalized to deal with seconds, +;; minutes, etc., in an obvious way :-) +;; +;; Note that value-list always comes from an optional argument to a procedure, +;; so is wrapped up as the first element of a list (i.e. it is a list inside a +;; list). + +(define (bump-time time value-list component higher-component + set-component! set-higher-component!) + (if (null? value-list) + (set-component! time (+ (component time) 1)) + (let ((best-next (%find-best-next (component time) (car value-list)))) + (if (eqv? 9999 (cdr best-next)) + (begin + (set-higher-component! time (+ (higher-component time) 1)) + (set-component! time (car best-next))) + (set-component! time (cdr best-next))))) + (car (mktime time))) + + + + +;; Set of configuration methods which use the above general function to bump +;; specific components of time to the next legitimate value. In each case, all +;; the components smaller than that of interest are taken to zero, so that for +;; example the time of the next year will be the time at which the next year +;; actually starts. + +(define (next-year-from current-time . year-list) + (let ((time (localtime current-time))) + (set-tm:mon time 0) + (set-tm:mday time 1) + (set-tm:hour time 0) + (set-tm:min time 0) + (set-tm:sec time 0) + (bump-time time year-list tm:year tm:year set-tm:year set-tm:year))) + +(define (next-month-from current-time . month-list) + (let ((time (localtime current-time))) + (set-tm:mday time 1) + (set-tm:hour time 0) + (set-tm:min time 0) + (set-tm:sec time 0) + (bump-time time month-list tm:mon tm:year set-tm:mon set-tm:year))) + +(define (next-day-from current-time . day-list) + (let ((time (localtime current-time))) + (set-tm:hour time 0) + (set-tm:min time 0) + (set-tm:sec time 0) + (bump-time time day-list tm:mday tm:mon set-tm:mday set-tm:mon))) + +(define (next-hour-from current-time . hour-list) + (let ((time (localtime current-time))) + (set-tm:min time 0) + (set-tm:sec time 0) + (bump-time time hour-list tm:hour tm:mday set-tm:hour set-tm:mday))) + +(define (next-minute-from current-time . minute-list) + (let ((time (localtime current-time))) + (set-tm:sec time 0) + (bump-time time minute-list tm:min tm:hour set-tm:min set-tm:hour))) + +(define (next-second-from current-time . second-list) + (let ((time (localtime current-time))) + (bump-time time second-list tm:sec tm:min set-tm:sec set-tm:min))) + + + +;; The current-action-time is the time a job was last run, the time from which +;; the next time to run a job must be computed. (When the program is first run, +;; this time is set to the configuration time so that jobs run from that moment +;; forwards.) Once we have this, we supply versions of the time computation +;; commands above which implicitly assume this value. + +(define current-action-time 0) + + + +;; We want to provide functions which take a single optional argument (as well +;; as implicitly the current action time), but unlike usual scheme behaviour if +;; the argument is missing we want to act like it is really missing, and if it +;; is there we want to act like it is a genuine argument, not a list of +;; optionals. + +(define (maybe-args function args) + (if (null? args) + (function current-action-time) + (function current-action-time (car args)))) + + + +;; These are the convenience functions we were striving to define for the +;; configuration files. They are wrappers for the next-X-from functions above, +;; but implicitly use the current-action-time for the time argument. + +(define (next-year . args) (maybe-args next-year-from args)) +(define (next-month . args) (maybe-args next-month-from args)) +(define (next-day . args) (maybe-args next-day-from args)) +(define (next-hour . args) (maybe-args next-hour-from args)) +(define (next-minute . args) (maybe-args next-minute-from args)) +(define (next-second . args) (maybe-args next-second-from args)) + + + +;; The default user for running jobs is the current one (who invoked this +;; program). There are exceptions: when cron parses /etc/crontab the user is +;; specified on each individual line; when cron parses /var/cron/tabs/* the user +;; is derived from the filename of the crontab. These cases are dealt with by +;; mutating this variable. Note that the variable is only used at configuration +;; time; a UID is stored with each job and it is that which takes effect when +;; the job actually runs. + +(define configuration-user (getpw (getuid))) +(define configuration-time (current-time)) + +(define (set-configuration-user user) + (set! configuration-user (if (or (string? user) + (integer? user)) + (getpw user) + user))) +(define (set-configuration-time time) (set! configuration-time time)) + + + +;; The job function, available to configuration files for adding a job rule to +;; the system. +;; +;; Here we must 'normalize' the next-time-function so that it is always a lambda +;; function which takes one argument (the last time the job ran) and returns a +;; single value (the next time the job should run). If the input value is a +;; string this is parsed as a Vixie-style time specification, and if it is a +;; list then we arrange to eval it (but note that such lists are expected to +;; ignore the function parameter - the last run time is always read from the +;; current-action-time global variable). A similar normalization is applied to +;; the action. +;; +;; Here we also compute the first time that the job is supposed to run, by +;; finding the next legitimate time from the current configuration time (set +;; right at the top of this program). + +(define (job time-proc action . displayable) + (let ((action (cond ((procedure? action) action) + ((list? action) (lambda () (primitive-eval action))) + ((string? action) (lambda () (system action))) + (else + (throw 'mcron-error 2 + "job: invalid second argument (action; should be lambda " + "function, string or list)")))) + + (time-proc + (cond ((procedure? time-proc) time-proc) + ((string? time-proc) (parse-vixie-time time-proc)) + ((list? time-proc) (lambda (current-time) + (primitive-eval time-proc))) + (else + (throw 'mcron-error 3 + "job: invalid first argument (next-time-function; " + "should be function, string or list)")))) + (displayable + (cond ((not (null? displayable)) (car displayable)) + ((procedure? action) "Lambda function") + ((string? action) action) + ((list? action) (with-output-to-string + (lambda () (display action))))))) + (add-job (lambda (current-time) + (set! current-action-time current-time) ;; ?? !!!! Code + + ;; Contributed by Sergey Poznyakoff to allow for daylight savings + ;; time changes. + (let* ((next (time-proc current-time)) + (gmtoff (tm:gmtoff (localtime next))) + (d (+ next (- gmtoff + (tm:gmtoff (localtime current-time)))))) + (if (eqv? (tm:gmtoff (localtime d)) gmtoff) + d + next))) + action + displayable + configuration-time + configuration-user))) diff --git a/src/mcron/main.scm b/src/mcron/main.scm new file mode 100644 index 0000000..1f2b068 --- /dev/null +++ b/src/mcron/main.scm @@ -0,0 +1,401 @@ +;; Copyright (C) 2015, 2016 Mathieu Lirzin +;; Copyright (C) 2003, 2012 Dale Mellor +;; +;; This file is part of GNU mcron. +;; +;; GNU mcron is free software: you can redistribute it and/or modify it under +;; the terms of the GNU General Public License as published by the Free +;; Software Foundation, either version 3 of the License, or (at your option) +;; any later version. +;; +;; GNU mcron is distributed in the hope that it will be useful, but WITHOUT +;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for +;; more details. +;; +;; You should have received a copy of the GNU General Public License along +;; with GNU mcron. If not, see . + +;;; This is the 'main' routine for the whole system; this module is the global +;;; entry point (after the minimal C wrapper); to all intents and purposes the +;;; program is pure Guile and starts here. + +(define-module (mcron main) + #:use-module (ice-9 getopt-long) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 regex) + #:use-module (mcron config) + #:use-module (mcron core) + #:use-module (mcron job-specifier) + #:use-module (mcron vixie-specification) + #:use-module (srfi srfi-2) + #:use-module (srfi srfi-26) + #:export (delete-run-file + main)) + +(define* (command-name #:optional (command (car (command-line)))) + "Extract the actual command name from COMMAND. This returns the last part +of COMMAND without any non-alphabetic characters. For example \"in.cron\" and +\"./mcron\" will return respectively \"cron\" and \"mcron\". + +When COMMAND is not specified this uses the first element of (command-line)." + (match:substring (regexp-exec (make-regexp "[[:alpha:]]*$") command))) + +(define (mcron-error exit-code . rest) + "Print an error message (made up from the parts of REST), and if the +EXIT-CODE error is fatal (present and non-zero) then exit to the system with +EXIT-CODE." + (with-output-to-port (current-error-port) + (lambda () + (for-each display (append (list (command-name) ": ") rest)) + (newline))) + (when (and exit-code (not (eq? exit-code 0))) + (primitive-exit exit-code))) + +(define-syntax-rule (catch-mcron-error exp ...) + "Evaluate EXP .... if an 'mcron-error exception occurs, print its diagnostics +and exit with its error code." + (catch 'mcron-error + (lambda () exp ...) + (lambda (key exit-code . msg) + (apply mcron-error exit-code msg)))) + +(define command-type + ;; We will be doing a lot of testing of the command name, so it makes sense + ;; to perform the string comparisons once and for all here. + (let* ((command (command-name)) + (command=? (cut string=? command <>))) + (cond ((command=? "mcron") 'mcron) + ((or (command=? "cron") (command=? "crond")) 'cron) + ((command=? "crontab") 'crontab) + (else (mcron-error 12 "The command name is invalid."))))) + +(define options + ;; There are a different set of options for the crontab personality compared + ;; to all the others, with the --help and --version options common to all + ;; the personalities. + (catch + 'misc-error + (lambda () + (getopt-long (command-line) + (append + (case command-type + ((crontab) + '((user (single-char #\u) (value #t)) + (edit (single-char #\e) (value #f)) + (list (single-char #\l) (value #f)) + (remove (single-char #\r) (value #f)))) + (else `((schedule (single-char #\s) (value #t) + (predicate + ,(lambda (value) + (string->number value)))) + (daemon (single-char #\d) (value #f)) + (noetc (single-char #\n) (value #f)) + (stdin (single-char #\i) (value #t) + (predicate + ,(lambda (value) + (or (string=? "vixie" value) + (string=? "guile" value)))))))) + '((version (single-char #\v) (value #f)) + (help (single-char #\h) (value #f)))))) + (lambda (key func fmt args . rest) + (mcron-error 1 (apply format (append (list #f fmt) args)))))) + +(define* (show-version #:optional (command (command-name))) + "Display version information for COMMAND and quit." + (let* ((name config-package-name) + (short-name (cadr (string-split name #\space))) + (version config-package-version)) + (simple-format #t "~a (~a) ~a +Copyright (C) 2015 the ~a authors. +License GPLv3+: GNU GPL version 3 or later +This is free software: you are free to change and redistribute it. +There is NO WARRANTY, to the extent permitted by law.\n" + command name version short-name) + (quit))) + +(define (show-package-information) + "Display where to get help and send bug reports." + (simple-format #t "\nReport bugs to: ~a. +~a home page: <~a> +General help using GNU software: \n" + config-package-bugreport + config-package-name + config-package-url)) + +(define* (show-help #:optional (command (command-name))) + "Display informations of usage for COMMAND and quit." + (simple-format #t "Usage: ~a" command) + (display + (case command-type + ((mcron) + " [OPTIONS] [FILES] +Run an mcron process according to the specifications in the FILES (`-' for +standard input), or use all the files in ~/.config/cron (or the +deprecated ~/.cron) with .guile or .vixie extensions. + + -v, --version Display version + -h, --help Display this help message + -sN, --schedule[=]N Display the next N jobs that will be run by mcron + -d, --daemon Immediately detach the program from the terminal + and run as a daemon process + -i, --stdin=(guile|vixie) Format of data passed as standard input or + file arguments (default guile)") + ((cron) + " [OPTIONS] +Unless an option is specified, run a cron daemon as a detached process, +reading all the information in the users' crontabs and in /etc/crontab. + + -v, --version Display version + -h, --help Display this help message + -sN, --schedule[=]N Display the next N jobs that will be run by cron + -n, --noetc Do not check /etc/crontab for updates (HIGHLY + RECOMMENDED).") + ((crontab) + " [-u user] file + crontab [-u user] { -e | -l | -r } + (default operation is replace, per 1003.2) + -e (edit user's crontab) + -l (list user's crontab) + -r (delete user's crontab") + (else "\nrubbish"))) + (newline) + (show-package-information) + (quit)) + +(define (delete-run-file) + "Remove the /var/run/cron.pid file so that crontab and other invocations of +cron don't get the wrong idea that a daemon is currently running. This +procedure is called from the C front-end whenever a terminal signal is +received." + (catch #t (lambda () (delete-file config-pid-file) + (delete-file config-socket-file)) + noop) + (quit)) + +(define (stdin->string) + "Return standard input as a string." + (with-output-to-string (lambda () (do ((in (read-char) (read-char))) + ((eof-object? in)) + (display in))))) + +(define (for-each-file proc directory) + "Apply PROC to each file in DIRECTORY. DIRECTORY must be a valid directory name. +PROC must be a procedure that take one file name argument. The return value +is not specified" + (let ((dir (opendir directory))) + (do ((file-name (readdir dir) (readdir dir))) + ((eof-object? file-name) (closedir dir)) + (proc file-name)))) + +(define process-user-file + (let ((guile-regexp (make-regexp "\\.gui(le)?$")) + (vixie-regexp (make-regexp "\\.vix(ie)?$"))) + (lambda* (file-name #:optional guile-syntax?) + "Process FILE-NAME according its extension. When GUILE-SYNTAX? is TRUE, +force guile syntax usage. If FILE-NAME format is not recognized, it is +silently ignored." + (cond ((string=? "-" file-name) + (if (string=? (option-ref options 'stdin "guile") "vixie") + (read-vixie-port (current-input-port)) + (eval-string (stdin->string)))) + ((or guile-syntax? (regexp-exec guile-regexp file-name)) + (load file-name)) + ((regexp-exec vixie-regexp file-name) + (read-vixie-file file-name)))))) + +(define (process-files-in-user-directory) + "Process files in $XDG_CONFIG_HOME/cron and/or ~/.cron directories (if +$XDG_CONFIG_HOME is not defined uses ~/.config/cron instead)." + (let ((errors 0) + (home-directory (passwd:dir (getpw (getuid))))) + (map (lambda (dir) + (catch #t + (lambda () + (for-each-file + (lambda (file) + (process-user-file (string-append dir "/" file))) + dir)) + (lambda (key . args) + (set! errors (1+ errors))))) + (list (string-append home-directory "/.cron") + (string-append (or (getenv "XDG_CONFIG_HOME") + (string-append home-directory "/.config")) + "/cron"))) + (when (eq? 2 errors) + (mcron-error 13 + "Cannot read files in your ~/.config/cron (or ~/.cron) directory.")))) + +(define (process-files-in-system-directory) + "Process all the files in the crontab directory. When the job procedure is +run on behalf of the configuration files, the jobs are registered on the +system with the appropriate user. Only root should be able to perform this +operation. The permissions on the /var/cron/tabs directory enforce this." + + (define (user-entry name) + ;; Return the user database entry if NAME is valid, otherwise #f. + (false-if-exception (getpwnam name))) + + (catch #t + (lambda () + (for-each-file + (lambda (user) + (and-let* ((entry (user-entry user))) ;crontab without user? + (set-configuration-user entry) + (catch-mcron-error + (read-vixie-file (string-append config-spool-dir "/" user))))) + config-spool-dir)) + (lambda (key . args) + (mcron-error 4 + "You do not have permission to access the system crontabs.")))) + +(define (cron-file-descriptors) + "Establish a socket to listen for updates from a crontab program, and return +a list containing the file descriptors correponding to the files read by +crontab. This requires that command-type is 'cron." + (if (eq? command-type 'cron) + (catch #t + (lambda () + (let ((sock (socket AF_UNIX SOCK_STREAM 0))) + (bind sock AF_UNIX config-socket-file) + (listen sock 5) + (list sock))) + (lambda (key . args) + (delete-file config-pid-file) + (mcron-error 1 "Cannot bind to UNIX socket " config-socket-file))) + '())) + +(define (process-update-request fdes-list) + "Read a user name from the socket, dealing with the /etc/crontab special +case, remove all the user's jobs from the job list, and then re-read the +user's updated file. In the special case drop all the system jobs and re-read +the /etc/crontab file. This function should be called whenever a message +comes in on the above socket." + (let* ((sock (car (accept (car fdes-list)))) + (user-name (read-line sock))) + (close sock) + (set-configuration-time (current-time)) + (catch-mcron-error + (if (string=? user-name "/etc/crontab") + (begin + (clear-system-jobs) + (use-system-job-list) + (read-vixie-file "/etc/crontab" parse-system-vixie-line) + (use-user-job-list)) + (let ((user (getpw user-name))) + (remove-user-jobs user) + (set-configuration-user user) + (read-vixie-file (string-append config-spool-dir "/" user-name))))))) + + +;;; +;;; Entry point. +;;; + +(define (main . args) + ;; Turn debugging on if indicated. + (when config-debug + (debug-enable 'backtrace)) + (when (option-ref options 'version #f) + (show-version)) + (when (option-ref options 'help #f) + (show-help)) + + ;; Setup the cron process, if appropriate. If there is already a + ;; /var/run/cron.pid file, then we must assume a cron daemon is already + ;; running and refuse to start another one. + ;; + ;; Otherwise, clear the MAILTO environment variable so that output from cron + ;; jobs is sent to the various users (this may still be overridden in the + ;; configuration files), and call the function in the C wrapper to set up + ;; terminal signal responses to vector to the procedure above. The PID file + ;; will be filled in properly later when we have forked our daemon process + ;; (but not done if we are only viewing the schedules). + (when (eq? command-type 'cron) + (unless (eqv? (getuid) 0) + (mcron-error 16 + "This program must be run by the root user (and should have been " + "installed as such).")) + (when (access? config-pid-file F_OK) + (mcron-error 1 + "A cron daemon is already running.\n (If you are sure this is not" + " true, remove the file\n " config-pid-file ".)")) + (unless (option-ref options 'schedule #f) + (with-output-to-file config-pid-file noop)) + (setenv "MAILTO" #f) + ;; XXX: At compile time, this yields a "possibly unbound variable" + ;; warning, but this is OK since it is bound in the C wrapper. + (c-set-cron-signals)) + + ;; Now we have the procedures in place for dealing with the contents of + ;; configuration files, the crontab personality is able to validate such + ;; files. If the user requested the crontab personality, we load and run the + ;; code here and then get out. + (when (eq? command-type 'crontab) + (load "crontab.scm") + (quit)) + + ;; Having defined all the necessary procedures for scanning various sets of + ;; files, we perform the actual configuration of the program depending on + ;; the personality we are running as. If it is mcron, we either scan the + ;; files passed on the command line, or else all the ones in the user's + ;; .config/cron (or .cron) directory. If we are running under the cron + ;; personality, we read the /var/cron/tabs directory and also the + ;; /etc/crontab file. + (case command-type + ((mcron) + (if (null? (option-ref options '() '())) + (process-files-in-user-directory) + (for-each (lambda (file-path) (process-user-file file-path #t)) + (option-ref options '() '())))) + ((cron) + (process-files-in-system-directory) + (use-system-job-list) + (catch-mcron-error (read-vixie-file "/etc/crontab" + parse-system-vixie-line)) + (use-user-job-list) + (unless (option-ref options 'noetc #f) + (display "\ +WARNING: cron will check for updates to /etc/crontab EVERY MINUTE. If you do +not use this file, or you are prepared to manually restart cron whenever you +make a change, then it is HIGHLY RECOMMENDED that you use the --noetc +option.\n") + (set-configuration-user "root") + (job '(- (next-minute-from (next-minute)) 6) + check-system-crontab + "/etc/crontab update checker.")))) + + ;; If the user has requested a schedule of jobs that will run, we provide + ;; the information here and then get out. Start by determining the number + ;; of time points in the future that output is required for. This may be + ;; provided on the command line as a parameter to the --schedule option, or + ;; else we assume a default of 8. Finally, ensure that the count is some + ;; positive integer. + (and-let* ((count (option-ref options 'schedule #f))) + (set! count (string->number count)) + (display (get-schedule (if (<= count 0) 1 count))) + (quit)) + + ;; If we are supposed to run as a daemon process (either a --daemon option + ;; has been explicitly used, or we are running as cron or crond), detach + ;; from the terminal now. If we are running as cron, we can now write the + ;; PID file. + (when (option-ref options 'daemon (eq? command-type 'cron)) + (unless (eqv? (primitive-fork) 0) + (quit)) + (setsid) + (when (eq? command-type 'cron) + (with-output-to-file config-pid-file + (lambda () (display (getpid)) (newline))))) + + ;; Now the main loop. Forever execute the run-job-loop procedure in the + ;; mcron core, and when it drops out (can only be because a message has come + ;; in on the socket) we process the socket request before restarting the + ;; loop again. Sergey Poznyakoff: we can also drop out of run-job-loop + ;; because of a SIGCHLD, so must test FDES-LIST. + (catch-mcron-error + (let ((fdes-list (cron-file-descriptors))) + (while #t + (run-job-loop fdes-list) + (unless (null? fdes-list) + (process-update-request fdes-list)))))) diff --git a/src/mcron/mcron-core.scm b/src/mcron/mcron-core.scm new file mode 100644 index 0000000..13781c9 --- /dev/null +++ b/src/mcron/mcron-core.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 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/redirect.scm b/src/mcron/redirect.scm new file mode 100644 index 0000000..af763cb --- /dev/null +++ b/src/mcron/redirect.scm @@ -0,0 +1,190 @@ +;; 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 (ice-9 regex) + #:use-module ((mcron config) :select (config-sendmail)) + #:use-module (mcron vixie-time)) + + + +;; An action string consists of a sequence of characters forming a command +;; executable by the shell, possibly followed by an non-escaped percentage +;; sign. The text after the percentage sign is to be fed to the command's +;; standard input, with further unescaped percents being substituted with +;; newlines. The escape character can itself be escaped. +;; +;; This regexp separates the two halves of the string, and indeed determines if +;; the second part is present. + +(define action-string-regexp (make-regexp "((\\\\%|[^%])*)%(.*)$")) + + + +;; This regexp identifies an escaped percentage sign. + +(define e-percent (make-regexp "\\\\%")) + + +;; Function to execute some action (this may be a shell command, lamdba function +;; or list of scheme procedures) in a forked process, with the input coming from +;; the string, and output (including the error output) being sent to a pipe +;; opened on a mail transport. + +(use-modules (ice-9 popen)) + +(define (with-mail-out action . user) + + ;; Determine the name of the user who is to recieve the mail, looking for a + ;; name in the optional user argument, then in the MAILTO environment + ;; variable, and finally in the LOGNAME environment variable. (The case + ;; MAILTO="" is dealt with specially below.) + + (let* ((mailto (getenv "MAILTO")) + (user (cond (mailto mailto) + ((not (null? user)) (car user)) + (else (getenv "LOGNAME")))) + (parent->child (pipe)) + (child->parent (pipe)) + (child-pid (primitive-fork))) + + + ;; The child process. Close redundant ends of pipes, remap the standard + ;; streams, and run the action, taking care to chop off the input part of an + ;; action string. + + (if (eqv? child-pid 0) + (begin + (close (cdr parent->child)) + (close (car child->parent)) + + (dup2 (port->fdes (car parent->child)) 0) + (close (car parent->child)) + (dup2 (port->fdes (cdr child->parent)) 1) + (close (cdr child->parent)) + (dup2 1 2) + + (cond ((string? action) + (let ((match (regexp-exec action-string-regexp action))) + (system (if match + (let ((action (match:substring match 1))) + (do ((match (regexp-exec e-percent action) + (regexp-exec e-percent action))) + ((not match)) + (set! action (string-append + (match:prefix match) + "%" + (match:suffix match)))) + action) + action)))) + + ((procedure? action) (action)) + ((list? action) (primitive-eval action))) + + (primitive-exit 0))) + + + ;; The parent process. Get rid of redundant pipe ends. + + (close (car parent->child)) + (close (cdr child->parent)) + + + ;; Put stuff to child from after '%' in command line, replacing + ;; other %'s with newlines. Ugly or what? + + (if (string? action) + (let ((port (cdr parent->child)) + (match (regexp-exec action-string-regexp action))) + (if (and match + (match:substring match 3)) + (with-input-from-string (match:substring match 3) + (lambda () + (let loop () + (let ((next-char (read-char))) + (if (not (eof-object? next-char)) + (cond + ((char=? next-char #\%) + (newline port) + (loop)) + ((char=? next-char #\\) + (let ((escape (read-char))) + (if (eof-object? escape) + (display #\\ port) + (if (char=? escape #\%) + (begin + (display #\% port) + (loop)) + (begin + (display #\\ port) + (display escape port) + (loop)))))) + (else + (display next-char port) + (loop))))))))))) + + + ;; So the child process doesn't hang on to its input expecting more stuff. + + (close (cdr parent->child)) + + + ;; That's got streaming into the child's input out of the way, now we stream + ;; the child's output to a mail sink, but only if there is something there + ;; in the first place. + + (if (eof-object? (peek-char (car child->parent))) + + (read-char (car child->parent)) + + (begin + (set-current-output-port (if (and (string? mailto) + (string=? mailto "")) + (open-output-file "/dev/null") + (open-output-pipe + (string-append config-sendmail + " " + user)))) + (set-current-input-port (car child->parent)) + (display "To: ") (display user) (newline) + (display "From: mcron") (newline) + (display (string-append "Subject: " user "@" (gethostname))) + (newline) + (newline) + + (do ((next-char (read-char) (read-char))) + ((eof-object? next-char)) + (display next-char)))) + + (close (car child->parent)) + + (waitpid child-pid))) diff --git a/src/mcron/vixie-specification.scm b/src/mcron/vixie-specification.scm new file mode 100644 index 0000000..5cd1528 --- /dev/null +++ b/src/mcron/vixie-specification.scm @@ -0,0 +1,207 @@ +;; 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/src/mcron/vixie-time.scm b/src/mcron/vixie-time.scm new file mode 100644 index 0000000..a91fa89 --- /dev/null +++ b/src/mcron/vixie-time.scm @@ -0,0 +1,384 @@ +;; 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) + #:use-module (ice-9 regex) + #:use-module (mcron job-specifier) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-13) + #:use-module (srfi srfi-14) + #:export (parse-vixie-time)) + +;; In Vixie-style time specifications three-letter symbols are allowed to stand +;; for the numbers corresponding to months and days of the week. We deal with +;; this by making a textual substitution early on in the processing of the +;; strings. +;; +;; We start by defining, once and for all, a list of cons cells consisting of +;; regexps which will match the symbols - which allow an arbitrary number of +;; other letters to appear after them (so that the user can optionally complete +;; the month and day names; this is an extension of Vixie) - and the value which +;; is to replace the symbol. +;; +;; The procedure then takes a string, and then for each symbol in the +;; parse-symbols list attempts to locate an instance and replace it with an +;; ASCII representation of the value it stands for. The procedure returns the +;; modified string. (Note that each symbol can appear only once, which meets the +;; Vixie specifications technically but still allows silly users to mess things +;; up). + +(define parse-symbols + (map (lambda (symbol-cell) + (cons (make-regexp (string-append (car symbol-cell) "[[:alpha:]]*") + regexp/icase) + (cdr symbol-cell))) + '(("jan" . "0") ("feb" . "1") ("mar" . "2") ("apr" . "3") + ("may" . "4") ("jun" . "5") ("jul" . "6") ("aug" . "7") + ("sep" . "8") ("oct" . "9") ("nov" . "10") ("dec" . "11") + + ("sun" . "0") ("mon" . "1") ("tue" . "2") ("wed" . "3") + ("thu" . "4") ("fri" . "5") ("sat" . "6") ))) + +(define (vixie-substitute-parse-symbols string) + (for-each (lambda (symbol-cell) + (let ((match (regexp-exec (car symbol-cell) string))) + (if match + (set! string (string-append (match:prefix match) + (cdr symbol-cell) + (match:suffix match)))))) + parse-symbols) + string) + + + +;; A Vixie time specification is made up of a space-separated list of elements, +;; and the elements consist of a comma-separated list of subelements. The +;; procedure below takes a string holding a subelement, which should have no +;; spaces or symbols (see above) in it, and returns a list of all values which +;; that subelement indicates. There are five distinct cases which must be dealt +;; with: [1] a single '*' which returns a list of all values; [2] a '*' followed +;; by a step specifier; [3] a range and step specifier; [4] a range; and [5] a +;; single number. +;; +;; To perform the computation required for the '*' cases, we need to pass the +;; limit of the allowable range for this subelement as the third argument. As +;; days of the month start at 1 while all the other time components start at 0, +;; we must pass the base of the range to deal with this case also. + +(define parse-vixie-subelement-regexp + (make-regexp "^([[:digit:]]+)(-([[:digit:]]+)(/([[:digit:]]+))?)?$")) + +(define (parse-vixie-subelement string base limit) + (if (char=? (string-ref string 0) #\*) + (range base limit (if (> (string-length string) 1) + (string->number (substring string 2)) ;; [2] + 1)) ;; [1] + (let ((match (regexp-exec parse-vixie-subelement-regexp string))) + (cond ((not match) + (throw 'mcron-error 9 + "Bad Vixie-style time specification.")) + ((match:substring match 5) + (range (string->number (match:substring match 1)) + (+ 1 (string->number (match:substring match 3))) + (string->number (match:substring match 5)))) ;; [3] + ((match:substring match 3) + (range (string->number (match:substring match 1)) + (+ 1 (string->number (match:substring match 3))))) ;; [4] + (else + (list (string->number (match:substring match 1)))))))) ;; [5] + + + +;; A Vixie element contains the entire specification, without spaces or symbols, +;; of the acceptable values for one of the time components (minutes, hours, +;; days, months, week days). Here we break the comma-separated list into +;; subelements, and process each with the procedure above. The return value is a +;; list of all the valid values of all the subcomponents. +;; +;; The second and third arguments are the base and upper limit on the values +;; that can be accepted for this time element. +;; +;; The effect of the 'apply append' is to merge a list of lists into a single +;; list. + +(define (parse-vixie-element string base limit) + (apply append + (map (lambda (sub-element) + (parse-vixie-subelement sub-element base limit)) + (string-tokenize string (char-set-complement (char-set #\,)))))) + + + +;; Consider there are two lists, one of days in the month, the other of days in +;; the week. This procedure returns an augmented list of days in the month with +;; weekdays accounted for. + +(define (interpolate-weekdays mday-list wday-list month year) + (let ((t (localtime 0))) + (set-tm:mday t 1) + (set-tm:mon t month) + (set-tm:year t year) + (let ((first-day (tm:wday (cdr (mktime t))))) + (apply append + mday-list + (map (lambda (wday) + (let ((first (- wday first-day))) + (if (< first 0) (set! first (+ first 7))) + (range (+ 1 first) 32 7))) + wday-list))))) + + + +;; Return the number of days in a month. Fix up a tm object for the zero'th day +;; of the next month, rationalize the object and extract the day. + +(define (days-in-month month year) + (let ((t (localtime 0))) (set-tm:mday t 0) + (set-tm:mon t (+ month 1)) + (set-tm:year t year) + (tm:mday (cdr (mktime t))))) + + + +;; We will be working with a list of time-spec's, one for each element of a time +;; specification (minute, hour, ...). Each time-spec holds three pieces of +;; information: a list of acceptable values for this time component, a procedure +;; to get the component from a tm object, and a procedure to set the component +;; in a tm object. + +(define (time-spec:list time-spec) (vector-ref time-spec 0)) +(define (time-spec:getter time-spec) (vector-ref time-spec 1)) +(define (time-spec:setter time-spec) (vector-ref time-spec 2)) + + + +;; This procedure modifies the time tm object by setting the component referred +;; to by the time-spec object to its next acceptable value. If this value is not +;; greater than the original (because we have wrapped around the top of the +;; acceptable values list), then the function returns #t, otherwise it returns +;; #f. Thus, if the return value is true then it will be necessary for the +;; caller to increment the next coarser time component as well. +;; +;; The first part of the let block is a concession to humanity; the procedure is +;; simply unreadable without all of these aliases. + +(define (increment-time-component time time-spec) + (let* ((time-list (time-spec:list time-spec)) + (getter (time-spec:getter time-spec)) + (setter (time-spec:setter time-spec)) + (find-best-next (@@ (mcron job-specifier) %find-best-next)) + (next-best (find-best-next (getter time) time-list)) + (wrap-around (eqv? (cdr next-best) 9999))) + (setter time ((if wrap-around car cdr) next-best)) + wrap-around)) + + + +;; There now follows a set of procedures for adjusting an element of time, +;; i.e. taking it to the next acceptable value. In each case, the head of the +;; time-spec-list is expected to correspond to the component of time in +;; question. If the adjusted value wraps around its allowed range, then the next +;; biggest element of time must be adjusted, and so on. + +;; There is no specification allowed for the year component of +;; time. Therefore, if we have to make an adjustment (presumably because a +;; monthly adjustment has wrapped around the top of its range) we can simply +;; go to the next year. + +(define (nudge-year! time) + (set-tm:year time (+ (tm:year time) 1))) + + +;; We nudge the month by finding the next allowable value, and if it wraps +;; around we also nudge the year. The time-spec-list will have time-spec +;; objects for month and weekday. + +(define (nudge-month! time time-spec-list) + (and (increment-time-component time (car time-spec-list)) + (nudge-year! time))) + + +;; Try to increment the day component of the time according to the combination +;; of the mday-list and the wday-list. If this wraps around the range, or if +;; this falls outside the current month (31st February, for example), then +;; bump the month, set the day to zero, and recurse on this procedure to find +;; the next day in the new month. +;; +;; The time-spec-list will have time-spec entries for mday, month, and +;; weekday. + +(define (nudge-day! time time-spec-list) + (if (or (increment-time-component + time + (vector + (interpolate-weekdays (time-spec:list (car time-spec-list)) + (time-spec:list (caddr time-spec-list)) + (tm:mon time) + (tm:year time)) + tm:mday + set-tm:mday)) + (> (tm:mday time) (days-in-month (tm:mon time) (tm:year time)))) + (begin + (nudge-month! time (cdr time-spec-list)) + (set-tm:mday time 0) + (nudge-day! time time-spec-list)))) + + + +;; The hour is bumped to the next accceptable value, and the day is bumped if +;; the hour wraps around. +;; +;; The time-spec-list holds specifications for hour, mday, month and weekday. + +(define (nudge-hour! time time-spec-list) + (and (increment-time-component time (car time-spec-list)) + (nudge-day! time (cdr time-spec-list)))) + + + +;; The minute is bumped to the next accceptable value, and the hour is bumped +;; if the minute wraps around. +;; +;; The time-spec-list holds specifications for minute, hour, day-date, month +;; and weekday. + +(define (nudge-min! time time-spec-list) + (and (increment-time-component time (car time-spec-list)) + (nudge-hour! time (cdr time-spec-list)))) + + + + +;; This is a procedure which returns a procedure which computes the next time a +;; command should run after the current time, based on the information in the +;; Vixie-style time specification. +;; +;; We start by computing a list of time-spec objects (described above) for the +;; minute, hour, date, month, year and weekday components of the overall time +;; specification [1]. Special care is taken to produce proper values for +;; fields 2 and 4: according to Vixie specification "If both fields are +;; restricted (ie, aren't *), the command will be run when _either_ field +;; matches the current time." This implies that if one of these fields is *, +;; while the other is not, its value should be '() [0], otherwise +;; interpolate-weekdays below will produce incorrect results. + +;; When we create the return procedure, it is this list to +;; which references to a time-spec-list will be bound. It will be used by the +;; returned procedure [3] to compute the next time a function should run. Any +;; 7's in the weekday component of the list (the last one) are folded into 0's +;; (both values represent sunday) [2]. Any 0's in the month-day component of the +;; list are removed (this allows a solitary zero to be used to indicate that +;; jobs should only run on certain days of the _week_) [2.1]. +;; +;; The returned procedure itself:- +;; +;; Starts by obtaining the current broken-down time [4], and fixing it to +;; ensure that it is an acceptable value, as follows. Each component from the +;; biggest down is checked for acceptability, and if it is not acceptable it +;; is bumped to the next acceptable value (this may cause higher components to +;; also be bumped if there is range wrap-around) and all the lower components +;; are set to -1 so that it can successfully be bumped up to zero if this is +;; an allowed value. The -1 value will be bumped up subsequently to an allowed +;; value [5]. +;; +;; Once it has been asserted that the current time is acceptable, or has been +;; adjusted to one minute before the next acceptable time, the minute +;; component is then bumped to the next acceptable time, which may ripple +;; through the higher components if necessary [6]. We now have the next time +;; the command needs to run. +;; +;; The new time is then converted back into a UNIX time and returned [7]. + +(define (parse-vixie-time string) + (let ((tokens (string-tokenize (vixie-substitute-parse-symbols string)))) + (cond + ((> (length tokens) 5) + (throw 'mcron-error 9 + "Too many fields in Vixie-style time specification")) + ((< (length tokens) 5) + (throw 'mcron-error 9 + "Not enough fields in Vixie-style time specification"))) + (let ((time-spec-list + (map-in-order (lambda (x) (vector + (let* ((n (vector-ref x 0)) + (tok (list-ref tokens n))) + (cond + ((and (= n 4) + (string=? tok "*") + (not (string=? + (list-ref tokens 2) "*"))) + '()) + ((and (= n 2) + (string=? tok "*") + (not (string=? + (list-ref tokens 4) "*"))) + '()) + (else + (parse-vixie-element + tok + (vector-ref x 1) + (vector-ref x 2))))) ; [0] + (vector-ref x 3) + (vector-ref x 4))) + ;; token range-top+1 getter setter + `( #( 0 0 60 ,tm:min ,set-tm:min ) + #( 1 0 24 ,tm:hour ,set-tm:hour ) + #( 2 1 32 ,tm:mday ,set-tm:mday ) + #( 3 0 12 ,tm:mon ,set-tm:mon ) + #( 4 0 7 ,tm:wday ,set-tm:wday ))))) ;; [1] + + (vector-set! (car (last-pair time-spec-list)) + 0 + (map (lambda (time-spec) + (if (eqv? time-spec 7) 0 time-spec)) + (vector-ref (car (last-pair time-spec-list)) 0))) ;; [2] + + (vector-set! (caddr time-spec-list) + 0 + (remove (lambda (day) (eqv? day 0)) + (vector-ref (caddr time-spec-list) 0))) ;; [2.1] + + + (lambda (current-time) ;; [3] + (let ((time (localtime current-time))) ;; [4] + + (if (not (member (tm:mon time) + (time-spec:list (cadddr time-spec-list)))) + (begin + (nudge-month! time (cdddr time-spec-list)) + (set-tm:mday time 0))) + (if (or (eqv? (tm:mday time) 0) + (not (member (tm:mday time) + (interpolate-weekdays + (time-spec:list (caddr time-spec-list)) + (time-spec:list (caddr (cddr time-spec-list))) + (tm:mon time) + (tm:year time))))) + (begin + (nudge-day! time (cddr time-spec-list)) + (set-tm:hour time -1))) + (if (not (member (tm:hour time) + (time-spec:list (cadr time-spec-list)))) + (begin + (nudge-hour! time (cdr time-spec-list)) + (set-tm:min time -1))) ;; [5] + + (set-tm:sec time 0) + (nudge-min! time time-spec-list) ;; [6] + (car (mktime time))))))) ;; [7] + + -- cgit v1.2.3