1 ;;; smtpmail.el --- simple SMTP protocol (RFC 821) for sending mail
3 ;; Copyright (C) 1995, 1996, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
4 ;; 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
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>
15 ;; This file is part of GNU Emacs.
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.
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.
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/>.
32 ;; Send Mail to smtp host from smtpmail temp buffer.
34 ;; Please add these lines in your .emacs(_emacs) or use customize.
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).
49 ;; To queue mail, set `smtpmail-queue-mail' to t and use
50 ;; `smtpmail-send-queued-mail' to send.
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
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
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
70 (autoload 'starttls-any-program-available
"starttls")
71 (autoload 'starttls-open-stream
"starttls")
72 (autoload 'starttls-negotiate
"starttls")
73 (autoload 'mail-strip-quoted-names
"mail-utils")
74 (autoload 'message-make-date
"message")
75 (autoload 'message-make-message-id
"message")
76 (autoload 'rfc2104-hash
"rfc2104")
77 (autoload 'netrc-parse
"netrc")
78 (autoload 'netrc-machine
"netrc")
79 (autoload 'netrc-get
"netrc")
80 (autoload 'password-read
"password-cache")
81 (autoload 'auth-source-user-or-password
"auth-source")
84 (defgroup smtpmail nil
85 "SMTP protocol for sending mail."
89 (defcustom smtpmail-default-smtp-server nil
90 "Specify default SMTP server.
91 This only has effect if you specify it before loading the smtpmail library."
92 :type
'(choice (const nil
) string
)
95 (defcustom smtpmail-smtp-server
96 (or (getenv "SMTPSERVER") smtpmail-default-smtp-server
)
97 "The name of the host running SMTP server."
98 :type
'(choice (const nil
) string
)
101 (defcustom smtpmail-smtp-service
25
102 "SMTP service port number.
103 The default value would be \"smtp\" or 25."
104 :type
'(choice (integer :tag
"Port") (string :tag
"Service"))
107 (defcustom smtpmail-local-domain nil
108 "Local domain name without a host name.
109 If the function `system-name' returns the full internet address,
110 don't define this value."
111 :type
'(choice (const nil
) string
)
114 (defcustom smtpmail-sendto-domain nil
115 "Local domain name without a host name.
116 This is appended (with an @-sign) to any specified recipients which do
117 not include an @-sign, so that each RCPT TO address is fully qualified.
118 \(Some configurations of sendmail require this.)
120 Don't bother to set this unless you have get an error like:
121 Sending failed; SMTP protocol error
122 when sending mail, and the *trace of SMTP session to <somewhere>*
123 buffer includes an exchange like:
125 501 <someone>: recipient address must contain a domain."
126 :type
'(choice (const nil
) string
)
129 (defcustom smtpmail-debug-info nil
130 "Whether to print info in buffer *trace of SMTP session to <somewhere>*.
131 See also `smtpmail-debug-verb' which determines if the SMTP protocol should
136 (defcustom smtpmail-debug-verb nil
137 "Whether this library sends the SMTP VERB command or not.
138 The commands enables verbose information from the SMTP server."
142 (defcustom smtpmail-code-conv-from nil
143 "Coding system for encoding outgoing mail.
144 Used for the value of `sendmail-coding-system' when
145 `select-message-coding-system' is called. "
149 (defcustom smtpmail-queue-mail nil
150 "Non-nil means mail is queued; otherwise it is sent immediately.
151 If queued, it is stored in the directory `smtpmail-queue-dir'
152 and sent with `smtpmail-send-queued-mail'."
156 (defcustom smtpmail-queue-dir
"~/Mail/queued-mail/"
157 "Directory where `smtpmail.el' stores queued mail."
161 (defcustom smtpmail-auth-credentials
"~/.authinfo"
162 "Specify username and password for servers, directly or via .netrc file.
163 This variable can either be a filename pointing to a file in netrc(5)
164 format, or list of four-element lists that contain, in order,
165 `servername' (a string), `port' (an integer), `user' (a string) and
166 `password' (a string, or nil to query the user when needed). If you
167 need to enter a `realm' too, add it to the user string, so that it
168 looks like `user@realm'."
170 (repeat (list (string :tag
"Server")
171 (integer :tag
"Port")
172 (string :tag
"Username")
173 (choice (const :tag
"Query when needed" nil
)
174 (string :tag
"Password")))))
178 (defcustom smtpmail-starttls-credentials
'(("" 25 "" ""))
179 "Specify STARTTLS keys and certificates for servers.
180 This is a list of four-element list with `servername' (a string),
181 `port' (an integer), `key' (a filename) and `certificate' (a
183 If you do not have a certificate/key pair, leave the `key' and
184 `certificate' fields as `nil'. A key/certificate pair is only
185 needed if you want to use X.509 client authenticated
187 :type
'(repeat (list (string :tag
"Server")
188 (integer :tag
"Port")
190 (file :tag
"Certificate")))
194 (defcustom smtpmail-warn-about-unknown-extensions nil
195 "If set, print warnings about unknown SMTP extensions.
196 This is mainly useful for development purposes, to learn about
197 new SMTP extensions that might be useful to support."
202 (defcustom smtpmail-queue-index-file
"index"
203 "File name of queued mail index.
204 This is relative to `smtpmail-queue-dir'."
208 ;; End of customizable variables.
211 (defvar smtpmail-address-buffer
)
212 (defvar smtpmail-recipient-address-list
)
214 (defvar smtpmail-queue-counter
0)
216 ;; Buffer-local variable.
217 (defvar smtpmail-read-point
)
219 (defconst smtpmail-auth-supported
'(cram-md5 plain login
)
220 "List of supported SMTP AUTH mechanisms.
221 The list is in preference order.")
223 (defvar smtpmail-mail-address nil
224 "Value to use for envelope-from address for mail from ambient buffer.")
227 (defun smtpmail-send-it ()
228 (let ((errbuf (if mail-interactive
229 (generate-new-buffer " smtpmail errors")
231 (tembuf (generate-new-buffer " smtpmail temp"))
232 (case-fold-search nil
)
234 (mailbuf (current-buffer))
235 ;; Examine this variable now, so that
236 ;; local binding in the mail buffer will take effect.
237 (smtpmail-mail-address
238 (or (and mail-specify-envelope-from
(mail-envelope-from))
240 (smtpmail-code-conv-from
241 (if enable-multibyte-characters
242 (let ((sendmail-coding-system smtpmail-code-conv-from
))
243 (select-message-coding-system)))))
245 (with-current-buffer tembuf
247 ;; Use the same `buffer-file-coding-system' as in the mail
248 ;; buffer, otherwise any `write-region' invocations (e.g., in
249 ;; mail-do-fcc below) will annoy with asking for a suitable
251 (set-buffer-file-coding-system smtpmail-code-conv-from nil t
)
252 (insert-buffer-substring mailbuf
)
253 (goto-char (point-max))
254 ;; require one newline at the end.
255 (or (= (preceding-char) ?
\n)
257 ;; Change header-delimiter to be what sendmail expects.
258 (mail-sendmail-undelimit-header)
259 (setq delimline
(point-marker))
260 ;; (sendmail-synch-aliases)
262 (expand-mail-aliases (point-min) delimline
))
263 (goto-char (point-min))
264 ;; ignore any blank lines in the header
265 (while (and (re-search-forward "\n\n\n*" delimline t
)
266 (< (point) delimline
))
267 (replace-match "\n"))
268 (let ((case-fold-search t
))
269 ;; We used to process Resent-... headers here,
270 ;; but it was not done properly, and the job
271 ;; is done correctly in `smtpmail-deduce-address-list'.
272 ;; Don't send out a blank subject line
273 (goto-char (point-min))
274 (if (re-search-forward "^Subject:\\([ \t]*\n\\)+\\b" delimline t
)
276 ;; This one matches a Subject just before the header delimiter.
277 (if (and (re-search-forward "^Subject:\\([ \t]*\n\\)+" delimline t
)
278 (= (match-end 0) delimline
))
280 ;; Put the "From:" field in unless for some odd reason
281 ;; they put one in themselves.
282 (goto-char (point-min))
283 (if (not (re-search-forward "^From:" delimline t
))
284 (let* ((login smtpmail-mail-address
)
285 (fullname (user-full-name)))
286 (cond ((eq mail-from-style
'angles
)
287 (insert "From: " fullname
)
288 (let ((fullname-start (+ (point-min) 6))
289 (fullname-end (point-marker)))
290 (goto-char fullname-start
)
291 ;; Look for a character that cannot appear unquoted
292 ;; according to RFC 822.
293 (if (re-search-forward "[^- !#-'*+/-9=?A-Z^-~]"
296 ;; Quote fullname, escaping specials.
297 (goto-char fullname-start
)
299 (while (re-search-forward "[\"\\]"
301 (replace-match "\\\\\\&" t
))
303 (insert " <" login
">\n"))
304 ((eq mail-from-style
'parens
)
305 (insert "From: " login
" (")
306 (let ((fullname-start (point)))
308 (let ((fullname-end (point-marker)))
309 (goto-char fullname-start
)
310 ;; RFC 822 says \ and nonmatching parentheses
311 ;; must be escaped in comments.
312 ;; Escape every instance of ()\ ...
313 (while (re-search-forward "[()\\]" fullname-end
1)
314 (replace-match "\\\\\\&" t
))
315 ;; ... then undo escaping of matching parentheses,
316 ;; including matching nested parentheses.
317 (goto-char fullname-start
)
318 (while (re-search-forward
319 "\\(\\=\\|[^\\]\\(\\\\\\\\\\)*\\)\\\\(\\(\\([^\\]\\|\\\\\\\\\\)*\\)\\\\)"
321 (replace-match "\\1(\\3)" t
)
322 (goto-char fullname-start
))))
324 ((null mail-from-style
)
325 (insert "From: " login
"\n")))))
326 ;; Insert a `Message-Id:' field if there isn't one yet.
327 (goto-char (point-min))
328 (unless (re-search-forward "^Message-Id:" delimline t
)
329 (insert "Message-Id: " (message-make-message-id) "\n"))
330 ;; Insert a `Date:' field if there isn't one yet.
331 (goto-char (point-min))
332 (unless (re-search-forward "^Date:" delimline t
)
333 (insert "Date: " (message-make-date) "\n"))
334 ;; Possibly add a MIME header for the current coding system
336 (goto-char (point-min))
337 (and (eq mail-send-nonascii
'mime
)
338 (not (re-search-forward "^MIME-version:" delimline t
))
339 (progn (skip-chars-forward "\0-\177")
340 (/= (point) (point-max)))
341 smtpmail-code-conv-from
343 (coding-system-get smtpmail-code-conv-from
345 (goto-char delimline
)
346 (insert "MIME-version: 1.0\n"
347 "Content-type: text/plain; charset="
348 (symbol-name charset
)
349 "\nContent-Transfer-Encoding: 8bit\n")))
350 ;; Insert an extra newline if we need it to work around
351 ;; Sun's bug that swallows newlines.
352 (goto-char (1+ delimline
))
353 (if (eval mail-mailer-swallows-blank-line
)
355 ;; Find and handle any FCC fields.
356 (goto-char (point-min))
357 (if (re-search-forward "^FCC:" delimline t
)
358 ;; Force `mail-do-fcc' to use the encoding of the mail
359 ;; buffer to encode outgoing messages on FCC files.
360 (let ((coding-system-for-write smtpmail-code-conv-from
))
361 (mail-do-fcc delimline
)))
363 (with-current-buffer errbuf
365 ;; Encode the header according to RFC2047.
366 (mail-encode-header (point-min) delimline
)
368 (setq smtpmail-address-buffer
(generate-new-buffer "*smtp-mail*"))
369 (setq smtpmail-recipient-address-list
370 (smtpmail-deduce-address-list tembuf
(point-min) delimline
))
371 (kill-buffer smtpmail-address-buffer
)
373 (smtpmail-do-bcc delimline
)
375 (if (not smtpmail-queue-mail
)
376 (if (not (null smtpmail-recipient-address-list
))
377 (if (not (smtpmail-via-smtp
378 smtpmail-recipient-address-list tembuf
))
379 (error "Sending failed; SMTP protocol error"))
380 (error "Sending failed; no recipients"))
384 (format-time-string "%Y-%m-%d_%H:%M:%S")
385 (setq smtpmail-queue-counter
386 (1+ smtpmail-queue-counter
)))
388 (file-data (convert-standard-filename file-data
))
389 (file-elisp (concat file-data
".el"))
390 (buffer-data (create-file-buffer file-data
))
391 (buffer-elisp (create-file-buffer file-elisp
))
392 (buffer-scratch "*queue-mail*"))
393 (unless (file-exists-p smtpmail-queue-dir
)
394 (make-directory smtpmail-queue-dir t
))
395 (with-current-buffer buffer-data
397 (set-buffer-file-coding-system
398 ;; We will be reading the file with no-conversion in
399 ;; smtpmail-send-queued-mail below, so write it out
401 (coding-system-change-eol-conversion
402 (or smtpmail-code-conv-from
'undecided
)
405 (insert-buffer-substring tembuf
)
406 (write-file file-data
)
407 (set-buffer buffer-elisp
)
410 "(setq smtpmail-recipient-address-list '"
411 (prin1-to-string smtpmail-recipient-address-list
)
413 (write-file file-elisp
)
414 (set-buffer (generate-new-buffer buffer-scratch
))
415 (insert (concat file-data
"\n"))
416 (append-to-file (point-min)
418 (expand-file-name smtpmail-queue-index-file
419 smtpmail-queue-dir
)))
420 (kill-buffer buffer-scratch
)
421 (kill-buffer buffer-data
)
422 (kill-buffer buffer-elisp
))))
425 (kill-buffer errbuf
)))))
428 (defun smtpmail-send-queued-mail ()
429 "Send mail that was queued as a result of setting `smtpmail-queue-mail'."
432 ;; Get index, get first mail, send it, update index, get second
433 ;; mail, send it, etc...
435 (qfile (expand-file-name smtpmail-queue-index-file
436 smtpmail-queue-dir
)))
437 (insert-file-contents qfile
)
438 (goto-char (point-min))
440 (setq file-msg
(buffer-substring (point) (line-end-position)))
442 ;; Insert the message literally: it is already encoded as per
443 ;; the MIME headers, and code conversions might guess the
446 (let ((coding-system-for-read 'no-conversion
))
447 (insert-file-contents file-msg
))
448 (let ((smtpmail-mail-address
449 (or (and mail-specify-envelope-from
(mail-envelope-from))
451 (if (not (null smtpmail-recipient-address-list
))
452 (if (not (smtpmail-via-smtp smtpmail-recipient-address-list
454 (error "Sending failed; SMTP protocol error"))
455 (error "Sending failed; no recipients"))))
456 (delete-file file-msg
)
457 (delete-file (concat file-msg
".el"))
458 (delete-region (point-at-bol) (point-at-bol 2)))
459 (write-region (point-min) (point-max) qfile
))))
461 ;; (defun smtpmail-via-smtp (host,port,sender,destination,smtpmail-text-buffer)
463 (defun smtpmail-fqdn ()
464 (if smtpmail-local-domain
465 (concat (system-name) "." smtpmail-local-domain
)
468 (defsubst smtpmail-cred-server
(cred)
471 (defsubst smtpmail-cred-port
(cred)
474 (defsubst smtpmail-cred-key
(cred)
477 (defsubst smtpmail-cred-user
(cred)
480 (defsubst smtpmail-cred-cert
(cred)
483 (defsubst smtpmail-cred-passwd
(cred)
486 (defun smtpmail-find-credentials (cred server port
)
489 (while (setq el
(pop l
))
490 (when (and (equal server
(smtpmail-cred-server el
))
491 (equal port
(smtpmail-cred-port el
)))
492 (throw 'done el
))))))
494 (defun smtpmail-maybe-append-domain (recipient)
495 (if (or (not smtpmail-sendto-domain
)
496 (string-match "@" recipient
))
498 (concat recipient
"@" smtpmail-sendto-domain
)))
500 (defun smtpmail-intersection (list1 list2
)
503 (when (memq el2 list1
)
507 (defvar starttls-extra-args
)
508 (defvar starttls-extra-arguments
)
510 (defun smtpmail-open-stream (process-buffer host port
)
511 (let ((cred (smtpmail-find-credentials
512 smtpmail-starttls-credentials host port
)))
513 (if (null (and cred
(starttls-any-program-available)))
515 (open-network-stream "SMTP" process-buffer host port
)
516 (let* ((cred-key (smtpmail-cred-key cred
))
517 (cred-cert (smtpmail-cred-cert cred
))
521 (when (and (stringp cred-key
) (stringp cred-cert
)
523 (setq cred-key
(expand-file-name cred-key
)))
525 (setq cred-cert
(expand-file-name cred-cert
))))
526 (list "--key-file" cred-key
"--cert-file" cred-cert
))))
527 (starttls-extra-arguments
529 starttls-extra-arguments
530 (when (and (stringp cred-key
) (stringp cred-cert
)
532 (setq cred-key
(expand-file-name cred-key
)))
534 (setq cred-cert
(expand-file-name cred-cert
))))
535 (list "--x509keyfile" cred-key
"--x509certfile" cred-cert
)))))
536 (starttls-open-stream "SMTP" process-buffer host port
)))))
538 ;; `password-read' autoloads password-cache.
539 (declare-function password-cache-add
"password-cache" (key password
))
541 (defun smtpmail-try-auth-methods (process supported-extensions host port
)
542 (let* ((mechs (cdr-safe (assoc 'auth supported-extensions
)))
543 (mech (car (smtpmail-intersection mechs smtpmail-auth-supported
)))
544 (auth-user (auth-source-user-or-password
545 "login" host
(or port
"smtp")))
546 (auth-pass (auth-source-user-or-password
547 "password" host
(or port
"smtp")))
548 (cred (if (and auth-user auth-pass
) ; try user-auth-* before netrc-*
549 (list host port auth-user auth-pass
)
550 ;; else, if auth-source didn't return them...
551 (if (stringp smtpmail-auth-credentials
)
552 (let* ((netrc (netrc-parse smtpmail-auth-credentials
))
553 (port-name (format "%s" (or port
"smtp")))
554 (hostentry (netrc-machine netrc host port-name
558 (netrc-get hostentry
"login")
559 (netrc-get hostentry
"password"))))
560 ;; else, try `smtpmail-find-credentials' since
561 ;; `smtpmail-auth-credentials' is not a string
562 (smtpmail-find-credentials
563 smtpmail-auth-credentials host port
))))
564 (prompt (when cred
(format "SMTP password for %s:%s: "
565 (smtpmail-cred-server cred
)
566 (smtpmail-cred-port cred
))))
568 (or (smtpmail-cred-passwd cred
)
569 (password-read prompt prompt
))))
571 (when (and cred mech
)
574 (smtpmail-send-command process
(upcase (format "AUTH %s" mech
)))
575 (if (or (null (car (setq ret
(smtpmail-read-response process
))))
576 (not (integerp (car ret
)))
579 (when (eq (car ret
) 334)
580 (let* ((challenge (substring (cadr ret
) 4))
581 (decoded (base64-decode-string challenge
))
582 (hash (rfc2104-hash 'md5
64 16 passwd decoded
))
583 (response (concat (smtpmail-cred-user cred
) " " hash
))
584 ;; Osamu Yamane <yamane@green.ocn.ne.jp>:
585 ;; SMTP auth fails because the SMTP server identifies
586 ;; only the first part of the string (delimited by
587 ;; new line characters) as a response from the
588 ;; client, and the rest as distinct commands.
590 ;; In my case, the response string is 80 characters
591 ;; long. Without the no-line-break option for
592 ;; `base64-encode-string', only the first 76 characters
593 ;; are taken as a response to the server, and the
594 ;; authentication fails.
595 (encoded (base64-encode-string response t
)))
596 (smtpmail-send-command process
(format "%s" encoded
))
597 (if (or (null (car (setq ret
(smtpmail-read-response process
))))
598 (not (integerp (car ret
)))
600 (throw 'done nil
)))))
602 (smtpmail-send-command process
"AUTH LOGIN")
603 (if (or (null (car (setq ret
(smtpmail-read-response process
))))
604 (not (integerp (car ret
)))
607 (smtpmail-send-command
608 process
(base64-encode-string (smtpmail-cred-user cred
) t
))
609 (if (or (null (car (setq ret
(smtpmail-read-response process
))))
610 (not (integerp (car ret
)))
613 (smtpmail-send-command process
(base64-encode-string passwd t
))
614 (if (or (null (car (setq ret
(smtpmail-read-response process
))))
615 (not (integerp (car ret
)))
619 ;; We used to send an empty initial request, and wait for an
620 ;; empty response, and then send the password, but this
621 ;; violate a SHOULD in RFC 2222 paragraph 5.1. Note that this
622 ;; is not sent if the server did not advertise AUTH PLAIN in
623 ;; the EHLO response. See RFC 2554 for more info.
624 (smtpmail-send-command process
625 (concat "AUTH PLAIN "
626 (base64-encode-string
628 (smtpmail-cred-user cred
)
631 (if (or (null (car (setq ret
(smtpmail-read-response process
))))
632 (not (integerp (car ret
)))
633 (not (equal (car ret
) 235)))
637 (error "Mechanism %s not implemented" mech
)))
638 ;; Remember the password.
639 (when (null (smtpmail-cred-passwd cred
))
640 (password-cache-add prompt passwd
)))))
642 (defun smtpmail-via-smtp (recipient smtpmail-text-buffer
)
644 (host (or smtpmail-smtp-server
645 (error "`smtpmail-smtp-server' not defined")))
646 (port smtpmail-smtp-service
)
647 ;; `smtpmail-mail-address' should be set to the appropriate
648 ;; buffer-local value by the caller, but in case not:
649 (envelope-from (or smtpmail-mail-address
650 (and mail-specify-envelope-from
651 (mail-envelope-from))
656 (supported-extensions '()))
659 ;; get or create the trace buffer
661 (get-buffer-create (format "*trace of SMTP session to %s*" host
)))
663 ;; clear the trace buffer of old output
664 (with-current-buffer process-buffer
665 (setq buffer-undo-list t
)
668 ;; open the connection to the server
669 (setq process
(smtpmail-open-stream process-buffer host port
))
670 (and (null process
) (throw 'done nil
))
672 ;; set the send-filter
673 (set-process-filter process
'smtpmail-process-filter
)
675 (with-current-buffer process-buffer
676 (set-buffer-process-coding-system 'raw-text-unix
'raw-text-unix
)
677 (make-local-variable 'smtpmail-read-point
)
678 (setq smtpmail-read-point
(point-min))
681 (if (or (null (car (setq greeting
(smtpmail-read-response process
))))
682 (not (integerp (car greeting
)))
683 (>= (car greeting
) 400))
690 (smtpmail-send-command process
(format "EHLO %s" (smtpmail-fqdn)))
692 (if (or (null (car (setq response-code
693 (smtpmail-read-response process
))))
694 (not (integerp (car response-code
)))
695 (>= (car response-code
) 400))
698 (smtpmail-send-command
699 process
(format "HELO %s" (smtpmail-fqdn)))
701 (if (or (null (car (setq response-code
702 (smtpmail-read-response process
))))
703 (not (integerp (car response-code
)))
704 (>= (car response-code
) 400))
706 (dolist (line (cdr (cdr response-code
)))
708 (with-case-table ascii-case-table
709 (mapcar (lambda (s) (intern (downcase s
)))
710 (split-string (substring line
4) "[ ]")))))
711 (and (eq (length name
) 1)
712 (setq name
(car name
)))
714 (cond ((memq (if (consp name
) (car name
) name
)
715 '(verb xvrb
8bitmime onex xone
719 auth
=login auth starttls
))
720 (setq supported-extensions
721 (cons name supported-extensions
)))
722 (smtpmail-warn-about-unknown-extensions
723 (message "Unknown extension %s" name
)))))))
726 (smtpmail-find-credentials smtpmail-starttls-credentials host port
)
727 (member 'starttls supported-extensions
)
728 (numberp (process-id process
)))
730 (smtpmail-send-command process
(format "STARTTLS"))
731 (if (or (null (car (setq response-code
(smtpmail-read-response process
))))
732 (not (integerp (car response-code
)))
733 (>= (car response-code
) 400))
735 (starttls-negotiate process
)
736 (setq do-starttls nil
))
737 (setq do-ehlo nil
))))
739 (smtpmail-try-auth-methods process supported-extensions host port
)
741 (if (or (member 'onex supported-extensions
)
742 (member 'xone supported-extensions
))
744 (smtpmail-send-command process
(format "ONEX"))
745 (if (or (null (car (setq response-code
(smtpmail-read-response process
))))
746 (not (integerp (car response-code
)))
747 (>= (car response-code
) 400))
750 (if (and smtpmail-debug-verb
751 (or (member 'verb supported-extensions
)
752 (member 'xvrb supported-extensions
)))
754 (smtpmail-send-command process
(format "VERB"))
755 (if (or (null (car (setq response-code
(smtpmail-read-response process
))))
756 (not (integerp (car response-code
)))
757 (>= (car response-code
) 400))
760 (if (member 'xusr supported-extensions
)
762 (smtpmail-send-command process
(format "XUSR"))
763 (if (or (null (car (setq response-code
(smtpmail-read-response process
))))
764 (not (integerp (car response-code
)))
765 (>= (car response-code
) 400))
768 ;; MAIL FROM:<sender>
770 (if (or (member 'size supported-extensions
)
771 (assoc 'size supported-extensions
))
773 (with-current-buffer smtpmail-text-buffer
775 (+ (- (point-max) (point-min))
776 ;; Add one byte for each change-of-line
777 ;; because of CR-LF representation:
778 (count-lines (point-min) (point-max)))))
781 (if (member '8bitmime supported-extensions
)
783 ;; Code should be added here that transforms
784 ;; the contents of the message buffer into
785 ;; something the receiving SMTP can handle.
786 ;; For a receiver that supports 8BITMIME, this
787 ;; may mean converting BINARY to BASE64, or
788 ;; adding Content-Transfer-Encoding and the
789 ;; other MIME headers. The code should also
790 ;; return an indication of what encoding the
791 ;; message buffer is now, i.e. ASCII or
797 ;; (smtpmail-send-command process (format "MAIL FROM:%s@%s" (user-login-name) (smtpmail-fqdn)))
798 (smtpmail-send-command process
(format "MAIL FROM:<%s>%s%s"
803 (if (or (null (car (setq response-code
(smtpmail-read-response process
))))
804 (not (integerp (car response-code
)))
805 (>= (car response-code
) 400))
808 ;; RCPT TO:<recipient>
810 (while (not (null (nth n recipient
)))
811 (smtpmail-send-command process
(format "RCPT TO:<%s>" (smtpmail-maybe-append-domain (nth n recipient
))))
814 (setq response-code
(smtpmail-read-response process
))
815 (if (or (null (car response-code
))
816 (not (integerp (car response-code
)))
817 (>= (car response-code
) 400))
821 (smtpmail-send-command process
"DATA")
823 (if (or (null (car (setq response-code
(smtpmail-read-response process
))))
824 (not (integerp (car response-code
)))
825 (>= (car response-code
) 400))
829 (smtpmail-send-data process smtpmail-text-buffer
)
832 (smtpmail-send-command process
".")
834 (if (or (null (car (setq response-code
(smtpmail-read-response process
))))
835 (not (integerp (car response-code
)))
836 (>= (car response-code
) 400))
840 ;; (smtpmail-send-command process "QUIT")
841 ;; (and (null (car (smtpmail-read-response process)))
842 ;; (throw 'done nil))
845 (with-current-buffer (process-buffer process
)
846 (smtpmail-send-command process
"QUIT")
847 (smtpmail-read-response process
)
849 ;; (if (or (null (car (setq response-code (smtpmail-read-response process))))
850 ;; (not (integerp (car response-code)))
851 ;; (>= (car response-code) 400))
852 ;; (throw 'done nil))
853 (delete-process process
)
854 (unless smtpmail-debug-info
855 (kill-buffer process-buffer
)))))))
858 (defun smtpmail-process-filter (process output
)
859 (with-current-buffer (process-buffer process
)
860 (goto-char (point-max))
863 (defun smtpmail-read-response (process)
864 (let ((case-fold-search nil
)
865 (response-strings nil
)
866 (response-continue t
)
867 (return-value '(nil ()))
870 (while response-continue
871 (goto-char smtpmail-read-point
)
872 (while (not (search-forward "\r\n" nil t
))
873 (unless (memq (process-status process
) '(open run
))
875 (accept-process-output process
)
876 (goto-char smtpmail-read-point
))
878 (setq match-end
(point))
879 (setq response-strings
880 (cons (buffer-substring smtpmail-read-point
(- match-end
2))
883 (goto-char smtpmail-read-point
)
884 (if (looking-at "[0-9]+ ")
885 (let ((begin (match-beginning 0))
887 (if smtpmail-debug-info
888 (message "%s" (car response-strings
)))
890 (setq smtpmail-read-point match-end
)
892 ;; ignore lines that start with "0"
893 (if (looking-at "0[0-9]+ ")
895 (setq response-continue nil
)
897 (cons (string-to-number
898 (buffer-substring begin end
))
899 (nreverse response-strings
)))))
901 (if (looking-at "[0-9]+-")
902 (progn (if smtpmail-debug-info
903 (message "%s" (car response-strings
)))
904 (setq smtpmail-read-point match-end
)
905 (setq response-continue t
))
907 (setq smtpmail-read-point match-end
)
908 (setq response-continue nil
)
910 (cons nil
(nreverse response-strings
)))))))
911 (setq smtpmail-read-point match-end
))
915 (defun smtpmail-send-command (process command
)
916 (goto-char (point-max))
917 (if (= (aref command
0) ?P
)
918 (insert "PASS <omitted>\r\n")
919 (insert command
"\r\n"))
920 (setq smtpmail-read-point
(point))
921 (process-send-string process command
)
922 (process-send-string process
"\r\n"))
924 (defun smtpmail-send-data-1 (process data
)
925 (goto-char (point-max))
927 (if (and (multibyte-string-p data
)
928 smtpmail-code-conv-from
)
929 (setq data
(string-as-multibyte
930 (encode-coding-string data smtpmail-code-conv-from
))))
932 (if smtpmail-debug-info
933 (insert data
"\r\n"))
935 (setq smtpmail-read-point
(point))
936 ;; Escape "." at start of a line
937 (if (eq (string-to-char data
) ?.
)
938 (process-send-string process
"."))
939 (process-send-string process data
)
940 (process-send-string process
"\r\n"))
942 (defun smtpmail-send-data (process buffer
)
943 (let ((data-continue t
) sending-data
)
944 (with-current-buffer buffer
945 (goto-char (point-min)))
947 (with-current-buffer buffer
948 (setq sending-data
(buffer-substring (point-at-bol) (point-at-eol)))
950 (setq data-continue
(not (eobp))))
951 (smtpmail-send-data-1 process sending-data
))))
953 (defun smtpmail-deduce-address-list (smtpmail-text-buffer header-start header-end
)
954 "Get address list suitable for smtp RCPT TO: <address>."
956 (with-current-buffer smtpmail-address-buffer
958 (let ((case-fold-search t
)
959 (simple-address-list "")
963 (insert-buffer-substring smtpmail-text-buffer header-start header-end
)
964 (goto-char (point-min))
965 ;; RESENT-* fields should stop processing of regular fields.
968 (if (re-search-forward "^Resent-\\(to\\|cc\\|bcc\\):"
970 "^Resent-\\(to\\|cc\\|bcc\\):"
971 "^\\(To:\\|Cc:\\|Bcc:\\)")))
973 (while (re-search-forward addr-regexp header-end t
)
975 (setq this-line
(match-beginning 0))
977 ;; get any continuation lines
978 (while (and (looking-at "^[ \t]+") (< (point) header-end
))
980 (setq this-line-end
(point-marker))
981 (setq simple-address-list
982 (concat simple-address-list
" "
983 (mail-strip-quoted-names (buffer-substring this-line this-line-end
)))))
985 (insert " " simple-address-list
"\n")
986 (subst-char-in-region (point-min) (point-max) 10 ? t
) ; newline --> blank
987 (subst-char-in-region (point-min) (point-max) ?
, ? t
) ; comma --> blank
988 (subst-char-in-region (point-min) (point-max) 9 ? t
) ; tab --> blank
990 (goto-char (point-min))
991 ;; tidyness in case hook is not robust when it looks at this
992 (while (re-search-forward "[ \t]+" header-end t
) (replace-match " "))
994 (goto-char (point-min))
995 (let (recipient-address-list)
996 (while (re-search-forward " \\([^ ]+\\) " (point-max) t
)
998 (setq recipient-address-list
(cons (buffer-substring (match-beginning 1) (match-end 1))
999 recipient-address-list
)))
1000 (setq smtpmail-recipient-address-list recipient-address-list
))))))
1002 (defun smtpmail-do-bcc (header-end)
1003 "Delete [Resent-]BCC: and their continuation lines from the header area.
1004 There may be multiple BCC: lines, and each may have arbitrarily
1005 many continuation lines."
1006 (let ((case-fold-search t
))
1008 (goto-char (point-min))
1009 ;; iterate over all BCC: lines
1010 (while (re-search-forward "^\\(RESENT-\\)?BCC:" header-end t
)
1011 (delete-region (match-beginning 0)
1012 (progn (forward-line 1) (point)))
1013 ;; get rid of any continuation lines
1014 (while (and (looking-at "^[ \t].*\n") (< (point) header-end
))
1015 (replace-match ""))))))
1019 ;;; smtpmail.el ends here