1 ;;; smtpmail.el --- simple SMTP protocol (RFC 821) for sending mail
3 ;; Copyright (C) 1995, 1996, 2001, 2002, 2003, 2004, 2005,
4 ;; 2006, 2007, 2008 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-open-stream
"starttls")
71 (autoload 'starttls-negotiate
"starttls")
72 (autoload 'mail-strip-quoted-names
"mail-utils")
73 (autoload 'message-make-date
"message")
74 (autoload 'message-make-message-id
"message")
75 (autoload 'rfc2104-hash
"rfc2104")
76 (autoload 'netrc-parse
"netrc")
77 (autoload 'netrc-machine
"netrc")
78 (autoload 'netrc-get
"netrc")
79 (autoload 'password-read
"password-cache")
82 (autoload 'auth-source-user-or-password
"auth-source"))
85 (defgroup smtpmail nil
86 "SMTP protocol for sending mail."
90 (defcustom smtpmail-default-smtp-server nil
91 "Specify default SMTP server.
92 This only has effect if you specify it before loading the smtpmail library."
93 :type
'(choice (const nil
) string
)
96 (defcustom smtpmail-smtp-server
97 (or (getenv "SMTPSERVER") smtpmail-default-smtp-server
)
98 "The name of the host running SMTP server."
99 :type
'(choice (const nil
) string
)
102 (defcustom smtpmail-smtp-service
25
103 "SMTP service port number.
104 The default value would be \"smtp\" or 25."
105 :type
'(choice (integer :tag
"Port") (string :tag
"Service"))
108 (defcustom smtpmail-local-domain nil
109 "Local domain name without a host name.
110 If the function `system-name' returns the full internet address,
111 don't define this value."
112 :type
'(choice (const nil
) string
)
115 (defcustom smtpmail-sendto-domain nil
116 "Local domain name without a host name.
117 This is appended (with an @-sign) to any specified recipients which do
118 not include an @-sign, so that each RCPT TO address is fully qualified.
119 \(Some configurations of sendmail require this.)
121 Don't bother to set this unless you have get an error like:
122 Sending failed; SMTP protocol error
123 when sending mail, and the *trace of SMTP session to <somewhere>*
124 buffer includes an exchange like:
126 501 <someone>: recipient address must contain a domain
128 :type
'(choice (const nil
) string
)
131 (defcustom smtpmail-debug-info nil
132 "Whether to print info in buffer *trace of SMTP session to <somewhere>*.
133 See also `smtpmail-debug-verb' which determines if the SMTP protocol should
138 (defcustom smtpmail-debug-verb nil
139 "Whether this library sends the SMTP VERB command or not.
140 The commands enables verbose information from the SMTP server."
144 (defcustom smtpmail-code-conv-from nil
145 "Coding system for encoding outgoing mail.
146 Used for the value of `sendmail-coding-system' when
147 `select-message-coding-system' is called. "
151 (defcustom smtpmail-queue-mail nil
152 "Non-nil means mail is queued; otherwise it is sent immediately.
153 If queued, it is stored in the directory `smtpmail-queue-dir'
154 and sent with `smtpmail-send-queued-mail'."
158 (defcustom smtpmail-queue-dir
"~/Mail/queued-mail/"
159 "Directory where `smtpmail.el' stores queued mail."
163 (defcustom smtpmail-auth-credentials
"~/.authinfo"
164 "Specify username and password for servers, directly or via .netrc file.
165 This variable can either be a filename pointing to a file in netrc(5)
166 format, or list of four-element lists that contain, in order,
167 `servername' (a string), `port' (an integer), `user' (a string) and
168 `password' (a string, or nil to query the user when needed). If you
169 need to enter a `realm' too, add it to the user string, so that it
170 looks like `user@realm'."
172 (repeat (list (string :tag
"Server")
173 (integer :tag
"Port")
174 (string :tag
"Username")
175 (choice (const :tag
"Query when needed" nil
)
176 (string :tag
"Password")))))
180 (defcustom smtpmail-starttls-credentials
'(("" 25 "" ""))
181 "Specify STARTTLS keys and certificates for servers.
182 This is a list of four-element list with `servername' (a string),
183 `port' (an integer), `key' (a filename) and `certificate' (a
185 If you do not have a certificate/key pair, leave the `key' and
186 `certificate' fields as `nil'. A key/certificate pair is only
187 needed if you want to use X.509 client authenticated
189 :type
'(repeat (list (string :tag
"Server")
190 (integer :tag
"Port")
192 (file :tag
"Certificate")))
196 (defcustom smtpmail-warn-about-unknown-extensions nil
197 "If set, print warnings about unknown SMTP extensions.
198 This is mainly useful for development purposes, to learn about
199 new SMTP extensions that might be useful to support."
204 (defcustom smtpmail-queue-index-file
"index"
205 "File name of queued mail index.
206 This is relative to `smtpmail-queue-dir'."
210 ;; End of customizable variables.
213 (defvar smtpmail-address-buffer
)
214 (defvar smtpmail-recipient-address-list
)
216 (defvar smtpmail-queue-counter
0)
218 ;; Buffer-local variable.
219 (defvar smtpmail-read-point
)
221 (defconst smtpmail-auth-supported
'(cram-md5 plain login
)
222 "List of supported SMTP AUTH mechanisms.")
224 (defvar smtpmail-mail-address nil
225 "Value to use for envelope-from address for mail from ambient buffer.")
228 (defun smtpmail-send-it ()
229 (let ((errbuf (if mail-interactive
230 (generate-new-buffer " smtpmail errors")
232 (tembuf (generate-new-buffer " smtpmail temp"))
233 (case-fold-search nil
)
235 (mailbuf (current-buffer))
236 ;; Examine this variable now, so that
237 ;; local binding in the mail buffer will take effect.
238 (smtpmail-mail-address
239 (or (and mail-specify-envelope-from
(mail-envelope-from))
241 (smtpmail-code-conv-from
242 (if enable-multibyte-characters
243 (let ((sendmail-coding-system smtpmail-code-conv-from
))
244 (select-message-coding-system)))))
249 ;; Use the same buffer-file-coding-system as in the mail
250 ;; buffer, otherwise any write-region invocations (e.g., in
251 ;; mail-do-fcc below) will annoy with asking for a suitable
253 (set-buffer-file-coding-system smtpmail-code-conv-from nil t
)
254 (insert-buffer-substring mailbuf
)
255 (goto-char (point-max))
256 ;; require one newline at the end.
257 (or (= (preceding-char) ?
\n)
259 ;; Change header-delimiter to be what sendmail expects.
260 (mail-sendmail-undelimit-header)
261 (setq delimline
(point-marker))
262 ;; (sendmail-synch-aliases)
264 (expand-mail-aliases (point-min) delimline
))
265 (goto-char (point-min))
266 ;; ignore any blank lines in the header
267 (while (and (re-search-forward "\n\n\n*" delimline t
)
268 (< (point) delimline
))
269 (replace-match "\n"))
270 (let ((case-fold-search t
))
271 ;; We used to process Resent-... headers here,
272 ;; but it was not done properly, and the job
273 ;; is done correctly in smtpmail-deduce-address-list.
274 ;; Don't send out a blank subject line
275 (goto-char (point-min))
276 (if (re-search-forward "^Subject:\\([ \t]*\n\\)+\\b" delimline t
)
278 ;; This one matches a Subject just before the header delimiter.
279 (if (and (re-search-forward "^Subject:\\([ \t]*\n\\)+" delimline t
)
280 (= (match-end 0) delimline
))
282 ;; Put the "From:" field in unless for some odd reason
283 ;; they put one in themselves.
284 (goto-char (point-min))
285 (if (not (re-search-forward "^From:" delimline t
))
286 (let* ((login smtpmail-mail-address
)
287 (fullname (user-full-name)))
288 (cond ((eq mail-from-style
'angles
)
289 (insert "From: " fullname
)
290 (let ((fullname-start (+ (point-min) 6))
291 (fullname-end (point-marker)))
292 (goto-char fullname-start
)
293 ;; Look for a character that cannot appear unquoted
294 ;; according to RFC 822.
295 (if (re-search-forward "[^- !#-'*+/-9=?A-Z^-~]"
298 ;; Quote fullname, escaping specials.
299 (goto-char fullname-start
)
301 (while (re-search-forward "[\"\\]"
303 (replace-match "\\\\\\&" t
))
305 (insert " <" login
">\n"))
306 ((eq mail-from-style
'parens
)
307 (insert "From: " login
" (")
308 (let ((fullname-start (point)))
310 (let ((fullname-end (point-marker)))
311 (goto-char fullname-start
)
312 ;; RFC 822 says \ and nonmatching parentheses
313 ;; must be escaped in comments.
314 ;; Escape every instance of ()\ ...
315 (while (re-search-forward "[()\\]" fullname-end
1)
316 (replace-match "\\\\\\&" t
))
317 ;; ... then undo escaping of matching parentheses,
318 ;; including matching nested parentheses.
319 (goto-char fullname-start
)
320 (while (re-search-forward
321 "\\(\\=\\|[^\\]\\(\\\\\\\\\\)*\\)\\\\(\\(\\([^\\]\\|\\\\\\\\\\)*\\)\\\\)"
323 (replace-match "\\1(\\3)" t
)
324 (goto-char fullname-start
))))
326 ((null mail-from-style
)
327 (insert "From: " login
"\n")))))
328 ;; Insert a `Message-Id:' field if there isn't one yet.
329 (goto-char (point-min))
330 (unless (re-search-forward "^Message-Id:" delimline t
)
331 (insert "Message-Id: " (message-make-message-id) "\n"))
332 ;; Insert a `Date:' field if there isn't one yet.
333 (goto-char (point-min))
334 (unless (re-search-forward "^Date:" delimline t
)
335 (insert "Date: " (message-make-date) "\n"))
336 ;; Possibly add a MIME header for the current coding system
338 (goto-char (point-min))
339 (and (eq mail-send-nonascii
'mime
)
340 (not (re-search-forward "^MIME-version:" delimline t
))
341 (progn (skip-chars-forward "\0-\177")
342 (/= (point) (point-max)))
343 smtpmail-code-conv-from
345 (coding-system-get smtpmail-code-conv-from
347 (goto-char delimline
)
348 (insert "MIME-version: 1.0\n"
349 "Content-type: text/plain; charset="
350 (symbol-name charset
)
351 "\nContent-Transfer-Encoding: 8bit\n")))
352 ;; Insert an extra newline if we need it to work around
353 ;; Sun's bug that swallows newlines.
354 (goto-char (1+ delimline
))
355 (if (eval mail-mailer-swallows-blank-line
)
357 ;; Find and handle any FCC fields.
358 (goto-char (point-min))
359 (if (re-search-forward "^FCC:" delimline t
)
360 ;; Force mail-do-fcc to use the encoding of the mail
361 ;; buffer to encode outgoing messages on FCC files.
362 (let ((coding-system-for-write smtpmail-code-conv-from
))
363 (mail-do-fcc delimline
)))
365 (with-current-buffer errbuf
370 (setq smtpmail-address-buffer
(generate-new-buffer "*smtp-mail*"))
371 (setq smtpmail-recipient-address-list
372 (smtpmail-deduce-address-list tembuf
(point-min) delimline
))
373 (kill-buffer smtpmail-address-buffer
)
375 (smtpmail-do-bcc delimline
)
377 (if (not smtpmail-queue-mail
)
378 (if (not (null smtpmail-recipient-address-list
))
379 (if (not (smtpmail-via-smtp
380 smtpmail-recipient-address-list tembuf
))
381 (error "Sending failed; SMTP protocol error"))
382 (error "Sending failed; no recipients"))
386 (format-time-string "%Y-%m-%d_%H:%M:%S")
387 (setq smtpmail-queue-counter
388 (1+ smtpmail-queue-counter
)))
390 (file-data (convert-standard-filename file-data
))
391 (file-elisp (concat file-data
".el"))
392 (buffer-data (create-file-buffer file-data
))
393 (buffer-elisp (create-file-buffer file-elisp
))
394 (buffer-scratch "*queue-mail*"))
395 (unless (file-exists-p smtpmail-queue-dir
)
396 (make-directory smtpmail-queue-dir t
))
397 (with-current-buffer buffer-data
399 (set-buffer-file-coding-system smtpmail-code-conv-from nil t
)
400 (insert-buffer-substring tembuf
)
401 (write-file file-data
)
402 (set-buffer buffer-elisp
)
405 "(setq smtpmail-recipient-address-list '"
406 (prin1-to-string smtpmail-recipient-address-list
)
408 (write-file file-elisp
)
409 (set-buffer (generate-new-buffer buffer-scratch
))
410 (insert (concat file-data
"\n"))
411 (append-to-file (point-min)
413 (expand-file-name smtpmail-queue-index-file
414 smtpmail-queue-dir
)))
415 (kill-buffer buffer-scratch
)
416 (kill-buffer buffer-data
)
417 (kill-buffer buffer-elisp
))))
420 (kill-buffer errbuf
)))))
423 (defun smtpmail-send-queued-mail ()
424 "Send mail that was queued as a result of setting `smtpmail-queue-mail'."
427 ;;; Get index, get first mail, send it, update index, get second
428 ;;; mail, send it, etc...
430 (qfile (expand-file-name smtpmail-queue-index-file
431 smtpmail-queue-dir
)))
432 (insert-file-contents qfile
)
433 (goto-char (point-min))
435 (setq file-msg
(buffer-substring (point) (line-end-position)))
437 ;; Insert the message literally: it is already encoded as per
438 ;; the MIME headers, and code conversions might guess the
441 (let ((coding-system-for-read 'no-conversion
))
442 (insert-file-contents file-msg
))
443 (let ((smtpmail-mail-address
444 (or (and mail-specify-envelope-from
(mail-envelope-from))
446 (if (not (null smtpmail-recipient-address-list
))
447 (if (not (smtpmail-via-smtp smtpmail-recipient-address-list
449 (error "Sending failed; SMTP protocol error"))
450 (error "Sending failed; no recipients"))))
451 (delete-file file-msg
)
452 (delete-file (concat file-msg
".el"))
453 (delete-region (point-at-bol) (point-at-bol 2)))
454 (write-region (point-min) (point-max) qfile
))))
456 ;(defun smtpmail-via-smtp (host,port,sender,destination,smtpmail-text-buffer)
458 (defun smtpmail-fqdn ()
459 (if smtpmail-local-domain
460 (concat (system-name) "." smtpmail-local-domain
)
463 (defsubst smtpmail-cred-server
(cred)
466 (defsubst smtpmail-cred-port
(cred)
469 (defsubst smtpmail-cred-key
(cred)
472 (defsubst smtpmail-cred-user
(cred)
475 (defsubst smtpmail-cred-cert
(cred)
478 (defsubst smtpmail-cred-passwd
(cred)
481 (defun smtpmail-find-credentials (cred server port
)
484 (while (setq el
(pop l
))
485 (when (and (equal server
(smtpmail-cred-server el
))
486 (equal port
(smtpmail-cred-port el
)))
487 (throw 'done el
))))))
489 (defun smtpmail-maybe-append-domain (recipient)
490 (if (or (not smtpmail-sendto-domain
)
491 (string-match "@" recipient
))
493 (concat recipient
"@" smtpmail-sendto-domain
)))
495 (defun smtpmail-intersection (list1 list2
)
498 (when (memq el2 list1
)
502 (defvar starttls-extra-args
)
503 (defvar starttls-extra-arguments
)
505 (defun smtpmail-open-stream (process-buffer host port
)
506 (let ((cred (smtpmail-find-credentials
507 smtpmail-starttls-credentials host port
)))
508 (if (null (and cred
(condition-case ()
511 (call-process (if starttls-use-gnutls
512 starttls-gnutls-program
516 (open-network-stream "SMTP" process-buffer host port
)
517 (let* ((cred-key (smtpmail-cred-key cred
))
518 (cred-cert (smtpmail-cred-cert cred
))
522 (when (and (stringp cred-key
) (stringp cred-cert
)
524 (setq cred-key
(expand-file-name cred-key
)))
526 (setq cred-cert
(expand-file-name cred-cert
))))
527 (list "--key-file" cred-key
"--cert-file" cred-cert
))))
528 (starttls-extra-arguments
530 starttls-extra-arguments
531 (when (and (stringp cred-key
) (stringp cred-cert
)
533 (setq cred-key
(expand-file-name cred-key
)))
535 (setq cred-cert
(expand-file-name cred-cert
))))
536 (list "--x509keyfile" cred-key
"--x509certfile" cred-cert
)))))
537 (starttls-open-stream "SMTP" process-buffer host port
)))))
539 ;; password-read autoloads password-cache.
540 (declare-function password-cache-add
"password-cache" (key password
))
542 (defun smtpmail-try-auth-methods (process supported-extensions host port
)
543 (let* ((mechs (cdr-safe (assoc 'auth supported-extensions
)))
544 (mech (car (smtpmail-intersection smtpmail-auth-supported mechs
)))
545 (auth-user (auth-source-user-or-password
546 "login" host
(or port
"smtp")))
547 (auth-pass (auth-source-user-or-password
548 "password" host
(or port
"smtp")))
549 (cred (if (and auth-user auth-pass
) ; try user-auth-* before netrc-*
550 (list host port auth-user auth-pass
)
551 ;; else, if auth-source didn't return them...
552 (if (stringp smtpmail-auth-credentials
)
553 (let* ((netrc (netrc-parse smtpmail-auth-credentials
))
554 (port-name (format "%s" (or port
"smtp")))
555 (hostentry (netrc-machine netrc host port-name
559 (netrc-get hostentry
"login")
560 (netrc-get hostentry
"password"))))
561 ;; else, try smtpmail-find-credentials since
562 ;; smtpmail-auth-credentials is not a string
563 (smtpmail-find-credentials
564 smtpmail-auth-credentials host port
))))
565 (prompt (when cred
(format "SMTP password for %s:%s: "
566 (smtpmail-cred-server cred
)
567 (smtpmail-cred-port cred
))))
569 (or (smtpmail-cred-passwd cred
)
570 (password-read prompt prompt
))))
572 (when (and cred mech
)
575 (smtpmail-send-command process
(upcase (format "AUTH %s" mech
)))
576 (if (or (null (car (setq ret
(smtpmail-read-response process
))))
577 (not (integerp (car ret
)))
580 (when (eq (car ret
) 334)
581 (let* ((challenge (substring (cadr ret
) 4))
582 (decoded (base64-decode-string challenge
))
583 (hash (rfc2104-hash 'md5
64 16 passwd decoded
))
584 (response (concat (smtpmail-cred-user cred
) " " hash
))
585 ;; Osamu Yamane <yamane@green.ocn.ne.jp>:
586 ;; SMTP auth fails because the SMTP server identifies
587 ;; only the first part of the string (delimited by
588 ;; new line characters) as a response from the
589 ;; client, and the rest as distinct commands.
591 ;; In my case, the response string is 80 characters
592 ;; long. Without the no-line-break option for
593 ;; base64-encode-sting, only the first 76 characters
594 ;; are taken as a response to the server, and the
595 ;; authentication fails.
596 (encoded (base64-encode-string response t
)))
597 (smtpmail-send-command process
(format "%s" encoded
))
598 (if (or (null (car (setq ret
(smtpmail-read-response process
))))
599 (not (integerp (car ret
)))
601 (throw 'done nil
)))))
603 (smtpmail-send-command process
"AUTH LOGIN")
604 (if (or (null (car (setq ret
(smtpmail-read-response process
))))
605 (not (integerp (car ret
)))
608 (smtpmail-send-command
609 process
(base64-encode-string (smtpmail-cred-user cred
) t
))
610 (if (or (null (car (setq ret
(smtpmail-read-response process
))))
611 (not (integerp (car ret
)))
614 (smtpmail-send-command process
(base64-encode-string passwd t
))
615 (if (or (null (car (setq ret
(smtpmail-read-response process
))))
616 (not (integerp (car ret
)))
620 ;; We used to send an empty initial request, and wait for an
621 ;; empty response, and then send the password, but this
622 ;; violate a SHOULD in RFC 2222 paragraph 5.1. Note that this
623 ;; is not sent if the server did not advertise AUTH PLAIN in
624 ;; the EHLO response. See RFC 2554 for more info.
625 (smtpmail-send-command process
626 (concat "AUTH PLAIN "
627 (base64-encode-string
629 (smtpmail-cred-user cred
)
632 (if (or (null (car (setq ret
(smtpmail-read-response process
))))
633 (not (integerp (car ret
)))
634 (not (equal (car ret
) 235)))
638 (error "Mechanism %s not implemented" mech
)))
639 ;; Remember the password.
640 (when (null (smtpmail-cred-passwd cred
))
641 (password-cache-add prompt passwd
)))))
643 (defun smtpmail-via-smtp (recipient smtpmail-text-buffer
)
645 (host (or smtpmail-smtp-server
646 (error "`smtpmail-smtp-server' not defined")))
647 (port smtpmail-smtp-service
)
648 ;; smtpmail-mail-address should be set to the appropriate
649 ;; buffer-local value by the caller, but in case not:
650 (envelope-from (or smtpmail-mail-address
651 (and mail-specify-envelope-from
652 (mail-envelope-from))
657 (supported-extensions '()))
660 ;; get or create the trace buffer
662 (get-buffer-create (format "*trace of SMTP session to %s*" host
)))
664 ;; clear the trace buffer of old output
665 (with-current-buffer process-buffer
666 (setq buffer-undo-list t
)
669 ;; open the connection to the server
670 (setq process
(smtpmail-open-stream process-buffer host port
))
671 (and (null process
) (throw 'done nil
))
673 ;; set the send-filter
674 (set-process-filter process
'smtpmail-process-filter
)
676 (with-current-buffer process-buffer
677 (set-buffer-process-coding-system 'raw-text-unix
'raw-text-unix
)
678 (make-local-variable 'smtpmail-read-point
)
679 (setq smtpmail-read-point
(point-min))
682 (if (or (null (car (setq greeting
(smtpmail-read-response process
))))
683 (not (integerp (car greeting
)))
684 (>= (car greeting
) 400))
692 (smtpmail-send-command process
(format "EHLO %s" (smtpmail-fqdn)))
694 (if (or (null (car (setq response-code
695 (smtpmail-read-response process
))))
696 (not (integerp (car response-code
)))
697 (>= (car response-code
) 400))
700 (smtpmail-send-command
701 process
(format "HELO %s" (smtpmail-fqdn)))
703 (if (or (null (car (setq response-code
704 (smtpmail-read-response process
))))
705 (not (integerp (car response-code
)))
706 (>= (car response-code
) 400))
708 (dolist (line (cdr (cdr response-code
)))
710 (with-case-table ascii-case-table
711 (mapcar (lambda (s) (intern (downcase s
)))
712 (split-string (substring line
4) "[ ]")))))
713 (and (eq (length name
) 1)
714 (setq name
(car name
)))
716 (cond ((memq (if (consp name
) (car name
) name
)
717 '(verb xvrb
8bitmime onex xone
721 auth
=login auth starttls
))
722 (setq supported-extensions
723 (cons name supported-extensions
)))
724 (smtpmail-warn-about-unknown-extensions
725 (message "Unknown extension %s" name
)))))))
728 (smtpmail-find-credentials smtpmail-starttls-credentials host port
)
729 (member 'starttls supported-extensions
)
730 (numberp (process-id process
)))
732 (smtpmail-send-command process
(format "STARTTLS"))
733 (if (or (null (car (setq response-code
(smtpmail-read-response process
))))
734 (not (integerp (car response-code
)))
735 (>= (car response-code
) 400))
737 (starttls-negotiate process
)
738 (setq do-starttls nil
))
739 (setq do-ehlo nil
))))
741 (smtpmail-try-auth-methods process supported-extensions host port
)
743 (if (or (member 'onex supported-extensions
)
744 (member 'xone supported-extensions
))
746 (smtpmail-send-command process
(format "ONEX"))
747 (if (or (null (car (setq response-code
(smtpmail-read-response process
))))
748 (not (integerp (car response-code
)))
749 (>= (car response-code
) 400))
752 (if (and smtpmail-debug-verb
753 (or (member 'verb supported-extensions
)
754 (member 'xvrb supported-extensions
)))
756 (smtpmail-send-command process
(format "VERB"))
757 (if (or (null (car (setq response-code
(smtpmail-read-response process
))))
758 (not (integerp (car response-code
)))
759 (>= (car response-code
) 400))
762 (if (member 'xusr supported-extensions
)
764 (smtpmail-send-command process
(format "XUSR"))
765 (if (or (null (car (setq response-code
(smtpmail-read-response process
))))
766 (not (integerp (car response-code
)))
767 (>= (car response-code
) 400))
770 ;; MAIL FROM:<sender>
772 (if (or (member 'size supported-extensions
)
773 (assoc 'size supported-extensions
))
775 (with-current-buffer smtpmail-text-buffer
777 (+ (- (point-max) (point-min))
778 ;; Add one byte for each change-of-line
779 ;; because of CR-LF representation:
780 (count-lines (point-min) (point-max)))))
783 (if (member '8bitmime supported-extensions
)
785 ;; Code should be added here that transforms
786 ;; the contents of the message buffer into
787 ;; something the receiving SMTP can handle.
788 ;; For a receiver that supports 8BITMIME, this
789 ;; may mean converting BINARY to BASE64, or
790 ;; adding Content-Transfer-Encoding and the
791 ;; other MIME headers. The code should also
792 ;; return an indication of what encoding the
793 ;; message buffer is now, i.e. ASCII or
799 ; (smtpmail-send-command process (format "MAIL FROM:%s@%s" (user-login-name) (smtpmail-fqdn)))
800 (smtpmail-send-command process
(format "MAIL FROM:<%s>%s%s"
805 (if (or (null (car (setq response-code
(smtpmail-read-response process
))))
806 (not (integerp (car response-code
)))
807 (>= (car response-code
) 400))
811 ;; RCPT TO:<recipient>
813 (while (not (null (nth n recipient
)))
814 (smtpmail-send-command process
(format "RCPT TO:<%s>" (smtpmail-maybe-append-domain (nth n recipient
))))
817 (setq response-code
(smtpmail-read-response process
))
818 (if (or (null (car response-code
))
819 (not (integerp (car response-code
)))
820 (>= (car response-code
) 400))
826 (smtpmail-send-command process
"DATA")
828 (if (or (null (car (setq response-code
(smtpmail-read-response process
))))
829 (not (integerp (car response-code
)))
830 (>= (car response-code
) 400))
835 (smtpmail-send-data process smtpmail-text-buffer
)
838 (smtpmail-send-command process
".")
840 (if (or (null (car (setq response-code
(smtpmail-read-response process
))))
841 (not (integerp (car response-code
)))
842 (>= (car response-code
) 400))
847 ; (smtpmail-send-command process "QUIT")
848 ; (and (null (car (smtpmail-read-response process)))
852 (with-current-buffer (process-buffer process
)
853 (smtpmail-send-command process
"QUIT")
854 (smtpmail-read-response process
)
856 ; (if (or (null (car (setq response-code (smtpmail-read-response process))))
857 ; (not (integerp (car response-code)))
858 ; (>= (car response-code) 400))
861 (delete-process process
)
862 (unless smtpmail-debug-info
863 (kill-buffer process-buffer
)))))))
866 (defun smtpmail-process-filter (process output
)
867 (with-current-buffer (process-buffer process
)
868 (goto-char (point-max))
871 (defun smtpmail-read-response (process)
872 (let ((case-fold-search nil
)
873 (response-strings nil
)
874 (response-continue t
)
875 (return-value '(nil ()))
878 (while response-continue
879 (goto-char smtpmail-read-point
)
880 (while (not (search-forward "\r\n" nil t
))
881 (unless (memq (process-status process
) '(open run
))
883 (accept-process-output process
)
884 (goto-char smtpmail-read-point
))
886 (setq match-end
(point))
887 (setq response-strings
888 (cons (buffer-substring smtpmail-read-point
(- match-end
2))
891 (goto-char smtpmail-read-point
)
892 (if (looking-at "[0-9]+ ")
893 (let ((begin (match-beginning 0))
895 (if smtpmail-debug-info
896 (message "%s" (car response-strings
)))
898 (setq smtpmail-read-point match-end
)
900 ;; ignore lines that start with "0"
901 (if (looking-at "0[0-9]+ ")
903 (setq response-continue nil
)
905 (cons (string-to-number
906 (buffer-substring begin end
))
907 (nreverse response-strings
)))))
909 (if (looking-at "[0-9]+-")
910 (progn (if smtpmail-debug-info
911 (message "%s" (car response-strings
)))
912 (setq smtpmail-read-point match-end
)
913 (setq response-continue t
))
915 (setq smtpmail-read-point match-end
)
916 (setq response-continue nil
)
918 (cons nil
(nreverse response-strings
)))))))
919 (setq smtpmail-read-point match-end
))
923 (defun smtpmail-send-command (process command
)
924 (goto-char (point-max))
925 (if (= (aref command
0) ?P
)
926 (insert "PASS <omitted>\r\n")
927 (insert command
"\r\n"))
928 (setq smtpmail-read-point
(point))
929 (process-send-string process command
)
930 (process-send-string process
"\r\n"))
932 (defun smtpmail-send-data-1 (process data
)
933 (goto-char (point-max))
935 (if (and (multibyte-string-p data
)
936 smtpmail-code-conv-from
)
937 (setq data
(string-as-multibyte
938 (encode-coding-string data smtpmail-code-conv-from
))))
940 (if smtpmail-debug-info
941 (insert data
"\r\n"))
943 (setq smtpmail-read-point
(point))
944 ;; Escape "." at start of a line
945 (if (eq (string-to-char data
) ?.
)
946 (process-send-string process
"."))
947 (process-send-string process data
)
948 (process-send-string process
"\r\n")
951 (defun smtpmail-send-data (process buffer
)
952 (let ((data-continue t
) sending-data
)
953 (with-current-buffer buffer
954 (goto-char (point-min)))
956 (with-current-buffer buffer
957 (setq sending-data
(buffer-substring (point-at-bol) (point-at-eol)))
959 (setq data-continue
(not (eobp))))
960 (smtpmail-send-data-1 process sending-data
))))
962 (defun smtpmail-deduce-address-list (smtpmail-text-buffer header-start header-end
)
963 "Get address list suitable for smtp RCPT TO: <address>."
965 (with-current-buffer smtpmail-address-buffer
968 ((case-fold-search t
)
969 (simple-address-list "")
973 (insert-buffer-substring smtpmail-text-buffer header-start header-end
)
974 (goto-char (point-min))
975 ;; RESENT-* fields should stop processing of regular fields.
978 (if (re-search-forward "^Resent-\\(to\\|cc\\|bcc\\):"
980 "^Resent-\\(to\\|cc\\|bcc\\):"
981 "^\\(To:\\|Cc:\\|Bcc:\\)")))
983 (while (re-search-forward addr-regexp header-end t
)
985 (setq this-line
(match-beginning 0))
987 ;; get any continuation lines
988 (while (and (looking-at "^[ \t]+") (< (point) header-end
))
990 (setq this-line-end
(point-marker))
991 (setq simple-address-list
992 (concat simple-address-list
" "
993 (mail-strip-quoted-names (buffer-substring this-line this-line-end
))))
996 (insert " " simple-address-list
"\n")
997 (subst-char-in-region (point-min) (point-max) 10 ? t
);; newline --> blank
998 (subst-char-in-region (point-min) (point-max) ?
, ? t
);; comma --> blank
999 (subst-char-in-region (point-min) (point-max) 9 ? t
);; tab --> blank
1001 (goto-char (point-min))
1002 ;; tidyness in case hook is not robust when it looks at this
1003 (while (re-search-forward "[ \t]+" header-end t
) (replace-match " "))
1005 (goto-char (point-min))
1006 (let (recipient-address-list)
1007 (while (re-search-forward " \\([^ ]+\\) " (point-max) t
)
1009 (setq recipient-address-list
(cons (buffer-substring (match-beginning 1) (match-end 1))
1010 recipient-address-list
))
1012 (setq smtpmail-recipient-address-list recipient-address-list
))
1020 (defun smtpmail-do-bcc (header-end)
1021 "Delete [Resent-]BCC: and their continuation lines from the header area.
1022 There may be multiple BCC: lines, and each may have arbitrarily
1023 many continuation lines."
1024 (let ((case-fold-search t
))
1026 (goto-char (point-min))
1027 ;; iterate over all BCC: lines
1028 (while (re-search-forward "^\\(RESENT-\\)?BCC:" header-end t
)
1029 (delete-region (match-beginning 0)
1030 (progn (forward-line 1) (point)))
1031 ;; get rid of any continuation lines
1032 (while (and (looking-at "^[ \t].*\n") (< (point) header-end
))
1033 (replace-match ""))))))
1038 ;; arch-tag: a76992df-6d71-43b7-9e72-4bacc6c05466
1039 ;;; smtpmail.el ends here