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