code.delx.au - gnu-emacs/blob - lisp/mail/smtpmail.el

   1 ;;; smtpmail.el --- simple SMTP protocol (RFC 821) for sending mail
   2
   3 ;; Copyright (C) 1995-1996, 2001-2011  Free Software Foundation, Inc.
   4
   5 ;; Author: Tomoji Kagatani <kagatani@rbc.ncl.omron.co.jp>
   6 ;; Maintainer: Simon Josefsson <simon@josefsson.org>
   7 ;; w32 Maintainer: Brian D. Carlstrom <bdc@ai.mit.edu>
   8 ;; ESMTP support: Simon Leinen <simon@switch.ch>
   9 ;; Hacked by Mike Taylor, 11th October 1999 to add support for
  10 ;; automatically appending a domain to RCPT TO: addresses.
  11 ;; AUTH=LOGIN support: Stephen Cranefield <scranefield@infoscience.otago.ac.nz>
  12 ;; Keywords: mail
  13
  14 ;; This file is part of GNU Emacs.
  15
  16 ;; GNU Emacs is free software: you can redistribute it and/or modify
  17 ;; it under the terms of the GNU General Public License as published by
  18 ;; the Free Software Foundation, either version 3 of the License, or
  19 ;; (at your option) any later version.
  20
  21 ;; GNU Emacs is distributed in the hope that it will be useful,
  22 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  23 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  24 ;; GNU General Public License for more details.
  25
  26 ;; You should have received a copy of the GNU General Public License
  27 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  28
  29 ;;; Commentary:
  30
  31 ;; Send Mail to smtp host from smtpmail temp buffer.
  32
  33 ;; Please add these lines in your .emacs(_emacs) or use customize.
  34 ;;
  35 ;;(setq send-mail-function 'smtpmail-send-it) ; if you use `mail'
  36 ;;(setq message-send-mail-function 'smtpmail-send-it) ; if you use message/Gnus
  37 ;;(setq smtpmail-smtp-server "YOUR SMTP HOST")
  38 ;;(setq smtpmail-local-domain "YOUR DOMAIN NAME")
  39 ;;(setq smtpmail-sendto-domain "YOUR DOMAIN NAME")
  40 ;;(setq smtpmail-debug-info t) ; only to debug problems
  41
  42 ;; To queue mail, set `smtpmail-queue-mail' to t and use
  43 ;; `smtpmail-send-queued-mail' to send.
  44
  45 ;; Modified by Stephen Cranefield <scranefield@infoscience.otago.ac.nz>,
  46 ;; 22/6/99, to support SMTP Authentication by the AUTH=LOGIN mechanism.
  47 ;; See http://help.netscape.com/products/server/messaging/3x/info/smtpauth.html
  48 ;; Rewritten by Simon Josefsson to use same credential variable as AUTH
  49 ;; support below.
  50
  51 ;; Modified by Simon Josefsson <jas@pdc.kth.se>, 22/2/99, to support SMTP
  52 ;; Authentication by the AUTH mechanism.
  53 ;; See http://www.ietf.org/rfc/rfc2554.txt
  54
  55 ;;; Code:
  56
  57 (require 'sendmail)
  58 (require 'auth-source)
  59 (autoload 'mail-strip-quoted-names "mail-utils")
  60 (autoload 'message-make-date "message")
  61 (autoload 'message-make-message-id "message")
  62 (autoload 'rfc2104-hash "rfc2104")
  63 (autoload 'password-read "password-cache")
  64
  65 ;;;
  66 (defgroup smtpmail nil
  67   "SMTP protocol for sending mail."
  68   :group 'mail)
  69
  70
  71 (defcustom smtpmail-default-smtp-server nil
  72   "Specify default SMTP server.
  73 This only has effect if you specify it before loading the smtpmail library."
  74   :type '(choice (const nil) string)
  75   :group 'smtpmail)
  76
  77 (defcustom smtpmail-smtp-server
  78   (or (getenv "SMTPSERVER") smtpmail-default-smtp-server)
  79   "The name of the host running SMTP server."
  80   :type '(choice (const nil) string)
  81   :group 'smtpmail)
  82
  83 (defcustom smtpmail-smtp-service 25
  84   "SMTP service port number.
  85 The default value would be \"smtp\" or 25."
  86   :type '(choice (integer :tag "Port") (string :tag "Service"))
  87   :group 'smtpmail)
  88
  89 (defcustom smtpmail-smtp-user nil
  90   "User name to use when looking up credentials."
  91   :version "24.1"
  92   :type '(choice (const nil) string)
  93   :group 'smtpmail)
  94
  95 (defcustom smtpmail-local-domain nil
  96   "Local domain name without a host name.
  97 If the function `system-name' returns the full internet address,
  98 don't define this value."
  99   :type '(choice (const nil) string)
 100   :group 'smtpmail)
 101
 102 (defcustom smtpmail-stream-type nil
 103   "Connection type SMTP connections.
 104 This may be either nil (possibly upgraded to STARTTLS if
 105 possible), or `starttls' (refuse to send if STARTTLS isn't
 106 available), or `plain' (never use STARTTLS).."
 107   :version "24.1"
 108   :group 'smtpmail
 109   :type '(choice (const :tag "Possibly upgrade to STARTTLS" nil)
 110                  (const :tag "Always use STARTTLS" starttls)
 111                  (const :tag "Never use STARTTLS" plain)))
 112
 113 (defcustom smtpmail-sendto-domain nil
 114   "Local domain name without a host name.
 115 This is appended (with an @-sign) to any specified recipients which do
 116 not include an @-sign, so that each RCPT TO address is fully qualified.
 117 \(Some configurations of sendmail require this.)
 118
 119 Don't bother to set this unless you have get an error like:
 120         Sending failed; 501 <someone>: recipient address must contain a domain."
 121   :type '(choice (const nil) string)
 122   :group 'smtpmail)
 123
 124 (defcustom smtpmail-debug-info nil
 125   "Whether to print info in buffer *trace of SMTP session to <somewhere>*.
 126 See also `smtpmail-debug-verb' which determines if the SMTP protocol should
 127 be verbose as well."
 128   :type 'boolean
 129   :group 'smtpmail)
 130
 131 (defcustom smtpmail-debug-verb nil
 132   "Whether this library sends the SMTP VERB command or not.
 133 The commands enables verbose information from the SMTP server."
 134   :type 'boolean
 135   :group 'smtpmail)
 136
 137 (defcustom smtpmail-code-conv-from nil
 138   "Coding system for encoding outgoing mail.
 139 Used for the value of `sendmail-coding-system' when
 140 `select-message-coding-system' is called. "
 141   :type 'coding-system
 142   :group 'smtpmail)
 143
 144 (defcustom smtpmail-queue-mail nil
 145   "Non-nil means mail is queued; otherwise it is sent immediately.
 146 If queued, it is stored in the directory `smtpmail-queue-dir'
 147 and sent with `smtpmail-send-queued-mail'."
 148   :type 'boolean
 149   :group 'smtpmail)
 150
 151 (defcustom smtpmail-queue-dir "~/Mail/queued-mail/"
 152   "Directory where `smtpmail.el' stores queued mail."
 153   :type 'directory
 154   :group 'smtpmail)
 155
 156 (defcustom smtpmail-warn-about-unknown-extensions nil
 157   "If set, print warnings about unknown SMTP extensions.
 158 This is mainly useful for development purposes, to learn about
 159 new SMTP extensions that might be useful to support."
 160   :type 'boolean
 161   :version "21.1"
 162   :group 'smtpmail)
 163
 164 (defcustom smtpmail-queue-index-file "index"
 165   "File name of queued mail index.
 166 This is relative to `smtpmail-queue-dir'."
 167   :type 'string
 168   :group 'smtpmail)
 169
 170 ;; End of customizable variables.
 171
 172
 173 (defvar smtpmail-address-buffer)
 174 (defvar smtpmail-recipient-address-list)
 175
 176 (defvar smtpmail-queue-counter 0)
 177
 178 ;; Buffer-local variable.
 179 (defvar smtpmail-read-point)
 180
 181 (defconst smtpmail-auth-supported '(cram-md5 plain login)
 182   "List of supported SMTP AUTH mechanisms.
 183 The list is in preference order.")
 184
 185 (defvar smtpmail-mail-address nil
 186   "Value to use for envelope-from address for mail from ambient buffer.")
 187
 188 ;;;###autoload
 189 (defun smtpmail-send-it ()
 190   (let ((errbuf (if mail-interactive
 191                     (generate-new-buffer " smtpmail errors")
 192                   0))
 193         (tembuf (generate-new-buffer " smtpmail temp"))
 194         (case-fold-search nil)
 195         delimline
 196         result
 197         (mailbuf (current-buffer))
 198         ;; Examine this variable now, so that
 199         ;; local binding in the mail buffer will take effect.
 200         (smtpmail-mail-address
 201          (or (and mail-specify-envelope-from (mail-envelope-from))
 202              user-mail-address))
 203         (smtpmail-code-conv-from
 204          (if enable-multibyte-characters
 205              (let ((sendmail-coding-system smtpmail-code-conv-from))
 206                (select-message-coding-system)))))
 207     (unwind-protect
 208         (with-current-buffer tembuf
 209           (erase-buffer)
 210           ;; Use the same `buffer-file-coding-system' as in the mail
 211           ;; buffer, otherwise any `write-region' invocations (e.g., in
 212           ;; mail-do-fcc below) will annoy with asking for a suitable
 213           ;; encoding.
 214           (set-buffer-file-coding-system smtpmail-code-conv-from nil t)
 215           (insert-buffer-substring mailbuf)
 216           (goto-char (point-max))
 217           ;; require one newline at the end.
 218           (or (= (preceding-char) ?\n)
 219               (insert ?\n))
 220           ;; Change header-delimiter to be what sendmail expects.
 221           (mail-sendmail-undelimit-header)
 222           (setq delimline (point-marker))
 223           ;; (sendmail-synch-aliases)
 224           (if mail-aliases
 225               (expand-mail-aliases (point-min) delimline))
 226           (goto-char (point-min))
 227           ;; ignore any blank lines in the header
 228           (while (and (re-search-forward "\n\n\n*" delimline t)
 229                       (< (point) delimline))
 230             (replace-match "\n"))
 231           (let ((case-fold-search t))
 232             ;; We used to process Resent-... headers here,
 233             ;; but it was not done properly, and the job
 234             ;; is done correctly in `smtpmail-deduce-address-list'.
 235             ;; Don't send out a blank subject line
 236             (goto-char (point-min))
 237             (if (re-search-forward "^Subject:\\([ \t]*\n\\)+\\b" delimline t)
 238                 (replace-match "")
 239               ;; This one matches a Subject just before the header delimiter.
 240               (if (and (re-search-forward "^Subject:\\([ \t]*\n\\)+" delimline t)
 241                        (= (match-end 0) delimline))
 242                   (replace-match "")))
 243             ;; Put the "From:" field in unless for some odd reason
 244             ;; they put one in themselves.
 245             (goto-char (point-min))
 246             (if (not (re-search-forward "^From:" delimline t))
 247                 (let* ((login smtpmail-mail-address)
 248                        (fullname (user-full-name)))
 249                   (cond ((eq mail-from-style 'angles)
 250                          (insert "From: " fullname)
 251                          (let ((fullname-start (+ (point-min) 6))
 252                                (fullname-end (point-marker)))
 253                            (goto-char fullname-start)
 254                            ;; Look for a character that cannot appear unquoted
 255                            ;; according to RFC 822.
 256                            (if (re-search-forward "[^- !#-'*+/-9=?A-Z^-~]"
 257                                                   fullname-end 1)
 258                                (progn
 259                                  ;; Quote fullname, escaping specials.
 260                                  (goto-char fullname-start)
 261                                  (insert "\"")
 262                                  (while (re-search-forward "[\"\\]"
 263                                                            fullname-end 1)
 264                                    (replace-match "\\\\\\&" t))
 265                                  (insert "\""))))
 266                          (insert " <" login ">\n"))
 267                         ((eq mail-from-style 'parens)
 268                          (insert "From: " login " (")
 269                          (let ((fullname-start (point)))
 270                            (insert fullname)
 271                            (let ((fullname-end (point-marker)))
 272                              (goto-char fullname-start)
 273                              ;; RFC 822 says \ and nonmatching parentheses
 274                              ;; must be escaped in comments.
 275                              ;; Escape every instance of ()\ ...
 276                              (while (re-search-forward "[()\\]" fullname-end 1)
 277                                (replace-match "\\\\\\&" t))
 278                              ;; ... then undo escaping of matching parentheses,
 279                              ;; including matching nested parentheses.
 280                              (goto-char fullname-start)
 281                              (while (re-search-forward
 282                                      "\\(\\=\\|[^\\]\\(\\\\\\\\\\)*\\)\\\\(\\(\\([^\\]\\|\\\\\\\\\\)*\\)\\\\)"
 283                                      fullname-end 1)
 284                                (replace-match "\\1(\\3)" t)
 285                                (goto-char fullname-start))))
 286                          (insert ")\n"))
 287                         ((null mail-from-style)
 288                          (insert "From: " login "\n")))))
 289             ;; Insert a `Message-Id:' field if there isn't one yet.
 290             (goto-char (point-min))
 291             (unless (re-search-forward "^Message-Id:" delimline t)
 292               (insert "Message-Id: " (message-make-message-id) "\n"))
 293             ;; Insert a `Date:' field if there isn't one yet.
 294             (goto-char (point-min))
 295             (unless (re-search-forward "^Date:" delimline t)
 296               (insert "Date: " (message-make-date) "\n"))
 297             ;; Possibly add a MIME header for the current coding system
 298             (let (charset)
 299               (goto-char (point-min))
 300               (and (eq mail-send-nonascii 'mime)
 301                    (not (re-search-forward "^MIME-version:" delimline t))
 302                    (progn (skip-chars-forward "\0-\177")
 303                           (/= (point) (point-max)))
 304                    smtpmail-code-conv-from
 305                    (setq charset
 306                          (coding-system-get smtpmail-code-conv-from
 307                                             'mime-charset))
 308                    (goto-char delimline)
 309                    (insert "MIME-version: 1.0\n"
 310                            "Content-type: text/plain; charset="
 311                            (symbol-name charset)
 312                            "\nContent-Transfer-Encoding: 8bit\n")))
 313             ;; Insert an extra newline if we need it to work around
 314             ;; Sun's bug that swallows newlines.
 315             (goto-char (1+ delimline))
 316             (if (eval mail-mailer-swallows-blank-line)
 317                 (newline))
 318             ;; Find and handle any FCC fields.
 319             (goto-char (point-min))
 320             (if (re-search-forward "^FCC:" delimline t)
 321                 ;; Force `mail-do-fcc' to use the encoding of the mail
 322                 ;; buffer to encode outgoing messages on FCC files.
 323                 (let ((coding-system-for-write smtpmail-code-conv-from))
 324                   (mail-do-fcc delimline)))
 325             (if mail-interactive
 326                 (with-current-buffer errbuf
 327                   (erase-buffer))))
 328           ;; Encode the header according to RFC2047.
 329           (mail-encode-header (point-min) delimline)
 330           ;;
 331           (setq smtpmail-address-buffer (generate-new-buffer "*smtp-mail*"))
 332           (setq smtpmail-recipient-address-list
 333                 (smtpmail-deduce-address-list tembuf (point-min) delimline))
 334           (kill-buffer smtpmail-address-buffer)
 335
 336           (smtpmail-do-bcc delimline)
 337           ;; Send or queue
 338           (if (not smtpmail-queue-mail)
 339               (if (not (null smtpmail-recipient-address-list))
 340                   (when (setq result
 341                               (smtpmail-via-smtp
 342                                smtpmail-recipient-address-list tembuf))
 343                     (error "Sending failed: %s" result))
 344                 (error "Sending failed; no recipients"))
 345             (let* ((file-data
 346                     (expand-file-name
 347                      (format "%s_%i"
 348                              (format-time-string "%Y-%m-%d_%H:%M:%S")
 349                              (setq smtpmail-queue-counter
 350                                    (1+ smtpmail-queue-counter)))
 351                      smtpmail-queue-dir))
 352                    (file-data (convert-standard-filename file-data))
 353                    (file-elisp (concat file-data ".el"))
 354                    (buffer-data (create-file-buffer file-data))
 355                    (buffer-elisp (create-file-buffer file-elisp))
 356                    (buffer-scratch "*queue-mail*"))
 357               (unless (file-exists-p smtpmail-queue-dir)
 358                 (make-directory smtpmail-queue-dir t))
 359               (with-current-buffer buffer-data
 360                 (erase-buffer)
 361                 (set-buffer-file-coding-system
 362                  ;; We will be reading the file with no-conversion in
 363                  ;; smtpmail-send-queued-mail below, so write it out
 364                  ;; with Unix EOLs.
 365                  (coding-system-change-eol-conversion
 366                   (or smtpmail-code-conv-from 'undecided)
 367                   'unix)
 368                  nil t)
 369                 (insert-buffer-substring tembuf)
 370                 (write-file file-data)
 371                 (set-buffer buffer-elisp)
 372                 (erase-buffer)
 373                 (insert (concat
 374                          "(setq smtpmail-recipient-address-list '"
 375                          (prin1-to-string smtpmail-recipient-address-list)
 376                          ")\n"))
 377                 (write-file file-elisp)
 378                 (set-buffer (generate-new-buffer buffer-scratch))
 379                 (insert (concat file-data "\n"))
 380                 (append-to-file (point-min)
 381                                 (point-max)
 382                                 (expand-file-name smtpmail-queue-index-file
 383                                                   smtpmail-queue-dir)))
 384               (kill-buffer buffer-scratch)
 385               (kill-buffer buffer-data)
 386               (kill-buffer buffer-elisp))))
 387       (kill-buffer tembuf)
 388       (if (bufferp errbuf)
 389           (kill-buffer errbuf)))))
 390
 391 ;;;###autoload
 392 (defun smtpmail-send-queued-mail ()
 393   "Send mail that was queued as a result of setting `smtpmail-queue-mail'."
 394   (interactive)
 395   (with-temp-buffer
 396     ;; Get index, get first mail, send it, update index, get second
 397     ;; mail, send it, etc...
 398     (let ((file-msg "")
 399           (qfile (expand-file-name smtpmail-queue-index-file
 400                                    smtpmail-queue-dir))
 401           result)
 402       (insert-file-contents qfile)
 403       (goto-char (point-min))
 404       (while (not (eobp))
 405         (setq file-msg (buffer-substring (point) (line-end-position)))
 406         (load file-msg)
 407         ;; Insert the message literally: it is already encoded as per
 408         ;; the MIME headers, and code conversions might guess the
 409         ;; encoding wrongly.
 410         (with-temp-buffer
 411           (let ((coding-system-for-read 'no-conversion))
 412             (insert-file-contents file-msg))
 413           (let ((smtpmail-mail-address
 414                  (or (and mail-specify-envelope-from (mail-envelope-from))
 415                      user-mail-address)))
 416             (if (not (null smtpmail-recipient-address-list))
 417                 (when (setq result (smtpmail-via-smtp
 418                                     smtpmail-recipient-address-list
 419                                     (current-buffer)))
 420                   (error "Sending failed: %s" result))
 421               (error "Sending failed; no recipients"))))
 422         (delete-file file-msg)
 423         (delete-file (concat file-msg ".el"))
 424         (delete-region (point-at-bol) (point-at-bol 2)))
 425       (write-region (point-min) (point-max) qfile))))
 426
 427 (defun smtpmail-fqdn ()
 428   (if smtpmail-local-domain
 429       (concat (system-name) "." smtpmail-local-domain)
 430     (system-name)))
 431
 432 (defsubst smtpmail-cred-server (cred)
 433   (nth 0 cred))
 434
 435 (defsubst smtpmail-cred-port (cred)
 436   (nth 1 cred))
 437
 438 (defsubst smtpmail-cred-key (cred)
 439   (nth 2 cred))
 440
 441 (defsubst smtpmail-cred-user (cred)
 442   (nth 2 cred))
 443
 444 (defsubst smtpmail-cred-cert (cred)
 445   (nth 3 cred))
 446
 447 (defsubst smtpmail-cred-passwd (cred)
 448   (nth 3 cred))
 449
 450 (defun smtpmail-find-credentials (cred server port)
 451   (catch 'done
 452     (let ((l cred) el)
 453       (while (setq el (pop l))
 454         (when (and (equal server (smtpmail-cred-server el))
 455                    (equal port (smtpmail-cred-port el)))
 456           (throw 'done el))))))
 457
 458 (defun smtpmail-maybe-append-domain (recipient)
 459   (if (or (not smtpmail-sendto-domain)
 460           (string-match "@" recipient))
 461       recipient
 462     (concat recipient "@" smtpmail-sendto-domain)))
 463
 464 (defun smtpmail-intersection (list1 list2)
 465   (let ((result nil))
 466     (dolist (el2 list2)
 467       (when (memq el2 list1)
 468         (push el2 result)))
 469     (nreverse result)))
 470
 471 ;; `password-read' autoloads password-cache.
 472 (declare-function password-cache-add "password-cache" (key password))
 473
 474 (defun smtpmail-command-or-throw (process string &optional code)
 475   (let (ret)
 476     (smtpmail-send-command process string)
 477     (unless (smtpmail-ok-p (setq ret (smtpmail-read-response process))
 478                            code)
 479       (throw 'done (format "%s in response to %s"
 480                            (smtpmail-response-text ret)
 481                            string)))
 482     ret))
 483
 484 (defun smtpmail-try-auth-methods (process supported-extensions host port
 485                                           &optional ask-for-password)
 486   (setq port
 487         (if port
 488             (format "%s" port)
 489           "smtp"))
 490   (let* ((mechs (cdr-safe (assoc 'auth supported-extensions)))
 491          (mech (car (smtpmail-intersection mechs smtpmail-auth-supported)))
 492          (auth-source-creation-prompts
 493           '((user  . "SMTP user name for %h: ")
 494             (secret . "SMTP password for %u@%h: ")))
 495          (auth-info (car
 496                      (auth-source-search
 497                       :host host
 498                       :port port
 499                       :user smtpmail-smtp-user
 500                       :max 1
 501                       :require (and ask-for-password
 502                                     '(:user :secret))
 503                       :create ask-for-password)))
 504          (user (plist-get auth-info :user))
 505          (password (plist-get auth-info :secret))
 506          (save-function (and ask-for-password
 507                              (plist-get auth-info :save-function)))
 508          ret)
 509     (when (functionp password)
 510       (setq password (funcall password)))
 511     (when (and user
 512                (not password))
 513       ;; The user has stored the user name, but not the password, so
 514       ;; ask for the password, even if we're not forcing that through
 515       ;; `ask-for-password'.
 516       (setq auth-info
 517             (car
 518              (auth-source-search
 519               :max 1
 520               :host host
 521               :port port
 522               :user smtpmail-smtp-user
 523               :require '(:user :secret)
 524               :create t))
 525             password (plist-get auth-info :secret)))
 526     (when (functionp password)
 527       (setq password (funcall password)))
 528     (cond
 529      ((or (not mech)
 530           (not user)
 531           (not password))
 532       ;; No mechanism, or no credentials.
 533       mech)
 534      ((eq mech 'cram-md5)
 535       (setq ret (smtpmail-command-or-throw process "AUTH CRAM-MD5"))
 536       (when (eq (car ret) 334)
 537         (let* ((challenge (substring (cadr ret) 4))
 538                (decoded (base64-decode-string challenge))
 539                (hash (rfc2104-hash 'md5 64 16 password decoded))
 540                (response (concat user " " hash))
 541                ;; Osamu Yamane <yamane@green.ocn.ne.jp>:
 542                ;; SMTP auth fails because the SMTP server identifies
 543                ;; only the first part of the string (delimited by
 544                ;; new line characters) as a response from the
 545                ;; client, and the rest as distinct commands.
 546
 547                ;; In my case, the response string is 80 characters
 548                ;; long.  Without the no-line-break option for
 549                ;; `base64-encode-string', only the first 76 characters
 550                ;; are taken as a response to the server, and the
 551                ;; authentication fails.
 552                (encoded (base64-encode-string response t)))
 553           (smtpmail-command-or-throw process encoded)
 554           (when save-function
 555             (funcall save-function)))))
 556      ((eq mech 'login)
 557       (smtpmail-command-or-throw process "AUTH LOGIN")
 558       (smtpmail-command-or-throw
 559        process (base64-encode-string user t))
 560       (smtpmail-command-or-throw process (base64-encode-string password t))
 561       (when save-function
 562         (funcall save-function)))
 563      ((eq mech 'plain)
 564       ;; We used to send an empty initial request, and wait for an
 565       ;; empty response, and then send the password, but this
 566       ;; violate a SHOULD in RFC 2222 paragraph 5.1.  Note that this
 567       ;; is not sent if the server did not advertise AUTH PLAIN in
 568       ;; the EHLO response.  See RFC 2554 for more info.
 569       (smtpmail-command-or-throw
 570        process
 571        (concat "AUTH PLAIN "
 572                (base64-encode-string (concat "\0" user "\0" password) t))
 573        235)
 574       (when save-function
 575         (funcall save-function)))
 576      (t
 577       (error "Mechanism %s not implemented" mech)))))
 578
 579 (defun smtpmail-response-code (string)
 580   (when string
 581     (with-temp-buffer
 582       (insert string)
 583       (goto-char (point-min))
 584       (and (re-search-forward "^\\([0-9]+\\) " nil t)
 585            (string-to-number (match-string 1))))))
 586
 587 (defun smtpmail-ok-p (response &optional code)
 588   (and (car response)
 589        (integerp (car response))
 590        (< (car response) 400)
 591        (or (null code)
 592            (= code (car response)))))
 593
 594 (defun smtpmail-response-text (response)
 595   (mapconcat 'identity (cdr response) "\n"))
 596
 597 (defun smtpmail-query-smtp-server ()
 598   (let ((server (read-string "Outgoing SMTP mail server: "))
 599         (ports '("smtp" 587))
 600         stream port)
 601     (when (and smtpmail-smtp-server
 602                (not (member smtpmail-smtp-server ports)))
 603       (push smtpmail-smtp-server ports))
 604     (while (and (not smtpmail-smtp-server)
 605                 (setq port (pop ports)))
 606       (when (setq stream (condition-case ()
 607                              (open-network-stream "smtp" nil server port)
 608                            (quit nil)
 609                            (error nil)))
 610         (customize-save-variable 'smtpmail-smtp-server server)
 611         (customize-save-variable 'smtpmail-smtp-service port)
 612         (delete-process stream)))
 613     (unless smtpmail-smtp-server
 614       (error "Couldn't contact an SMTP server"))))
 615
 616 (defun smtpmail-via-smtp (recipient smtpmail-text-buffer
 617                                     &optional ask-for-password)
 618   (unless smtpmail-smtp-server
 619     (smtpmail-query-smtp-server))
 620   (let ((process nil)
 621         (host (or smtpmail-smtp-server
 622                   (error "`smtpmail-smtp-server' not defined")))
 623         (port smtpmail-smtp-service)
 624         ;; `smtpmail-mail-address' should be set to the appropriate
 625         ;; buffer-local value by the caller, but in case not:
 626         (envelope-from (or smtpmail-mail-address
 627                            (and mail-specify-envelope-from
 628                                 (mail-envelope-from))
 629                            user-mail-address))
 630         response-code
 631         process-buffer
 632         result
 633         auth-mechanisms
 634         (supported-extensions '()))
 635     (unwind-protect
 636         (catch 'done
 637           ;; get or create the trace buffer
 638           (setq process-buffer
 639                 (get-buffer-create
 640                  (format "*trace of SMTP session to %s*" host)))
 641
 642           ;; clear the trace buffer of old output
 643           (with-current-buffer process-buffer
 644             (setq buffer-undo-list t)
 645             (erase-buffer))
 646
 647           ;; open the connection to the server
 648           (let ((coding-system-for-read 'binary)
 649                 (coding-system-for-write 'binary))
 650             (setq result
 651                   (open-network-stream
 652                    "smtpmail" process-buffer host port
 653                    :type smtpmail-stream-type
 654                    :return-list t
 655                    :capability-command (format "EHLO %s\r\n" (smtpmail-fqdn))
 656                    :end-of-command "^[0-9]+ .*\r\n"
 657                    :success "^2.*\n"
 658                    :always-query-capabilities t
 659                    :starttls-function
 660                    (lambda (capabilities)
 661                      (and (string-match "-STARTTLS" capabilities)
 662                           "STARTTLS\r\n"))
 663                    :client-certificate t
 664                    :use-starttls-if-possible t)))
 665
 666           ;; If we couldn't access the server at all, we give up.
 667           (unless (setq process (car result))
 668             (throw 'done (if (plist-get (cdr result) :error)
 669                              (plist-get (cdr result) :error)
 670                            "Unable to contact server")))
 671
 672           ;; set the send-filter
 673           (set-process-filter process 'smtpmail-process-filter)
 674
 675           (let* ((greeting (plist-get (cdr result) :greeting))
 676                  (code (smtpmail-response-code greeting)))
 677             (unless code
 678               (throw 'done (format "No greeting: %s" greeting)))
 679             (when (>= code 400)
 680               (throw 'done (format "Connection not allowed: %s" greeting))))
 681
 682           (with-current-buffer process-buffer
 683             (set-buffer-process-coding-system 'raw-text-unix 'raw-text-unix)
 684             (make-local-variable 'smtpmail-read-point)
 685             (setq smtpmail-read-point (point-min))
 686
 687             (let* ((capabilities (plist-get (cdr result) :capabilities))
 688                    (code (smtpmail-response-code capabilities)))
 689               (if (or (null code)
 690                       (>= code 400))
 691                   ;; The server didn't accept EHLO, so we fall back on HELO.
 692                   (smtpmail-command-or-throw
 693                    process (format "HELO %s" (smtpmail-fqdn)))
 694                 ;; EHLO was successful, so we parse the extensions.
 695                 (dolist (line (delete
 696                                ""
 697                                (split-string
 698                                 (plist-get (cdr result) :capabilities)
 699                                 "\r\n")))
 700                   (let ((name
 701                          (with-case-table ascii-case-table
 702                            (mapcar (lambda (s) (intern (downcase s)))
 703                                    (split-string (substring line 4) "[ ]")))))
 704                     (when (= (length name) 1)
 705                       (setq name (car name)))
 706                     (when name
 707                       (cond ((memq (if (consp name) (car name) name)
 708                                    '(verb xvrb 8bitmime onex xone
 709                                           expn size dsn etrn
 710                                           enhancedstatuscodes
 711                                           help xusr
 712                                           auth=login auth starttls))
 713                              (setq supported-extensions
 714                                    (cons name supported-extensions)))
 715                             (smtpmail-warn-about-unknown-extensions
 716                              (message "Unknown extension %s" name))))))))
 717
 718             (setq auth-mechanisms
 719                   (smtpmail-try-auth-methods
 720                    process supported-extensions host port
 721                    ask-for-password))
 722
 723             (when (or (member 'onex supported-extensions)
 724                       (member 'xone supported-extensions))
 725               (smtpmail-command-or-throw process (format "ONEX")))
 726
 727             (when (and smtpmail-debug-verb
 728                        (or (member 'verb supported-extensions)
 729                            (member 'xvrb supported-extensions)))
 730               (smtpmail-command-or-throw process (format "VERB")))
 731
 732             (when (member 'xusr supported-extensions)
 733               (smtpmail-command-or-throw process (format "XUSR")))
 734
 735             ;; MAIL FROM:<sender>
 736             (let ((size-part
 737                    (if (or (member 'size supported-extensions)
 738                            (assoc 'size supported-extensions))
 739                        (format " SIZE=%d"
 740                                (with-current-buffer smtpmail-text-buffer
 741                                  ;; size estimate:
 742                                  (+ (- (point-max) (point-min))
 743                                     ;; Add one byte for each change-of-line
 744                                     ;; because of CR-LF representation:
 745                                     (count-lines (point-min) (point-max)))))
 746                      ""))
 747                   (body-part
 748                    (if (member '8bitmime supported-extensions)
 749                        ;; FIXME:
 750                        ;; Code should be added here that transforms
 751                        ;; the contents of the message buffer into
 752                        ;; something the receiving SMTP can handle.
 753                        ;; For a receiver that supports 8BITMIME, this
 754                        ;; may mean converting BINARY to BASE64, or
 755                        ;; adding Content-Transfer-Encoding and the
 756                        ;; other MIME headers.  The code should also
 757                        ;; return an indication of what encoding the
 758                        ;; message buffer is now, i.e. ASCII or
 759                        ;; 8BITMIME.
 760                        (if nil
 761                            " BODY=8BITMIME"
 762                          "")
 763                      "")))
 764               (smtpmail-send-command
 765                process (format "MAIL FROM:<%s>%s%s"
 766                                envelope-from size-part body-part))
 767               (cond
 768                ((smtpmail-ok-p (setq result (smtpmail-read-response process)))
 769                 ;; Success.
 770                 )
 771                ((and auth-mechanisms
 772                      (not ask-for-password)
 773                      (eq (car result) 530))
 774                 ;; We got a "530 auth required", so we close and try
 775                 ;; again, this time asking the user for a password.
 776                 (smtpmail-send-command process "QUIT")
 777                 (smtpmail-read-response process)
 778                 (delete-process process)
 779                 (setq process nil)
 780                 (throw 'done
 781                        (smtpmail-via-smtp recipient smtpmail-text-buffer t)))
 782                (t
 783                 ;; Return the error code.
 784                 (throw 'done
 785                        (smtpmail-response-text result)))))
 786
 787             ;; RCPT TO:<recipient>
 788             (let ((n 0))
 789               (while (not (null (nth n recipient)))
 790                 (smtpmail-send-command
 791                  process (format "RCPT TO:<%s>"
 792                                  (smtpmail-maybe-append-domain
 793                                   (nth n recipient))))
 794                 (cond
 795                  ((smtpmail-ok-p (setq result (smtpmail-read-response process)))
 796                   ;; Success.
 797                   nil)
 798                  ((and auth-mechanisms
 799                        (not ask-for-password)
 800                        (integerp (car result))
 801                        (>= (car result) 550)
 802                        (<= (car result) 554))
 803                   ;; We got a "550 relay not permitted" (or the like),
 804                   ;; and the server accepts credentials, so we try
 805                   ;; again, but ask for a password first.
 806                   (smtpmail-send-command process "QUIT")
 807                   (smtpmail-read-response process)
 808                   (delete-process process)
 809                   (setq process nil)
 810                   (throw 'done
 811                          (smtpmail-via-smtp recipient smtpmail-text-buffer t)))
 812                  (t
 813                   ;; Return the error code.
 814                   (throw 'done
 815                          (smtpmail-response-text result))))
 816                 (setq n (1+ n))))
 817
 818             ;; Send the contents.
 819             (smtpmail-command-or-throw process "DATA")
 820             (smtpmail-send-data process smtpmail-text-buffer)
 821             ;; DATA end "."
 822             (smtpmail-command-or-throw process ".")
 823             ;; Return success.
 824             nil))
 825       (when (and process
 826                  (buffer-live-p process-buffer))
 827         (with-current-buffer (process-buffer process)
 828           (smtpmail-send-command process "QUIT")
 829           (smtpmail-read-response process)
 830           (delete-process process)
 831           (unless smtpmail-debug-info
 832             (kill-buffer process-buffer)))))))
 833
 834
 835 (defun smtpmail-process-filter (process output)
 836   (with-current-buffer (process-buffer process)
 837     (goto-char (point-max))
 838     (insert output)))
 839
 840 (defun smtpmail-read-response (process)
 841   (let ((case-fold-search nil)
 842         (response-strings nil)
 843         (response-continue t)
 844         (return-value '(nil ()))
 845         match-end)
 846     (catch 'done
 847       (while response-continue
 848         (goto-char smtpmail-read-point)
 849         (while (not (search-forward "\r\n" nil t))
 850           (unless (memq (process-status process) '(open run))
 851             (throw 'done nil))
 852           (accept-process-output process)
 853           (goto-char smtpmail-read-point))
 854
 855         (setq match-end (point))
 856         (setq response-strings
 857               (cons (buffer-substring smtpmail-read-point (- match-end 2))
 858                     response-strings))
 859
 860         (goto-char smtpmail-read-point)
 861         (if (looking-at "[0-9]+ ")
 862             (let ((begin (match-beginning 0))
 863                   (end (match-end 0)))
 864               (if smtpmail-debug-info
 865                   (message "%s" (car response-strings)))
 866
 867               (setq smtpmail-read-point match-end)
 868
 869               ;; ignore lines that start with "0"
 870               (if (looking-at "0[0-9]+ ")
 871                   nil
 872                 (setq response-continue nil)
 873                 (setq return-value
 874                       (cons (string-to-number
 875                              (buffer-substring begin end))
 876                             (nreverse response-strings)))))
 877
 878           (if (looking-at "[0-9]+-")
 879               (progn (if smtpmail-debug-info
 880                          (message "%s" (car response-strings)))
 881                      (setq smtpmail-read-point match-end)
 882                      (setq response-continue t))
 883             (progn
 884               (setq smtpmail-read-point match-end)
 885               (setq response-continue nil)
 886               (setq return-value
 887                     (cons nil (nreverse response-strings)))))))
 888       (setq smtpmail-read-point match-end))
 889     return-value))
 890
 891
 892 (defun smtpmail-send-command (process command)
 893   (goto-char (point-max))
 894   (if (= (aref command 0) ?P)
 895       (insert "PASS <omitted>\r\n")
 896     (insert command "\r\n"))
 897   (setq smtpmail-read-point (point))
 898   (process-send-string process command)
 899   (process-send-string process "\r\n"))
 900
 901 (defun smtpmail-send-data-1 (process data)
 902   (goto-char (point-max))
 903
 904   (if (and (multibyte-string-p data)
 905            smtpmail-code-conv-from)
 906       (setq data (string-as-multibyte
 907                   (encode-coding-string data smtpmail-code-conv-from))))
 908
 909   (if smtpmail-debug-info
 910       (insert data "\r\n"))
 911
 912   (setq smtpmail-read-point (point))
 913   ;; Escape "." at start of a line
 914   (if (eq (string-to-char data) ?.)
 915       (process-send-string process "."))
 916   (process-send-string process data)
 917   (process-send-string process "\r\n"))
 918
 919 (defun smtpmail-send-data (process buffer)
 920   (let ((data-continue t) sending-data
 921         (pr (with-current-buffer buffer
 922               (make-progress-reporter "Sending email"
 923                                       (point-min) (point-max)))))
 924     (with-current-buffer buffer
 925       (goto-char (point-min)))
 926     (while data-continue
 927       (with-current-buffer buffer
 928         (progress-reporter-update pr (point))
 929         (setq sending-data (buffer-substring (point-at-bol) (point-at-eol)))
 930         (end-of-line 2)
 931         (setq data-continue (not (eobp))))
 932       (smtpmail-send-data-1 process sending-data))
 933     (progress-reporter-done pr)))
 934
 935 (defun smtpmail-deduce-address-list (smtpmail-text-buffer header-start header-end)
 936   "Get address list suitable for smtp RCPT TO: <address>."
 937   (unwind-protect
 938       (with-current-buffer smtpmail-address-buffer
 939         (erase-buffer)
 940         (let ((case-fold-search t)
 941               (simple-address-list "")
 942               this-line
 943               this-line-end
 944               addr-regexp)
 945           (insert-buffer-substring smtpmail-text-buffer header-start header-end)
 946           (goto-char (point-min))
 947           ;; RESENT-* fields should stop processing of regular fields.
 948           (save-excursion
 949             (setq addr-regexp
 950                   (if (re-search-forward "^Resent-\\(to\\|cc\\|bcc\\):"
 951                                          header-end t)
 952                       "^Resent-\\(to\\|cc\\|bcc\\):"
 953                     "^\\(To:\\|Cc:\\|Bcc:\\)")))
 954
 955           (while (re-search-forward addr-regexp header-end t)
 956             (replace-match "")
 957             (setq this-line (match-beginning 0))
 958             (forward-line 1)
 959             ;; get any continuation lines
 960             (while (and (looking-at "^[ \t]+") (< (point) header-end))
 961               (forward-line 1))
 962             (setq this-line-end (point-marker))
 963             (setq simple-address-list
 964                   (concat simple-address-list " "
 965                           (mail-strip-quoted-names (buffer-substring this-line this-line-end)))))
 966           (erase-buffer)
 967           (insert " " simple-address-list "\n")
 968           (subst-char-in-region (point-min) (point-max) 10 ?  t) ; newline --> blank
 969           (subst-char-in-region (point-min) (point-max) ?, ?  t) ; comma   --> blank
 970           (subst-char-in-region (point-min) (point-max)  9 ?  t) ; tab     --> blank
 971
 972           (goto-char (point-min))
 973           ;; tidyness in case hook is not robust when it looks at this
 974           (while (re-search-forward "[ \t]+" header-end t) (replace-match " "))
 975
 976           (goto-char (point-min))
 977           (let (recipient-address-list)
 978             (while (re-search-forward " \\([^ ]+\\) " (point-max) t)
 979               (backward-char 1)
 980               (setq recipient-address-list (cons (buffer-substring (match-beginning 1) (match-end 1))
 981                                                  recipient-address-list)))
 982             (setq smtpmail-recipient-address-list recipient-address-list))))))
 983
 984 (defun smtpmail-do-bcc (header-end)
 985   "Delete [Resent-]BCC: and their continuation lines from the header area.
 986 There may be multiple BCC: lines, and each may have arbitrarily
 987 many continuation lines."
 988   (let ((case-fold-search t))
 989     (save-excursion
 990       (goto-char (point-min))
 991       ;; iterate over all BCC: lines
 992       (while (re-search-forward "^\\(RESENT-\\)?BCC:" header-end t)
 993         (delete-region (match-beginning 0)
 994                        (progn (forward-line 1) (point)))
 995         ;; get rid of any continuation lines
 996         (while (and (looking-at "^[ \t].*\n") (< (point) header-end))
 997           (replace-match ""))))))
 998
 999 (provide 'smtpmail)
1000
1001 ;;; smtpmail.el ends here