home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 5 Edit / 05-Edit.zip / emacmail.zip / sendmail-os2.el < prev    next >
Lisp/Scheme  |  1993-08-07  |  5KB  |  151 lines
  1. ;; Mail sending commands for Emacs.  
  2.  
  3. ;; Copyright (C) 1992, 1993 Stuart Wilson.
  4.  
  5. ;; This file is part of GNU Emacs.
  6.  
  7. ;; GNU Emacs is free software; you can redistribute it and/or modify
  8. ;; it under the terms of the GNU General Public License as published by
  9. ;; the Free Software Foundation; either version 1, or (at your option)
  10. ;; any later version.
  11.  
  12. ;; GNU Emacs is distributed in the hope that it will be useful,
  13. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  14. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15. ;; GNU General Public License for more details.
  16.  
  17. ;; You should have received a copy of the GNU General Public License
  18. ;; along with GNU Emacs; see the file COPYING.  If not, write to
  19. ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  20.  
  21.  
  22. ;; This file contains the modifications to sendmail.el, that are required  
  23. to 
  24.  
  25. ;; make the sendmail E-lisp code work on a PC running OS/2 v2.0
  26. ;;
  27. ;; It uses C:\TCPIP\BIN\SENDMAIL.EXE from IBM TCP/IP v1.2
  28. ;;
  29. ;;        Stuart Wilson
  30. ;;        stuartw@pec.co.nz
  31. ;;        23 July 1992.
  32.  
  33.  
  34. ;; First of all load the original sendmail.el
  35. (load-library "sendmail")
  36.  
  37.  
  38. ;; It won't work unless this is set to true
  39. (setq mail-interactive t)
  40.  
  41. ;;
  42. ;; Now replace a couple of functions to make it work under OS/2
  43. ;;
  44. (defun mail-send ()
  45.   "Send the message in the current buffer."
  46.   (interactive)
  47.   (message "Sending...")
  48.   (if (sendmail-send-it)
  49.       (message "Sending...done"))
  50.   (set-buffer-modified-p nil)
  51.   (delete-auto-save-file-if-necessary))
  52.  
  53.  
  54. (defun sendmail-send-it ()
  55.   (let ((errbuf (if mail-interactive
  56.             (generate-new-buffer "*sendmail-errors*")
  57.           0))
  58.     (tembuf (generate-new-buffer " sendmail temp"))
  59.     (case-fold-search nil)
  60.     delimline
  61.     (mailbuf (current-buffer)))
  62.     (unwind-protect
  63.     (save-excursion
  64.       (set-buffer tembuf)
  65.       (setq buffer-undo-list t)
  66.       (erase-buffer)
  67.       (insert-buffer-substring mailbuf)
  68.       (goto-char (point-max))
  69.       ;; require one newline at the end.
  70.       (or (= (preceding-char) ?\n)
  71.           (insert ?\n))
  72.       ;; Change header-delimiter to be what sendmail expects.
  73.       (goto-char (point-min))
  74.       (re-search-forward
  75.         (concat "^" (regexp-quote mail-header-separator) "\n"))
  76.       (replace-match "\n")
  77.       (backward-char 1)
  78.       (setq delimline (point-marker))
  79.       (if mail-aliases
  80.           (expand-mail-aliases (point-min) delimline))
  81.       (goto-char (point-min))
  82.       ;; ignore any blank lines in the header
  83.       (while (and (re-search-forward "\n\n\n*" delimline t)
  84.               (< (point) delimline))
  85.         (replace-match "\n"))
  86.       (let ((case-fold-search t))
  87.         ;; Find and handle any FCC fields.
  88.         (goto-char (point-min))
  89.         (if (re-search-forward "^FCC:" delimline t)
  90.         (mail-do-fcc delimline))
  91.         ;; If there is a From and no Sender, put in a Sender.
  92.         (goto-char (point-min))
  93.         (and (re-search-forward "^From:"  delimline t)
  94.          (not (save-excursion
  95.             (goto-char (point-min))
  96.             (re-search-forward "^Sender:" delimline t)))
  97.          (progn
  98.            (forward-line 1)
  99.            (insert "Sender: " (getenv "USER") "@" (getenv  
  100. "HOSTNAME") "\n")))
  101.         ;; don't send out a blank subject line
  102.         (goto-char (point-min))
  103.         (if (re-search-forward "^Subject:[ \t]*\n" delimline t)
  104.         (replace-match ""))
  105.         (if mail-interactive
  106.         (save-excursion
  107.           (set-buffer errbuf)
  108.           (erase-buffer))))
  109.  
  110.       ;;
  111.       ;; Now the changes to make it work under OS/2.
  112.       ;;     --- stuartw@pec.co.nz
  113.  
  114.       (let ((tmp-fname (make-temp-name "smail"))
  115.         (to (mail-extract-to)))
  116.         (if (string= to "")
  117.         (message "Sending... failed -- No \"To:\" Address")
  118.           (message (concat "Sending... to " to))
  119.           (write-region (point-min) (point-max) tmp-fname nil 0)
  120.           (call-process "c:/tcpip/bin/sendmail.exe"
  121.                 nil errbuf nil
  122.                 "-af" tmp-fname
  123.                 "-f" (concat (getenv "USER") "@" (getenv  
  124. "HOSTNAME"))
  125.                 to)
  126.           (message "Sending... done")
  127.           (delete-file tmp-fname))))
  128.       (kill-buffer tembuf)
  129.       (if (bufferp errbuf)
  130.       (kill-buffer errbuf)))))
  131.  
  132.  
  133. ;; IBM sendmail for OS/2 requires the To address to be on the command
  134. ;; line, which means we have to extract it from the message header.
  135.  
  136. (defun mail-extract-to ()
  137.    (save-excursion
  138.      (goto-char (point-min))
  139.      (let ((start
  140.           (if (not (re-search-forward "^To:" (point-max) t))
  141.           nil
  142.         (skip-chars-forward " \t")
  143.         (point)))
  144.        (end
  145.         (progn
  146.           (end-of-line)
  147.           (skip-chars-backward " \t\n")
  148.           (point))))
  149.        (if start
  150.        (buffer-substring start end)
  151.      ""))))