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