HCoop / bpt / emacs.git / blob
? search:


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