code.delx.au - gnu-emacs/blob - lisp/mail/mailpost.el

   1 ;;; mailpost.el --- RMAIL coupler to /usr/uci/post mailer
   2
   3 ;; Author: Gary Delp <delp@huey.Udel.Edu>
   4 ;; Maintainer: FSF
   5 ;; Created: 13 Jan 1986
   6 ;; Last-Modified: 30 May 1992
   7
   8 ;; This is in the public domain
   9 ;; since Delp distributed it without a copyright notice in 1986.
  10
  11 ;;; Commentary:
  12
  13 ;; Yet another mail interface.  this for the rmail system to provide
  14 ;;  the missing sendmail interface on systems without /usr/lib/sendmail,
  15 ;;   but with /usr/uci/post.
  16
  17 ;;; Code:
  18
  19 ;; (setq send-mail-function 'post-mail-send-it)
  20
  21 (defun post-mail-send-it ()
  22   "The MH -post interface for `rmail-mail' to call.
  23 To use it, include \"(setq send-mail-function 'post-mail-send-it)\" in
  24 site-init."
  25   (let ((errbuf (if mail-interactive
  26                     (generate-new-buffer " post-mail errors")
  27                   0))
  28         (temfile "/tmp/,rpost")
  29         (tembuf (generate-new-buffer " post-mail temp"))
  30         (case-fold-search nil)
  31         delimline
  32         (mailbuf (current-buffer)))
  33     (unwind-protect
  34         (save-excursion
  35           (set-buffer tembuf)
  36           (erase-buffer)
  37           (insert-buffer-substring mailbuf)
  38           (goto-char (point-max))
  39           ;; require one newline at the end.
  40           (or (= (preceding-char) ?\n)
  41               (insert ?\n))
  42           ;; Change header-delimiter to be what post-mail expects.
  43           (goto-char (point-min))
  44           (search-forward (concat "\n" mail-header-separator "\n"))
  45           (replace-match "\n\n")
  46           (backward-char 1)
  47           (setq delimline (point-marker))
  48           (if mail-aliases
  49               (expand-mail-aliases (point-min) delimline))
  50           (goto-char (point-min))
  51           ;; ignore any blank lines in the header
  52           (while (and (re-search-forward "\n\n\n*" delimline t)
  53                       (< (point) delimline))
  54             (replace-match "\n"))
  55           ;; Find and handle any FCC fields.
  56           (let ((case-fold-search t))
  57             (goto-char (point-min))
  58             (if (re-search-forward "^FCC:" delimline t)
  59                 (mail-do-fcc delimline))
  60             ;; If there is a From and no Sender, put it a Sender.
  61             (goto-char (point-min))
  62             (and (re-search-forward "^From:"  delimline t)
  63                  (not (save-excursion
  64                         (goto-char (point-min))
  65                         (re-search-forward "^Sender:" delimline t)))
  66                  (progn
  67                    (forward-line 1)
  68                    (insert "Sender: " (user-login-name) "\n")))
  69             ;; don't send out a blank subject line
  70             (goto-char (point-min))
  71             (if (re-search-forward "^Subject:[ \t]*\n" delimline t)
  72                 (replace-match ""))
  73             (if mail-interactive
  74                 (save-excursion
  75                   (set-buffer errbuf)
  76                   (erase-buffer))))
  77           (write-file (setq temfile (make-temp-name temfile)))
  78           (set-file-modes temfile 384)
  79           (apply 'call-process
  80                  (append (list (if (boundp 'post-mail-program)
  81                                    post-mail-program
  82                                  "/usr/uci/lib/mh/post")
  83                                nil errbuf nil
  84                                "-nofilter" "-msgid")
  85                          (if mail-interactive '("-watch") '("-nowatch"))
  86                          (list temfile)))
  87           (if mail-interactive
  88               (save-excursion
  89                 (set-buffer errbuf)
  90                 (goto-char (point-min))
  91                 (while (re-search-forward "\n\n* *" nil t)
  92                   (replace-match "; "))
  93                 (if (not (zerop (buffer-size)))
  94                     (error "Sending...failed to %s"
  95                            (buffer-substring (point-min) (point-max)))))))
  96       (kill-buffer tembuf)
  97       (if (bufferp errbuf)
  98           (switch-to-buffer errbuf)))))
  99
 100 ;;; mailpost.el ends here