cgit.sxemacs.org Git - gnus/blob - contrib/smtpmail.el

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