smtpmail.el 34.2 KB
Newer Older
Richard M. Stallman's avatar
Richard M. Stallman committed
1
;;; smtpmail.el --- simple SMTP protocol (RFC 821) for sending mail
Richard M. Stallman's avatar
Richard M. Stallman committed
2

3 4
;; Copyright (C) 1995, 1996, 2001, 2002, 2003, 2004, 2005,
;;   2006 Free Software Foundation, Inc.
Richard M. Stallman's avatar
Richard M. Stallman committed
5 6

;; Author: Tomoji Kagatani <kagatani@rbc.ncl.omron.co.jp>
7 8
;; Maintainer: Simon Josefsson <simon@josefsson.org>
;; w32 Maintainer: Brian D. Carlstrom <bdc@ai.mit.edu>
9
;; ESMTP support: Simon Leinen <simon@switch.ch>
10 11
;; Hacked by Mike Taylor, 11th October 1999 to add support for
;; automatically appending a domain to RCPT TO: addresses.
12
;; AUTH=LOGIN support: Stephen Cranefield <scranefield@infoscience.otago.ac.nz>
Richard M. Stallman's avatar
Richard M. Stallman committed
13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28
;; Keywords: mail

;; This file is part of GNU Emacs.

;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to the
Lute Kamstra's avatar
Lute Kamstra committed
29 30
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
Richard M. Stallman's avatar
Richard M. Stallman committed
31 32 33 34 35

;;; Commentary:

;; Send Mail to smtp host from smtpmail temp buffer.

36
;; Please add these lines in your .emacs(_emacs) or use customize.
Richard M. Stallman's avatar
Richard M. Stallman committed
37
;;
38
;;(setq send-mail-function 'smtpmail-send-it) ; if you use `mail'
39
;;(setq message-send-mail-function 'smtpmail-send-it) ; if you use message/Gnus
Richard M. Stallman's avatar
Richard M. Stallman committed
40 41
;;(setq smtpmail-default-smtp-server "YOUR SMTP HOST")
;;(setq smtpmail-local-domain "YOUR DOMAIN NAME")
42
;;(setq smtpmail-sendto-domain "YOUR DOMAIN NAME")
43
;;(setq smtpmail-debug-info t) ; only to debug problems
44
;;(setq smtpmail-auth-credentials  ; or use ~/.authinfo
45 46 47
;;      '(("YOUR SMTP HOST" 25 "username" "password")))
;;(setq smtpmail-starttls-credentials
;;      '(("YOUR SMTP HOST" 25 "~/.my_smtp_tls.key" "~/.my_smtp_tls.cert")))
48 49
;; Where the 25 equals the value of `smtpmail-smtp-service', it can be an
;; integer or a string, just as long as they match (eq).
Richard M. Stallman's avatar
Richard M. Stallman committed
50

51
;; To queue mail, set smtpmail-queue-mail to t and use
Richard M. Stallman's avatar
Richard M. Stallman committed
52 53
;; smtpmail-send-queued-mail to send.

54 55 56 57 58 59 60 61 62 63 64 65 66 67
;; Modified by Stephen Cranefield <scranefield@infoscience.otago.ac.nz>,
;; 22/6/99, to support SMTP Authentication by the AUTH=LOGIN mechanism.
;; See http://help.netscape.com/products/server/messaging/3x/info/smtpauth.html
;; Rewritten by Simon Josefsson to use same credential variable as AUTH
;; support below.

;; Modified by Simon Josefsson <jas@pdc.kth.se>, 22/2/99, to support SMTP
;; Authentication by the AUTH mechanism.
;; See http://www.ietf.org/rfc/rfc2554.txt

;; Modified by Simon Josefsson <simon@josefsson.org>, 2000-10-07, to support
;; STARTTLS.  Requires external program
;; ftp://ftp.opaopa.org/pub/elisp/starttls-*.tar.gz.
;; See http://www.ietf.org/rfc/rfc2246.txt, http://www.ietf.org/rfc/rfc2487.txt
Richard M. Stallman's avatar
Richard M. Stallman committed
68

Richard M. Stallman's avatar
Richard M. Stallman committed
69 70 71
;;; Code:

(require 'sendmail)
72 73 74
(autoload 'starttls-open-stream "starttls")
(autoload 'starttls-negotiate "starttls")
(autoload 'mail-strip-quoted-names "mail-utils")
Stefan Monnier's avatar
Stefan Monnier committed
75 76
(autoload 'message-make-date "message")
(autoload 'message-make-message-id "message")
77
(autoload 'rfc2104-hash "rfc2104")
78
(autoload 'netrc-parse "netrc")
79 80
(autoload 'netrc-machine "netrc")
(autoload 'netrc-get "netrc")
Richard M. Stallman's avatar
Richard M. Stallman committed
81 82

;;;
83 84 85
(defgroup smtpmail nil
  "SMTP protocol for sending mail."
  :group 'mail)
Richard M. Stallman's avatar
Richard M. Stallman committed
86

87 88

(defcustom smtpmail-default-smtp-server nil
89 90
  "*Specify default SMTP server.
This only has effect if you specify it before loading the smtpmail library."
91 92 93
  :type '(choice (const nil) string)
  :group 'smtpmail)

94
(defcustom smtpmail-smtp-server
95
  (or (getenv "SMTPSERVER") smtpmail-default-smtp-server)
96 97 98
  "*The name of the host running SMTP server."
  :type '(choice (const nil) string)
  :group 'smtpmail)
Richard M. Stallman's avatar
Richard M. Stallman committed
99

100
(defcustom smtpmail-smtp-service 25
101 102 103
  "*SMTP service port number.
The default value would be \"smtp\" or 25 ."
  :type '(choice (integer :tag "Port") (string :tag "Service"))
104
  :group 'smtpmail)
Richard M. Stallman's avatar
Richard M. Stallman committed
105

106
(defcustom smtpmail-local-domain nil
Richard M. Stallman's avatar
Richard M. Stallman committed
107 108
  "*Local domain name without a host name.
If the function (system-name) returns the full internet address,
109 110 111 112
don't define this value."
  :type '(choice (const nil) string)
  :group 'smtpmail)

113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128
(defcustom smtpmail-sendto-domain nil
  "*Local domain name without a host name.
This is appended (with an @-sign) to any specified recipients which do
not include an @-sign, so that each RCPT TO address is fully qualified.
\(Some configurations of sendmail require this.)

Don't bother to set this unless you have get an error like:
	Sending failed; SMTP protocol error
when sending mail, and the *trace of SMTP session to <somewhere>*
buffer includes an exchange like:
	RCPT TO: <someone>
	501 <someone>: recipient address must contain a domain
"
  :type '(choice (const nil) string)
  :group 'smtpmail)

129
(defcustom smtpmail-debug-info nil
130 131 132 133 134 135 136 137 138
  "Whether to print info in buffer *trace of SMTP session to <somewhere>*.
See also `smtpmail-debug-verb' which determines if the SMTP protocol should
be verbose as well."
  :type 'boolean
  :group 'smtpmail)

(defcustom smtpmail-debug-verb nil
  "Whether this library sends the SMTP VERB command or not.
The commands enables verbose information from the SMTP server."
139 140 141 142 143 144 145
  :type 'boolean
  :group 'smtpmail)

(defcustom smtpmail-code-conv-from nil ;; *junet*
  "*smtpmail code convert from this code to *internal*..for tiny-mime.."
  :type 'boolean
  :group 'smtpmail)
Richard M. Stallman's avatar
Richard M. Stallman committed
146

147
(defcustom smtpmail-queue-mail nil
Richard M. Stallman's avatar
Richard M. Stallman committed
148 149 150 151 152 153 154 155 156 157 158
  "*Specify if mail is queued (if t) or sent immediately (if nil).
If queued, it is stored in the directory `smtpmail-queue-dir'
and sent with `smtpmail-send-queued-mail'."
  :type 'boolean
  :group 'smtpmail)

(defcustom smtpmail-queue-dir "~/Mail/queued-mail/"
  "*Directory where `smtpmail.el' stores queued mail."
  :type 'directory
  :group 'smtpmail)

159 160 161 162
(defcustom smtpmail-auth-credentials "~/.authinfo"
  "Specify username and password for servers, directly or via .netrc file.
This variable can either be a filename pointing to a file in netrc(5)
format, or list of four-element lists that contain, in order,
163
`servername' (a string), `port' (an integer), `user' (a string) and
164 165 166 167 168
`password' (a string, or nil to query the user when needed).  If you
need to enter a `realm' too, add it to the user string, so that it
looks like `user@realm'."
  :type '(choice file
		 (repeat (list (string  :tag "Server")
169 170 171
		       (integer :tag "Port")
		       (string  :tag "Username")
		       (choice (const :tag "Query when needed" nil)
172
				       (string  :tag "Password")))))
173
  :version "22.1"
174 175 176 177 178
  :group 'smtpmail)

(defcustom smtpmail-starttls-credentials '(("" 25 "" ""))
  "Specify STARTTLS keys and certificates for servers.
This is a list of four-element list with `servername' (a string),
179 180 181 182 183 184
`port' (an integer), `key' (a filename) and `certificate' (a
filename).
If you do not have a certificate/key pair, leave the `key' and
`certificate' fields as `nil'.  A key/certificate pair is only
needed if you want to use X.509 client authenticated
connections."
185 186 187 188 189 190 191
  :type '(repeat (list (string  :tag "Server")
		       (integer :tag "Port")
		       (file    :tag "Key")
		       (file    :tag "Certificate")))
  :version "21.1"
  :group 'smtpmail)

192 193 194 195 196
(defcustom smtpmail-warn-about-unknown-extensions nil
  "*If set, print warnings about unknown SMTP extensions.
This is mainly useful for development purposes, to learn about
new SMTP extensions that might be useful to support."
  :type 'boolean
197
  :version "21.1"
198 199
  :group 'smtpmail)

Richard M. Stallman's avatar
Richard M. Stallman committed
200 201 202 203
(defvar smtpmail-queue-index-file "index"
  "File name of queued mail index,
This is relative to `smtpmail-queue-dir'.")

204 205 206
(defvar smtpmail-address-buffer)
(defvar smtpmail-recipient-address-list)

207 208
(defvar smtpmail-queue-counter 0)

209 210 211
;; Buffer-local variable.
(defvar smtpmail-read-point)

Richard M. Stallman's avatar
Richard M. Stallman committed
212 213 214
(defvar smtpmail-queue-index (concat smtpmail-queue-dir
				     smtpmail-queue-index-file))

215
(defconst smtpmail-auth-supported '(cram-md5 plain login)
216 217
  "List of supported SMTP AUTH mechanisms.")

Richard M. Stallman's avatar
Richard M. Stallman committed
218 219 220 221
;;;
;;;
;;;

222
(defvar smtpmail-mail-address nil
223
  "Value to use for envelope-from address for mail from ambient buffer.")
224

225
;;;###autoload
Richard M. Stallman's avatar
Richard M. Stallman committed
226 227 228 229 230 231 232
(defun smtpmail-send-it ()
  (let ((errbuf (if mail-interactive
		    (generate-new-buffer " smtpmail errors")
		  0))
	(tembuf (generate-new-buffer " smtpmail temp"))
	(case-fold-search nil)
	delimline
Kenichi Handa's avatar
Kenichi Handa committed
233
	(mailbuf (current-buffer))
Glenn Morris's avatar
Glenn Morris committed
234 235
        ;; Examine this variable now, so that
	;; local binding in the mail buffer will take effect.
236 237 238
	(smtpmail-mail-address
         (or (and mail-specify-envelope-from (mail-envelope-from))
             user-mail-address))
Kenichi Handa's avatar
Kenichi Handa committed
239 240 241 242
	(smtpmail-code-conv-from
	 (if enable-multibyte-characters
	     (let ((sendmail-coding-system smtpmail-code-conv-from))
	       (select-message-coding-system)))))
Richard M. Stallman's avatar
Richard M. Stallman committed
243 244 245 246 247 248 249 250 251 252
    (unwind-protect
	(save-excursion
	  (set-buffer tembuf)
	  (erase-buffer)
	  (insert-buffer-substring mailbuf)
	  (goto-char (point-max))
	  ;; require one newline at the end.
	  (or (= (preceding-char) ?\n)
	      (insert ?\n))
	  ;; Change header-delimiter to be what sendmail expects.
253
	  (mail-sendmail-undelimit-header)
Richard M. Stallman's avatar
Richard M. Stallman committed
254
	  (setq delimline (point-marker))
255
;;	  (sendmail-synch-aliases)
Richard M. Stallman's avatar
Richard M. Stallman committed
256 257 258 259 260 261 262 263
	  (if mail-aliases
	      (expand-mail-aliases (point-min) delimline))
	  (goto-char (point-min))
	  ;; ignore any blank lines in the header
	  (while (and (re-search-forward "\n\n\n*" delimline t)
		      (< (point) delimline))
	    (replace-match "\n"))
	  (let ((case-fold-search t))
264 265 266
	    ;; We used to process Resent-... headers here,
	    ;; but it was not done properly, and the job
	    ;; is done correctly in smtpmail-deduce-address-list.
Richard M. Stallman's avatar
Richard M. Stallman committed
267 268
	    ;; Don't send out a blank subject line
	    (goto-char (point-min))
269 270 271 272 273 274
	    (if (re-search-forward "^Subject:\\([ \t]*\n\\)+\\b" delimline t)
		(replace-match "")
	      ;; This one matches a Subject just before the header delimiter.
	      (if (and (re-search-forward "^Subject:\\([ \t]*\n\\)+" delimline t)
		       (= (match-end 0) delimline))
		  (replace-match "")))
275 276 277 278
	    ;; Put the "From:" field in unless for some odd reason
	    ;; they put one in themselves.
	    (goto-char (point-min))
	    (if (not (re-search-forward "^From:" delimline t))
279
		(let* ((login smtpmail-mail-address)
280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312
		       (fullname (user-full-name)))
		  (cond ((eq mail-from-style 'angles)
			 (insert "From: " fullname)
			 (let ((fullname-start (+ (point-min) 6))
			       (fullname-end (point-marker)))
			   (goto-char fullname-start)
			   ;; Look for a character that cannot appear unquoted
			   ;; according to RFC 822.
			   (if (re-search-forward "[^- !#-'*+/-9=?A-Z^-~]"
						  fullname-end 1)
			       (progn
				 ;; Quote fullname, escaping specials.
				 (goto-char fullname-start)
				 (insert "\"")
				 (while (re-search-forward "[\"\\]"
							   fullname-end 1)
				   (replace-match "\\\\\\&" t))
				 (insert "\""))))
			 (insert " <" login ">\n"))
			((eq mail-from-style 'parens)
			 (insert "From: " login " (")
			 (let ((fullname-start (point)))
			   (insert fullname)
			   (let ((fullname-end (point-marker)))
			     (goto-char fullname-start)
			     ;; RFC 822 says \ and nonmatching parentheses
			     ;; must be escaped in comments.
			     ;; Escape every instance of ()\ ...
			     (while (re-search-forward "[()\\]" fullname-end 1)
			       (replace-match "\\\\\\&" t))
			     ;; ... then undo escaping of matching parentheses,
			     ;; including matching nested parentheses.
			     (goto-char fullname-start)
313
			     (while (re-search-forward
314 315 316 317 318 319 320
				     "\\(\\=\\|[^\\]\\(\\\\\\\\\\)*\\)\\\\(\\(\\([^\\]\\|\\\\\\\\\\)*\\)\\\\)"
				     fullname-end 1)
			       (replace-match "\\1(\\3)" t)
			       (goto-char fullname-start))))
			 (insert ")\n"))
			((null mail-from-style)
			 (insert "From: " login "\n")))))
Stefan Monnier's avatar
Stefan Monnier committed
321 322 323 324 325 326 327 328
	    ;; Insert a `Message-Id:' field if there isn't one yet.
	    (goto-char (point-min))
	    (unless (re-search-forward "^Message-Id:" delimline t)
	      (insert "Message-Id: " (message-make-message-id) "\n"))
	    ;; Insert a `Date:' field if there isn't one yet.
	    (goto-char (point-min))
	    (unless (re-search-forward "^Date:" delimline t)
	      (insert "Date: " (message-make-date) "\n"))
Richard M. Stallman's avatar
Richard M. Stallman committed
329 330 331 332 333
	    ;; Insert an extra newline if we need it to work around
	    ;; Sun's bug that swallows newlines.
	    (goto-char (1+ delimline))
	    (if (eval mail-mailer-swallows-blank-line)
		(newline))
334 335 336 337
	    ;; Find and handle any FCC fields.
	    (goto-char (point-min))
	    (if (re-search-forward "^FCC:" delimline t)
		(mail-do-fcc delimline))
Richard M. Stallman's avatar
Richard M. Stallman committed
338
	    (if mail-interactive
Stefan Monnier's avatar
Stefan Monnier committed
339
		(with-current-buffer errbuf
Richard M. Stallman's avatar
Richard M. Stallman committed
340 341 342 343 344 345
		  (erase-buffer))))
	  ;;
	  ;;
	  ;;
	  (setq smtpmail-address-buffer (generate-new-buffer "*smtp-mail*"))
	  (setq smtpmail-recipient-address-list
346
		    (smtpmail-deduce-address-list tembuf (point-min) delimline))
Richard M. Stallman's avatar
Richard M. Stallman committed
347
	  (kill-buffer smtpmail-address-buffer)
348

Richard M. Stallman's avatar
Richard M. Stallman committed
349
	  (smtpmail-do-bcc delimline)
Richard M. Stallman's avatar
Richard M. Stallman committed
350 351 352
	  ; Send or queue
	  (if (not smtpmail-queue-mail)
	      (if (not (null smtpmail-recipient-address-list))
353
		  (if (not (smtpmail-via-smtp
Richard M. Stallman's avatar
Richard M. Stallman committed
354 355 356
			    smtpmail-recipient-address-list tembuf))
		      (error "Sending failed; SMTP protocol error"))
		(error "Sending failed; no recipients"))
357 358 359 360 361 362 363 364 365
	    (let* ((file-data
		    (expand-file-name
		     (format "%s_%i"
			     (format-time-string "%Y-%m-%d_%H:%M:%S")
			     (setq smtpmail-queue-counter
				   (1+ smtpmail-queue-counter)))
		     smtpmail-queue-dir))
		   (file-data (convert-standard-filename file-data))
		   (file-elisp (concat file-data ".el"))
Richard M. Stallman's avatar
Richard M. Stallman committed
366 367 368
		   (buffer-data (create-file-buffer file-data))
		   (buffer-elisp (create-file-buffer file-elisp))
		   (buffer-scratch "*queue-mail*"))
369 370
	      (unless (file-exists-p smtpmail-queue-dir)
		(make-directory smtpmail-queue-dir t))
Stefan Monnier's avatar
Stefan Monnier committed
371
	      (with-current-buffer buffer-data
Richard M. Stallman's avatar
Richard M. Stallman committed
372
		(erase-buffer)
373
		(insert-buffer-substring tembuf)
Richard M. Stallman's avatar
Richard M. Stallman committed
374 375 376 377 378 379
		(write-file file-data)
		(set-buffer buffer-elisp)
		(erase-buffer)
		(insert (concat
			 "(setq smtpmail-recipient-address-list '"
			 (prin1-to-string smtpmail-recipient-address-list)
380
			 ")\n"))
Richard M. Stallman's avatar
Richard M. Stallman committed
381 382 383
		(write-file file-elisp)
		(set-buffer (generate-new-buffer buffer-scratch))
		(insert (concat file-data "\n"))
384 385
		(append-to-file (point-min)
				(point-max)
Richard M. Stallman's avatar
Richard M. Stallman committed
386 387 388 389 390
				smtpmail-queue-index)
		)
	      (kill-buffer buffer-scratch)
	      (kill-buffer buffer-data)
	      (kill-buffer buffer-elisp))))
Richard M. Stallman's avatar
Richard M. Stallman committed
391 392 393 394
      (kill-buffer tembuf)
      (if (bufferp errbuf)
	  (kill-buffer errbuf)))))

395
;;;###autoload
Richard M. Stallman's avatar
Richard M. Stallman committed
396 397 398
(defun smtpmail-send-queued-mail ()
  "Send mail that was queued as a result of setting `smtpmail-queue-mail'."
  (interactive)
399 400 401 402 403
  (with-temp-buffer
    ;;; Get index, get first mail, send it, update index, get second
    ;;; mail, send it, etc...
    (let ((file-msg ""))
      (insert-file-contents smtpmail-queue-index)
404
      (goto-char (point-min))
Richard M. Stallman's avatar
Richard M. Stallman committed
405
      (while (not (eobp))
Stefan Monnier's avatar
Stefan Monnier committed
406
	(setq file-msg (buffer-substring (point) (line-end-position)))
Richard M. Stallman's avatar
Richard M. Stallman committed
407
	(load file-msg)
408 409 410
	;; Insert the message literally: it is already encoded as per
	;; the MIME headers, and code conversions might guess the
	;; encoding wrongly.
411 412 413
	(with-temp-buffer
	  (let ((coding-system-for-read 'no-conversion))
	    (insert-file-contents file-msg))
Glenn Morris's avatar
Glenn Morris committed
414 415 416 417 418 419 420 421
          (let ((smtpmail-mail-address
                 (or (and mail-specify-envelope-from (mail-envelope-from))
                     user-mail-address)))
            (if (not (null smtpmail-recipient-address-list))
                (if (not (smtpmail-via-smtp smtpmail-recipient-address-list
                                            (current-buffer)))
                    (error "Sending failed; SMTP protocol error"))
              (error "Sending failed; no recipients"))))
Richard M. Stallman's avatar
Richard M. Stallman committed
422 423
	(delete-file file-msg)
	(delete-file (concat file-msg ".el"))
424
	(delete-region (point-at-bol) (point-at-bol 2)))
425
      (write-region (point-min) (point-max) smtpmail-queue-index))))
Richard M. Stallman's avatar
Richard M. Stallman committed
426 427 428 429 430 431 432 433

;(defun smtpmail-via-smtp (host,port,sender,destination,smtpmail-text-buffer)

(defun smtpmail-fqdn ()
  (if smtpmail-local-domain
      (concat (system-name) "." smtpmail-local-domain)
    (system-name)))

434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459
(defsubst smtpmail-cred-server (cred)
  (nth 0 cred))

(defsubst smtpmail-cred-port (cred)
  (nth 1 cred))

(defsubst smtpmail-cred-key (cred)
  (nth 2 cred))

(defsubst smtpmail-cred-user (cred)
  (nth 2 cred))

(defsubst smtpmail-cred-cert (cred)
  (nth 3 cred))

(defsubst smtpmail-cred-passwd (cred)
  (nth 3 cred))

(defun smtpmail-find-credentials (cred server port)
  (catch 'done
    (let ((l cred) el)
      (while (setq el (pop l))
	(when (and (equal server (smtpmail-cred-server el))
		   (equal port (smtpmail-cred-port el)))
	  (throw 'done el))))))

460 461 462 463 464 465
(defun smtpmail-maybe-append-domain (recipient)
  (if (or (not smtpmail-sendto-domain)
	  (string-match "@" recipient))
      recipient
    (concat recipient "@" smtpmail-sendto-domain)))

466 467 468 469 470 471 472
(defun smtpmail-intersection (list1 list2)
  (let ((result nil))
    (dolist (el2 list2)
      (when (memq el2 list1)
	(push el2 result)))
    (nreverse result)))

473 474 475
(defvar starttls-extra-args)
(defvar starttls-extra-arguments)

476 477 478 479
(defun smtpmail-open-stream (process-buffer host port)
  (let ((cred (smtpmail-find-credentials
	       smtpmail-starttls-credentials host port)))
    (if (null (and cred (condition-case ()
480
			    (with-no-warnings
481
			      (require 'starttls)
482 483 484
			      (call-process (if starttls-use-gnutls
						starttls-gnutls-program
					      starttls-program)))
485 486 487 488 489 490
			  (error nil))))
	;; The normal case.
	(open-network-stream "SMTP" process-buffer host port)
      (let* ((cred-key (smtpmail-cred-key cred))
	     (cred-cert (smtpmail-cred-cert cred))
	     (starttls-extra-args
491 492 493 494 495 496 497 498
	      (append
	       starttls-extra-args
	       (when (and (stringp cred-key) (stringp cred-cert)
			  (file-regular-p
			   (setq cred-key (expand-file-name cred-key)))
			  (file-regular-p
			   (setq cred-cert (expand-file-name cred-cert))))
		 (list "--key-file" cred-key "--cert-file" cred-cert))))
Simon Josefsson's avatar
Simon Josefsson committed
499
	     (starttls-extra-arguments
500 501 502 503 504 505 506 507
	      (append
	       starttls-extra-arguments
	       (when (and (stringp cred-key) (stringp cred-cert)
			  (file-regular-p
			   (setq cred-key (expand-file-name cred-key)))
			  (file-regular-p
			   (setq cred-cert (expand-file-name cred-cert))))
		 (list "--x509keyfile" cred-key "--x509certfile" cred-cert)))))
508 509 510 511 512
	(starttls-open-stream "SMTP" process-buffer host port)))))

(defun smtpmail-try-auth-methods (process supported-extensions host port)
  (let* ((mechs (cdr-safe (assoc 'auth supported-extensions)))
	 (mech (car (smtpmail-intersection smtpmail-auth-supported mechs)))
513 514
	 (cred (if (stringp smtpmail-auth-credentials)
		   (let* ((netrc (netrc-parse smtpmail-auth-credentials))
515 516 517
                          (port-name (format "%s" (or port "smtp")))
			  (hostentry (netrc-machine netrc host port-name
                                                    port-name)))
518 519 520 521
                     (when hostentry
                       (list host port
                             (netrc-get hostentry "login")
                             (netrc-get hostentry "password"))))
522
		 (smtpmail-find-credentials
523
		  smtpmail-auth-credentials host port)))
524 525 526 527 528 529 530
	 (passwd (when cred
		   (or (smtpmail-cred-passwd cred)
		       (read-passwd
			(format "SMTP password for %s:%s: "
				(smtpmail-cred-server cred)
				(smtpmail-cred-port cred))))))
	 ret)
531
    (when (and cred mech)
532 533
      (cond
       ((eq mech 'cram-md5)
Simon Josefsson's avatar
Simon Josefsson committed
534
	(smtpmail-send-command process (upcase (format "AUTH %s" mech)))
535 536 537 538 539 540 541 542 543
	(if (or (null (car (setq ret (smtpmail-read-response process))))
		(not (integerp (car ret)))
		(>= (car ret) 400))
	    (throw 'done nil))
	(when (eq (car ret) 334)
	  (let* ((challenge (substring (cadr ret) 4))
		 (decoded (base64-decode-string challenge))
		 (hash (rfc2104-hash 'md5 64 16 passwd decoded))
		 (response (concat (smtpmail-cred-user cred) " " hash))
Richard M. Stallman's avatar
Richard M. Stallman committed
544 545 546 547 548 549 550 551 552 553 554
		 ;; Osamu Yamane <yamane@green.ocn.ne.jp>:
		 ;; SMTP auth fails because the SMTP server identifies
		 ;; only the first part of the string (delimited by
		 ;; new line characters) as a response from the
		 ;; client, and the rest as distinct commands.

		 ;; In my case, the response string is 80 characters
		 ;; long.  Without the no-line-break option for
		 ;; base64-encode-sting, only the first 76 characters
		 ;; are taken as a response to the server, and the
		 ;; authentication fails.
555
		 (encoded (base64-encode-string response t)))
556 557 558 559 560 561 562 563 564 565 566 567
	    (smtpmail-send-command process (format "%s" encoded))
	    (if (or (null (car (setq ret (smtpmail-read-response process))))
		    (not (integerp (car ret)))
		    (>= (car ret) 400))
		(throw 'done nil)))))
       ((eq mech 'login)
	(smtpmail-send-command process "AUTH LOGIN")
	(if (or (null (car (setq ret (smtpmail-read-response process))))
		(not (integerp (car ret)))
		(>= (car ret) 400))
	    (throw 'done nil))
	(smtpmail-send-command
568
	 process (base64-encode-string (smtpmail-cred-user cred) t))
569 570 571 572
	(if (or (null (car (setq ret (smtpmail-read-response process))))
		(not (integerp (car ret)))
		(>= (car ret) 400))
	    (throw 'done nil))
573
	(smtpmail-send-command process (base64-encode-string passwd t))
574 575 576 577
	(if (or (null (car (setq ret (smtpmail-read-response process))))
		(not (integerp (car ret)))
		(>= (car ret) 400))
	    (throw 'done nil)))
578
       ((eq mech 'plain)
579 580 581 582 583
	;; We used to send an empty initial request, and wait for an
	;; empty response, and then send the password, but this
	;; violate a SHOULD in RFC 2222 paragraph 5.1.  Note that this
	;; is not sent if the server did not advertise AUTH PLAIN in
	;; the EHLO response.  See RFC 2554 for more info.
584 585 586
	(smtpmail-send-command process
			       (concat "AUTH PLAIN "
				       (base64-encode-string
587 588 589
					(concat "\0"
						(smtpmail-cred-user cred)
						"\0"
590
						passwd) t)))
591 592 593 594 595
	(if (or (null (car (setq ret (smtpmail-read-response process))))
		(not (integerp (car ret)))
		(not (equal (car ret) 235)))
	    (throw 'done nil)))

596
       (t
597
	(error "Mechanism %s not implemented" mech)))
598
      ;; Remember the password.
599 600
      (when (and (not (stringp smtpmail-auth-credentials))
		 (null (smtpmail-cred-passwd cred)))
601 602
	(setcar (cdr (cdr (cdr cred))) passwd)))))

Richard M. Stallman's avatar
Richard M. Stallman committed
603 604
(defun smtpmail-via-smtp (recipient smtpmail-text-buffer)
  (let ((process nil)
605 606
	(host (or smtpmail-smtp-server
		  (error "`smtpmail-smtp-server' not defined")))
607
	(port smtpmail-smtp-service)
Glenn Morris's avatar
Glenn Morris committed
608 609 610 611 612 613
        ;; smtpmail-mail-address should be set to the appropriate
        ;; buffer-local value by the caller, but in case not:
        (envelope-from (or smtpmail-mail-address
                           (and mail-specify-envelope-from
                                (mail-envelope-from))
                           user-mail-address))
Richard M. Stallman's avatar
Richard M. Stallman committed
614
	response-code
615
	greeting
616 617
	process-buffer
	(supported-extensions '()))
Richard M. Stallman's avatar
Richard M. Stallman committed
618 619 620 621 622 623 624
    (unwind-protect
	(catch 'done
	  ;; get or create the trace buffer
	  (setq process-buffer
		(get-buffer-create (format "*trace of SMTP session to %s*" host)))

	  ;; clear the trace buffer of old output
Stefan Monnier's avatar
Stefan Monnier committed
625
	  (with-current-buffer process-buffer
626
	    (setq buffer-undo-list t)
Richard M. Stallman's avatar
Richard M. Stallman committed
627 628 629
	    (erase-buffer))

	  ;; open the connection to the server
630
	  (setq process (smtpmail-open-stream process-buffer host port))
Richard M. Stallman's avatar
Richard M. Stallman committed
631 632 633 634 635
	  (and (null process) (throw 'done nil))

	  ;; set the send-filter
	  (set-process-filter process 'smtpmail-process-filter)

Stefan Monnier's avatar
Stefan Monnier committed
636
	  (with-current-buffer process-buffer
637
	    (set-buffer-process-coding-system 'raw-text-unix 'raw-text-unix)
Richard M. Stallman's avatar
Richard M. Stallman committed
638 639 640
	    (make-local-variable 'smtpmail-read-point)
	    (setq smtpmail-read-point (point-min))

641

Richard M. Stallman's avatar
Richard M. Stallman committed
642 643 644 645 646 647
	    (if (or (null (car (setq greeting (smtpmail-read-response process))))
		    (not (integerp (car greeting)))
		    (>= (car greeting) 400))
		(throw 'done nil)
	      )

648 649 650
	    (let ((do-ehlo t)
		  (do-starttls t))
	      (while do-ehlo
651 652
	    ;; EHLO
	    (smtpmail-send-command process (format "EHLO %s" (smtpmail-fqdn)))
Richard M. Stallman's avatar
Richard M. Stallman committed
653

654 655
	    (if (or (null (car (setq response-code
				     (smtpmail-read-response process))))
Richard M. Stallman's avatar
Richard M. Stallman committed
656 657
		    (not (integerp (car response-code)))
		    (>= (car response-code) 400))
658 659
		(progn
		  ;; HELO
660 661
		  (smtpmail-send-command
		   process (format "HELO %s" (smtpmail-fqdn)))
662

663 664
		  (if (or (null (car (setq response-code
					   (smtpmail-read-response process))))
665 666 667
			  (not (integerp (car response-code)))
			  (>= (car response-code) 400))
		      (throw 'done nil)))
668 669 670 671 672
	      (dolist (line (cdr (cdr response-code)))
		(let ((name (mapcar (lambda (s) (intern (downcase s)))
				    (split-string (substring line 4) "[ ]"))))
		  (and (eq (length name) 1)
		       (setq name (car name)))
673
		    (and name
674 675
		       (cond ((memq (if (consp name) (car name) name)
				    '(verb xvrb 8bitmime onex xone
676
						  expn size dsn etrn
677 678 679
				      enhancedstatuscodes
				      help xusr
				      auth=login auth starttls))
680 681
				(setq supported-extensions
				      (cons name supported-extensions)))
682
			       (smtpmail-warn-about-unknown-extensions
683 684 685 686 687
			      (message "Unknown extension %s" name)))))))

	    (if (and do-starttls
		     (smtpmail-find-credentials smtpmail-starttls-credentials host port)
		     (member 'starttls supported-extensions)
688
		     (numberp (process-id process)))
689 690 691 692 693 694 695 696 697
		(progn
		  (smtpmail-send-command process (format "STARTTLS"))
		  (if (or (null (car (setq response-code (smtpmail-read-response process))))
			  (not (integerp (car response-code)))
			  (>= (car response-code) 400))
		      (throw 'done nil))
		  (starttls-negotiate process)
		  (setq do-starttls nil))
	      (setq do-ehlo nil))))
698

699
	    (smtpmail-try-auth-methods process supported-extensions host port)
700 701 702 703 704 705 706 707 708 709

	    (if (or (member 'onex supported-extensions)
		    (member 'xone supported-extensions))
		(progn
		  (smtpmail-send-command process (format "ONEX"))
		  (if (or (null (car (setq response-code (smtpmail-read-response process))))
			  (not (integerp (car response-code)))
			  (>= (car response-code) 400))
		      (throw 'done nil))))

710
	    (if (and smtpmail-debug-verb
711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726
		     (or (member 'verb supported-extensions)
			 (member 'xvrb supported-extensions)))
		(progn
		  (smtpmail-send-command process (format "VERB"))
		  (if (or (null (car (setq response-code (smtpmail-read-response process))))
			  (not (integerp (car response-code)))
			  (>= (car response-code) 400))
		      (throw 'done nil))))

	    (if (member 'xusr supported-extensions)
		(progn
		  (smtpmail-send-command process (format "XUSR"))
		  (if (or (null (car (setq response-code (smtpmail-read-response process))))
			  (not (integerp (car response-code)))
			  (>= (car response-code) 400))
		      (throw 'done nil))))
Richard M. Stallman's avatar
Richard M. Stallman committed
727

728
	    ;; MAIL FROM:<sender>
729
	    (let ((size-part
730 731
		   (if (or (member 'size supported-extensions)
			   (assoc 'size supported-extensions))
732
		       (format " SIZE=%d"
Stefan Monnier's avatar
Stefan Monnier committed
733
			       (with-current-buffer smtpmail-text-buffer
734 735 736
				 ;; size estimate:
				 (+ (- (point-max) (point-min))
				    ;; Add one byte for each change-of-line
737 738
				    ;; because of CR-LF representation:
				    (count-lines (point-min) (point-max)))))
739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757
		     ""))
		  (body-part
		   (if (member '8bitmime supported-extensions)
		       ;; FIXME:
		       ;; Code should be added here that transforms
		       ;; the contents of the message buffer into
		       ;; something the receiving SMTP can handle.
		       ;; For a receiver that supports 8BITMIME, this
		       ;; may mean converting BINARY to BASE64, or
		       ;; adding Content-Transfer-Encoding and the
		       ;; other MIME headers.  The code should also
		       ;; return an indication of what encoding the
		       ;; message buffer is now, i.e. ASCII or
		       ;; 8BITMIME.
		       (if nil
			   " BODY=8BITMIME"
			 "")
		     "")))
;	      (smtpmail-send-command process (format "MAIL FROM:%s@%s" (user-login-name) (smtpmail-fqdn)))
758
	      (smtpmail-send-command process (format "MAIL FROM:<%s>%s%s"
Glenn Morris's avatar
Glenn Morris committed
759
                                                     envelope-from
760 761
						     size-part
						     body-part))
762

763 764 765 766 767
	      (if (or (null (car (setq response-code (smtpmail-read-response process))))
		      (not (integerp (car response-code)))
		      (>= (car response-code) 400))
		  (throw 'done nil)
		))
768

769
	    ;; RCPT TO:<recipient>
770 771
	    (let ((n 0))
	      (while (not (null (nth n recipient)))
772
		(smtpmail-send-command process (format "RCPT TO:<%s>" (smtpmail-maybe-append-domain (nth n recipient))))
773 774
		(setq n (1+ n))

775 776
		(setq response-code (smtpmail-read-response process))
		(if (or (null (car response-code))
777 778 779 780 781
			(not (integerp (car response-code)))
			(>= (car response-code) 400))
		    (throw 'done nil)
		  )
		))
782

Richard M. Stallman's avatar
Richard M. Stallman committed
783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809
	    ;; DATA
	    (smtpmail-send-command process "DATA")

	    (if (or (null (car (setq response-code (smtpmail-read-response process))))
		    (not (integerp (car response-code)))
		    (>= (car response-code) 400))
		(throw 'done nil)
	      )

	    ;; Mail contents
	    (smtpmail-send-data process smtpmail-text-buffer)

	    ;;DATA end "."
	    (smtpmail-send-command process ".")

	    (if (or (null (car (setq response-code (smtpmail-read-response process))))
		    (not (integerp (car response-code)))
		    (>= (car response-code) 400))
		(throw 'done nil)
	      )

	    ;;QUIT
;	    (smtpmail-send-command process "QUIT")
;	    (and (null (car (smtpmail-read-response process)))
;		 (throw 'done nil))
	    t ))
      (if process
Stefan Monnier's avatar
Stefan Monnier committed
810
	  (with-current-buffer (process-buffer process)
Richard M. Stallman's avatar
Richard M. Stallman committed
811 812 813 814 815 816 817 818
	    (smtpmail-send-command process "QUIT")
	    (smtpmail-read-response process)

;	    (if (or (null (car (setq response-code (smtpmail-read-response process))))
;		    (not (integerp (car response-code)))
;		    (>= (car response-code) 400))
;		(throw 'done nil)
;	      )
819 820 821
	    (delete-process process)
	    (unless smtpmail-debug-info
	      (kill-buffer process-buffer)))))))
Richard M. Stallman's avatar
Richard M. Stallman committed
822 823 824


(defun smtpmail-process-filter (process output)
Stefan Monnier's avatar
Stefan Monnier committed
825
  (with-current-buffer (process-buffer process)
Richard M. Stallman's avatar
Richard M. Stallman committed
826 827 828 829 830
    (goto-char (point-max))
    (insert output)))

(defun smtpmail-read-response (process)
  (let ((case-fold-search nil)
831
	(response-strings nil)
Richard M. Stallman's avatar
Richard M. Stallman committed
832
	(response-continue t)
833
	(return-value '(nil ()))
Richard M. Stallman's avatar
Richard M. Stallman committed
834
	match-end)
835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862
    (catch 'done
      (while response-continue
	(goto-char smtpmail-read-point)
	(while (not (search-forward "\r\n" nil t))
	  (unless (memq (process-status process) '(open run))
	    (throw 'done nil))
	  (accept-process-output process)
	  (goto-char smtpmail-read-point))

	(setq match-end (point))
	(setq response-strings
	      (cons (buffer-substring smtpmail-read-point (- match-end 2))
		    response-strings))

	(goto-char smtpmail-read-point)
	(if (looking-at "[0-9]+ ")
	    (let ((begin (match-beginning 0))
		  (end (match-end 0)))
	      (if smtpmail-debug-info
		  (message "%s" (car response-strings)))

	      (setq smtpmail-read-point match-end)

	      ;; ignore lines that start with "0"
	      (if (looking-at "0[0-9]+ ")
		  nil
		(setq response-continue nil)
		(setq return-value
863
		      (cons (string-to-number
864 865 866 867 868 869 870 871 872 873
			     (buffer-substring begin end))
			    (nreverse response-strings)))))

	  (if (looking-at "[0-9]+-")
	      (progn (if smtpmail-debug-info
			 (message "%s" (car response-strings)))
		     (setq smtpmail-read-point match-end)
		     (setq response-continue t))
	    (progn
	      (setq smtpmail-read-point match-end)
874 875
	      (setq response-continue nil)
	      (setq return-value
876 877
		    (cons nil (nreverse response-strings)))))))
      (setq smtpmail-read-point match-end))
Richard M. Stallman's avatar
Richard M. Stallman committed
878 879 880 881 882 883 884 885 886 887 888 889 890 891 892
    return-value))


(defun smtpmail-send-command (process command)
  (goto-char (point-max))
  (if (= (aref command 0) ?P)
      (insert "PASS <omitted>\r\n")
    (insert command "\r\n"))
  (setq smtpmail-read-point (point))
  (process-send-string process command)
  (process-send-string process "\r\n"))

(defun smtpmail-send-data-1 (process data)
  (goto-char (point-max))

Kenichi Handa's avatar
Kenichi Handa committed
893 894 895 896
  (if (and (multibyte-string-p data)
	   smtpmail-code-conv-from)
      (setq data (string-as-multibyte
		  (encode-coding-string data smtpmail-code-conv-from))))
897

Richard M. Stallman's avatar
Richard M. Stallman committed
898 899 900 901
  (if smtpmail-debug-info
      (insert data "\r\n"))

  (setq smtpmail-read-point (point))
902 903
  ;; Escape "." at start of a line
  (if (eq (string-to-char data) ?.)
Richard M. Stallman's avatar
Richard M. Stallman committed
904
      (process-send-string process "."))
905
  (process-send-string process data)
Richard M. Stallman's avatar
Richard M. Stallman committed
906 907 908 909
  (process-send-string process "\r\n")
  )

(defun smtpmail-send-data (process buffer)
910
  (let ((data-continue t) sending-data)
Stefan Monnier's avatar
Stefan Monnier committed
911
    (with-current-buffer buffer
Richard M. Stallman's avatar
Richard M. Stallman committed
912 913
      (goto-char (point-min)))
    (while data-continue
Stefan Monnier's avatar
Stefan Monnier committed
914
      (with-current-buffer buffer
915 916 917 918
        (setq sending-data (buffer-substring (point-at-bol) (point-at-eol)))
	(end-of-line 2)
        (setq data-continue (not (eobp))))
      (smtpmail-send-data-1 process sending-data))))
Richard M. Stallman's avatar
Richard M. Stallman committed
919 920 921

(defun smtpmail-deduce-address-list (smtpmail-text-buffer header-start header-end)
  "Get address list suitable for smtp RCPT TO: <address>."
922
  (unwind-protect
Stefan Monnier's avatar
Stefan Monnier committed
923 924
      (with-current-buffer smtpmail-address-buffer
	(erase-buffer)
925 926 927 928 929 930
	(let
	    ((case-fold-search t)
	     (simple-address-list "")
	     this-line
	     this-line-end
	     addr-regexp)
Richard M. Stallman's avatar
Richard M. Stallman committed
931 932
	  (insert-buffer-substring smtpmail-text-buffer header-start header-end)
	  (goto-char (point-min))
933 934
	  ;; RESENT-* fields should stop processing of regular fields.
	  (save-excursion
Stefan Monnier's avatar
Stefan Monnier committed
935 936 937 938 939
	    (setq addr-regexp
		  (if (re-search-forward "^Resent-\\(to\\|cc\\|bcc\\):"
					 header-end t)
		      "^Resent-\\(to\\|cc\\|bcc\\):"
		    "^\\(To:\\|Cc:\\|Bcc:\\)")))
940 941

	  (while (re-search-forward addr-regexp header-end t)
Richard M. Stallman's avatar
Richard M. Stallman committed
942 943 944 945 946 947 948 949 950 951 952 953
	    (replace-match "")
	    (setq this-line (match-beginning 0))
	    (forward-line 1)
	    ;; get any continuation lines
	    (while (and (looking-at "^[ \t]+") (< (point) header-end))
	      (forward-line 1))
	    (setq this-line-end (point-marker))
	    (setq simple-address-list
		  (concat simple-address-list " "
			  (mail-strip-quoted-names (buffer-substring this-line this-line-end))))
	    )
	  (erase-buffer)
954
	  (insert " " simple-address-list "\n")
Richard M. Stallman's avatar
Richard M. Stallman committed
955 956 957 958 959 960 961 962 963
	  (subst-char-in-region (point-min) (point-max) 10 ?  t);; newline --> blank
	  (subst-char-in-region (point-min) (point-max) ?, ?  t);; comma   --> blank
	  (subst-char-in-region (point-min) (point-max)  9 ?  t);; tab     --> blank

	  (goto-char (point-min))
	  ;; tidyness in case hook is not robust when it looks at this
	  (while (re-search-forward "[ \t]+" header-end t) (replace-match " "))

	  (goto-char (point-min))
964
	  (let (recipient-address-list)
965
	    (while (re-search-forward " \\([^ ]+\\) " (point-max) t)
966
	      (backward-char 1)
967 968
	      (setq recipient-address-list (cons (buffer-substring (match-beginning 1) (match-end 1))
						 recipient-address-list))
969 970
	      )
	    (setq smtpmail-recipient-address-list recipient-address-list))
Richard M. Stallman's avatar
Richard M. Stallman committed
971 972

	  )
973
	)
Richard M. Stallman's avatar
Richard M. Stallman committed
974 975 976 977 978
    )
  )


(defun smtpmail-do-bcc (header-end)
979
  "Delete [Resent-]BCC: and their continuation lines from the header area.
Richard M. Stallman's avatar
Richard M. Stallman committed
980 981 982
There may be multiple BCC: lines, and each may have arbitrarily
many continuation lines."
  (let ((case-fold-search t))
Karl Heuer's avatar
Karl Heuer committed
983 984 985 986 987 988 989 990 991
    (save-excursion
      (goto-char (point-min))
      ;; iterate over all BCC: lines
      (while (re-search-forward "^\\(RESENT-\\)?BCC:" header-end t)
	(delete-region (match-beginning 0)
		       (progn (forward-line 1) (point)))
	;; get rid of any continuation lines
	(while (and (looking-at "^[ \t].*\n") (< (point) header-end))
	  (replace-match ""))))))
Richard M. Stallman's avatar
Richard M. Stallman committed
992 993 994 995


(provide 'smtpmail)

Miles Bader's avatar
Miles Bader committed
996
;;; arch-tag: a76992df-6d71-43b7-9e72-4bacc6c05466
Richard M. Stallman's avatar
Richard M. Stallman committed
997
;;; smtpmail.el ends here