lisp/mail/mailpost.el

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