From 61f85be19da0e62c899e3b62da403480d881e9f9 Mon Sep 17 00:00:00 2001 From: Mathieu Lirzin Date: Sat, 23 Jul 2016 23:58:06 +0200 Subject: build: Rename (mcron main) to (mcron utils). * src/mcron/main.scm: Rename to ... * src/mcron/utils.scm: ... this. * src/mcron/scripts/cron.scm: Adapt. * src/mcron/scripts/crontab.scm: Likewise. * src/mcron/scripts/mcron.scm: Likewise. * Makefile.am (dist_mcronmodule_DATA): Likewise. --- src/mcron/utils.scm | 119 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 119 insertions(+) create mode 100644 src/mcron/utils.scm (limited to 'src/mcron/utils.scm') diff --git a/src/mcron/utils.scm b/src/mcron/utils.scm new file mode 100644 index 0000000..7b29971 --- /dev/null +++ b/src/mcron/utils.scm @@ -0,0 +1,119 @@ +;;;; utils.scm -- helper procedures +;;; Copyright © 2003, 2012 Dale Mellor +;;; Copyright © 2015, 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 . + +(define-module (mcron utils) + #:use-module (ice-9 getopt-long) + #:use-module (ice-9 rdelim) + #:use-module (mcron config) + #:use-module (mcron base) + #:use-module (mcron job-specifier) + #:use-module (mcron vixie-specification) + #:export (catch-mcron-error + mcron-error + parse-args + show-version + show-package-information + stdin->string + for-each-file + process-update-request) + #:re-export (option-ref)) + +(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 (cons "mcron: " 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 (parse-args args option-desc-list) + "Parse ARGS with OPTION-DESC-LIST specification." + (catch 'misc-error + (lambda () (getopt-long args option-desc-list)) + (lambda (key func fmt args . rest) + (mcron-error 1 (apply format (append (list #f fmt) args)))))) + +(define (show-version command) + "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))) + +(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 (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-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))))))) -- cgit v1.2.3 From 2d6c072b47a72f9152b2d43d0ffa42f413f15713 Mon Sep 17 00:00:00 2001 From: Mathieu Lirzin Date: Sun, 24 Jul 2016 00:26:20 +0200 Subject: utils: for-each-file: Use named let. * src/mcron/utils.scm (for-each-file): Use named 'let' instead of 'do'. --- src/mcron/utils.scm | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) (limited to 'src/mcron/utils.scm') diff --git a/src/mcron/utils.scm b/src/mcron/utils.scm index 7b29971..ce2610c 100644 --- a/src/mcron/utils.scm +++ b/src/mcron/utils.scm @@ -92,9 +92,12 @@ General help using GNU software: \n" 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)))) + (let loop ((file-name (readdir dir))) + (if (eof-object? file-name) + (closedir dir) + (begin + (proc file-name) + (loop (readdir dir))))))) (define (process-update-request fdes-list) "Read a user name from the socket, dealing with the /etc/crontab special -- cgit v1.2.3 From d4b4ac5708385d500f566267719124c7c62572df Mon Sep 17 00:00:00 2001 From: Mathieu Lirzin Date: Sun, 24 Jul 2016 00:38:21 +0200 Subject: utils: Remove unneeded 'stdin->string' procedure. * src/mcron/utils.scm: Re-export 'read-string'. (stdin->string): Delete. * src/mcron/scripts/crontab.scm (main): Use 'read-string' instead. * src/mcron/scripts/mcron.scm (process-user-file): Likewise. --- src/mcron/scripts/crontab.scm | 2 +- src/mcron/scripts/mcron.scm | 2 +- src/mcron/utils.scm | 10 ++-------- 3 files changed, 4 insertions(+), 10 deletions(-) (limited to 'src/mcron/utils.scm') diff --git a/src/mcron/scripts/crontab.scm b/src/mcron/scripts/crontab.scm index cf6673a..502fec6 100644 --- a/src/mcron/scripts/crontab.scm +++ b/src/mcron/scripts/crontab.scm @@ -210,7 +210,7 @@ (let ((input-file (car (option-ref opts '() '())))) (catch-mcron-error (if (string=? input-file "-") - (let ((input-string (stdin->string))) + (let ((input-string (read-string))) (read-vixie-port (open-input-string input-string)) (with-output-to-file crontab-file (λ () (display input-string)))) diff --git a/src/mcron/scripts/mcron.scm b/src/mcron/scripts/mcron.scm index 7b82cf3..b6c7729 100644 --- a/src/mcron/scripts/mcron.scm +++ b/src/mcron/scripts/mcron.scm @@ -63,7 +63,7 @@ silently ignored." (cond ((string=? "-" file-name) (if (string=? input "vixie") (read-vixie-port (current-input-port)) - (eval-string (stdin->string)))) + (eval-string (read-string)))) ((or guile-syntax? (regexp-exec guile-regexp file-name)) (load file-name)) ((regexp-exec vixie-regexp file-name) diff --git a/src/mcron/utils.scm b/src/mcron/utils.scm index ce2610c..062e756 100644 --- a/src/mcron/utils.scm +++ b/src/mcron/utils.scm @@ -29,10 +29,10 @@ parse-args show-version show-package-information - stdin->string for-each-file process-update-request) - #:re-export (option-ref)) + #:re-export (option-ref + read-string)) (define (mcron-error exit-code . rest) "Print an error message (made up from the parts of REST), and if the @@ -81,12 +81,6 @@ General help using GNU software: \n" config-package-name config-package-url)) -(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 -- cgit v1.2.3