mail/smtpmail.el

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