smtpmail.el

   1 ;;; smtpmail.el --- simple SMTP protocol (RFC 821) for sending mail
   2
   3 ;; Copyright (C) 1995, 1996 Free Software Foundation, Inc.
   4
   5 ;; Author: Tomoji Kagatani <kagatani@rbc.ncl.omron.co.jp>
   6 ;; Maintainer: Brian D. Carlstrom <bdc@ai.mit.edu>
   7 ;; ESMTP support: Simon Leinen <simon@switch.ch>
   8 ;; Keywords: mail
   9
  10 ;; This file is part of GNU Emacs.
  11
  12 ;; GNU Emacs is free software; you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation; either version 2, or (at your option)
  15 ;; any later version.
  16
  17 ;; GNU Emacs is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  24 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  25 ;; Boston, MA 02111-1307, USA.
  26
  27 ;;; Commentary:
  28
  29 ;; Send Mail to smtp host from smtpmail temp buffer.
  30
  31 ;; Please add these lines in your .emacs(_emacs).
  32 ;;
  33 ;;(setq send-mail-function 'smtpmail-send-it)
  34 ;;(setq smtp-default-server "YOUR SMTP HOST")
  35 ;;(setq smtp-service "smtp")
  36 ;;(setq smtp-local-domain "YOUR DOMAIN NAME")
  37 ;;(setq smtp-debug-info t)
  38 ;;(autoload 'smtpmail-send-it "smtpmail")
  39 ;;(setq user-full-name "YOUR NAME HERE")
  40
  41 ;; To queue mail, set smtpmail-queue-mail to t and use
  42 ;; smtpmail-send-queued-mail to send.
  43
  44
  45 ;;; Code:
  46
  47 (require 'smtp)
  48 (require 'sendmail)
  49 (require 'time-stamp)
  50
  51 ;;;
  52
  53 (defcustom smtpmail-queue-mail nil
  54   "*Specify if mail is queued (if t) or sent immediately (if nil).
  55 If queued, it is stored in the directory `smtpmail-queue-dir'
  56 and sent with `smtpmail-send-queued-mail'."
  57   :type 'boolean
  58   :group 'smtp)
  59
  60 (defcustom smtpmail-queue-dir "~/Mail/queued-mail/"
  61   "*Directory where `smtpmail.el' stores queued mail."
  62   :type 'directory
  63   :group 'smtp)
  64
  65 (defvar smtpmail-queue-index-file "index"
  66   "File name of queued mail index,
  67 This is relative to `smtpmail-queue-dir'.")
  68
  69 (defvar smtpmail-queue-index (concat smtpmail-queue-dir
  70                                      smtpmail-queue-index-file))
  71
  72 (defvar smtpmail-recipient-address-list nil)
  73
  74
  75 ;;;
  76 ;;;
  77 ;;;
  78
  79 ;;;###autoload
  80 (defun smtpmail-send-it ()
  81   (require 'mail-utils)
  82   (let ((errbuf (if mail-interactive
  83                     (generate-new-buffer " smtpmail errors")
  84                   0))
  85         (tembuf (generate-new-buffer " smtpmail temp"))
  86         (case-fold-search nil)
  87         resend-to-addresses
  88         delimline
  89         (mailbuf (current-buffer)))
  90     (unwind-protect
  91         (save-excursion
  92           (set-buffer tembuf)
  93           (erase-buffer)
  94           (insert-buffer-substring mailbuf)
  95           (goto-char (point-max))
  96           ;; require one newline at the end.
  97           (or (= (preceding-char) ?\n)
  98               (insert ?\n))
  99           ;; Change header-delimiter to be what sendmail expects.
 100           (goto-char (point-min))
 101           (re-search-forward
 102             (concat "^" (regexp-quote mail-header-separator) "\n"))
 103           (replace-match "\n")
 104           (backward-char 1)
 105           (setq delimline (point-marker))
 106 ;;        (sendmail-synch-aliases)
 107           (if mail-aliases
 108               (expand-mail-aliases (point-min) delimline))
 109           (goto-char (point-min))
 110           ;; ignore any blank lines in the header
 111           (while (and (re-search-forward "\n\n\n*" delimline t)
 112                       (< (point) delimline))
 113             (replace-match "\n"))
 114           (let ((case-fold-search t))
 115             (goto-char (point-min))
 116             (goto-char (point-min))
 117             (while (re-search-forward "^Resent-to:" delimline t)
 118               (setq resend-to-addresses
 119                     (save-restriction
 120                       (narrow-to-region (point)
 121                                         (save-excursion
 122                                           (end-of-line)
 123                                           (point)))
 124                       (append (mail-parse-comma-list)
 125                               resend-to-addresses))))
 126 ;;; Apparently this causes a duplicate Sender.
 127 ;;;         ;; If the From is different than current user, insert Sender.
 128 ;;;         (goto-char (point-min))
 129 ;;;         (and (re-search-forward "^From:"  delimline t)
 130 ;;;              (progn
 131 ;;;                (require 'mail-utils)
 132 ;;;                (not (string-equal
 133 ;;;                      (mail-strip-quoted-names
 134 ;;;                       (save-restriction
 135 ;;;                         (narrow-to-region (point-min) delimline)
 136 ;;;                         (mail-fetch-field "From")))
 137 ;;;                      (user-login-name))))
 138 ;;;              (progn
 139 ;;;                (forward-line 1)
 140 ;;;                (insert "Sender: " (user-login-name) "\n")))
 141             ;; Don't send out a blank subject line
 142             (goto-char (point-min))
 143             (if (re-search-forward "^Subject:[ \t]*\n" delimline t)
 144                 (replace-match ""))
 145             ;; Put the "From:" field in unless for some odd reason
 146             ;; they put one in themselves.
 147             (goto-char (point-min))
 148             (if (not (re-search-forward "^From:" delimline t))
 149                 (let* ((login user-mail-address)
 150                        (fullname (user-full-name)))
 151                   (cond ((eq mail-from-style 'angles)
 152                          (insert "From: " fullname)
 153                          (let ((fullname-start (+ (point-min) 6))
 154                                (fullname-end (point-marker)))
 155                            (goto-char fullname-start)
 156                            ;; Look for a character that cannot appear unquoted
 157                            ;; according to RFC 822.
 158                            (if (re-search-forward "[^- !#-'*+/-9=?A-Z^-~]"
 159                                                   fullname-end 1)
 160                                (progn
 161                                  ;; Quote fullname, escaping specials.
 162                                  (goto-char fullname-start)
 163                                  (insert "\"")
 164                                  (while (re-search-forward "[\"\\]"
 165                                                            fullname-end 1)
 166                                    (replace-match "\\\\\\&" t))
 167                                  (insert "\""))))
 168                          (insert " <" login ">\n"))
 169                         ((eq mail-from-style 'parens)
 170                          (insert "From: " login " (")
 171                          (let ((fullname-start (point)))
 172                            (insert fullname)
 173                            (let ((fullname-end (point-marker)))
 174                              (goto-char fullname-start)
 175                              ;; RFC 822 says \ and nonmatching parentheses
 176                              ;; must be escaped in comments.
 177                              ;; Escape every instance of ()\ ...
 178                              (while (re-search-forward "[()\\]" fullname-end 1)
 179                                (replace-match "\\\\\\&" t))
 180                              ;; ... then undo escaping of matching parentheses,
 181                              ;; including matching nested parentheses.
 182                              (goto-char fullname-start)
 183                              (while (re-search-forward
 184                                      "\\(\\=\\|[^\\]\\(\\\\\\\\\\)*\\)\\\\(\\(\\([^\\]\\|\\\\\\\\\\)*\\)\\\\)"
 185                                      fullname-end 1)
 186                                (replace-match "\\1(\\3)" t)
 187                                (goto-char fullname-start))))
 188                          (insert ")\n"))
 189                         ((null mail-from-style)
 190                          (insert "From: " login "\n")))))
 191             ;; Insert an extra newline if we need it to work around
 192             ;; Sun's bug that swallows newlines.
 193             (goto-char (1+ delimline))
 194             (if (eval mail-mailer-swallows-blank-line)
 195                 (newline))
 196             ;; Find and handle any FCC fields.
 197             (goto-char (point-min))
 198             (if (re-search-forward "^FCC:" delimline t)
 199                 (mail-do-fcc delimline))
 200             (if mail-interactive
 201                 (save-excursion
 202                   (set-buffer errbuf)
 203                   (erase-buffer))))
 204           ;;
 205           ;;
 206           ;;
 207           (setq smtpmail-recipient-address-list
 208                 (or resend-to-addresses
 209                     (smtp-deduce-address-list tembuf (point-min) delimline)))
 210
 211           (smtpmail-do-bcc delimline)
 212           ; Send or queue
 213           (if (not smtpmail-queue-mail)
 214               (if smtpmail-recipient-address-list
 215                   (if (not (smtp-via-smtp user-mail-address
 216                                           smtpmail-recipient-address-list
 217                                           tembuf))
 218                       (error "Sending failed; SMTP protocol error"))
 219                 (error "Sending failed; no recipients"))
 220             (let* ((file-data (concat
 221                                smtpmail-queue-dir
 222                                (time-stamp-strftime
 223                                 "%02y%02m%02d-%02H%02M%02S")))
 224                    (file-elisp (concat file-data ".el"))
 225                    (buffer-data (create-file-buffer file-data))
 226                    (buffer-elisp (create-file-buffer file-elisp))
 227                    (buffer-scratch "*queue-mail*"))
 228               (save-excursion
 229                 (set-buffer buffer-data)
 230                 (erase-buffer)
 231                 (insert-buffer tembuf)
 232                 (write-file file-data)
 233                 (set-buffer buffer-elisp)
 234                 (erase-buffer)
 235                 (insert (concat
 236                          "(setq smtpmail-recipient-address-list '"
 237                          (prin1-to-string smtpmail-recipient-address-list)
 238                          ")\n"))
 239                 (write-file file-elisp)
 240                 (set-buffer (generate-new-buffer buffer-scratch))
 241                 (insert (concat file-data "\n"))
 242                 (append-to-file (point-min)
 243                                 (point-max)
 244                                 smtpmail-queue-index)
 245                 )
 246               (kill-buffer buffer-scratch)
 247               (kill-buffer buffer-data)
 248               (kill-buffer buffer-elisp))))
 249       (kill-buffer tembuf)
 250       (if (bufferp errbuf)
 251           (kill-buffer errbuf)))))
 252
 253 (defun smtpmail-send-queued-mail ()
 254   "Send mail that was queued as a result of setting `smtpmail-queue-mail'."
 255   (interactive)
 256   ;;; Get index, get first mail, send it, get second mail, etc...
 257   (let ((buffer-index (find-file-noselect smtpmail-queue-index))
 258         (file-msg "")
 259         (tembuf nil))
 260     (save-excursion
 261       (set-buffer buffer-index)
 262       (beginning-of-buffer)
 263       (while (not (eobp))
 264         (setq file-msg (buffer-substring (point) (save-excursion
 265                                                    (end-of-line)
 266                                                    (point))))
 267         (load file-msg)
 268         (setq tembuf (find-file-noselect file-msg))
 269         (if smtpmail-recipient-address-list
 270             (if (not (smtp-via-smtp user-mail-address
 271                                     smtpmail-recipient-address-list tembuf))
 272                 (error "Sending failed; SMTP protocol error"))
 273           (error "Sending failed; no recipients"))
 274         (delete-file file-msg)
 275         (delete-file (concat file-msg ".el"))
 276         (kill-buffer tembuf)
 277         (kill-line 1))
 278       (set-buffer buffer-index)
 279       (save-buffer smtpmail-queue-index)
 280       (kill-buffer buffer-index)
 281       )))
 282
 283
 284 (defun smtpmail-do-bcc (header-end)
 285   "Delete BCC: and their continuation lines from the header area.
 286 There may be multiple BCC: lines, and each may have arbitrarily
 287 many continuation lines."
 288   (let ((case-fold-search t))
 289     (save-excursion
 290       (goto-char (point-min))
 291       ;; iterate over all BCC: lines
 292       (while (re-search-forward "^BCC:" header-end t)
 293         (delete-region (match-beginning 0) (progn (forward-line 1) (point)))
 294         ;; get rid of any continuation lines
 295         (while (and (looking-at "^[ \t].*\n") (< (point) header-end))
 296           (replace-match ""))
 297         )
 298       ) ;; save-excursion
 299     ) ;; let
 300   )
 301
 302
 303 ;;;
 304
 305 (provide 'smtpmail)
 306
 307 ;;; smtpmail.el ends here