lisp/mail/smtpmail.el

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