AboutSummaryRefsLogTreeCommitDiffStats
path: root/scm/mcron/redirect.scm
diff options
context:
space:
mode:
authorMathieu Lirzin <mthl@gnu.org>2016-05-07 11:09:44 +0200
committerMathieu Lirzin <mthl@gnu.org>2016-05-07 23:38:53 +0200
commit995bc9ca6ebf6880d7e7e6f3d1baa2941758fc47 (patch)
tree1f12ba3e4218d91a8736df5a5fa6eb82ffe39181 /scm/mcron/redirect.scm
parentbb8703b679509fe3b842f9f24f6871b3c2889916 (diff)
downloadmcron-995bc9ca6ebf6880d7e7e6f3d1baa2941758fc47.tar.gz
mcron-995bc9ca6ebf6880d7e7e6f3d1baa2941758fc47.tar.bz2
mcron-995bc9ca6ebf6880d7e7e6f3d1baa2941758fc47.zip
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.
Diffstat (limited to 'scm/mcron/redirect.scm')
-rw-r--r--scm/mcron/redirect.scm190
1 files changed, 0 insertions, 190 deletions
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 <http://www.gnu.org/licenses/>.
-
-
-
-;; 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)))