Mercurial > emacs
annotate lisp/mail/smtpmail.el @ 17085:4dafa5431293
Change coding system name koi8 to koi8-r.
Remove prefix "coding-system-" from coding system symbol names.
author | Kenichi Handa <handa@m17n.org> |
---|---|
date | Wed, 26 Feb 1997 12:27:06 +0000 |
parents | 3c4a708a2631 |
children | 2a9fdbfcb993 |
rev | line source |
---|---|
15345 | 1 ;; Simple SMTP protocol (RFC 821) for sending mail |
2 | |
15451
89c1e7fe879a
(smtpmail-smtp-service): Use port 25 as default.
Richard M. Stallman <rms@gnu.org>
parents:
15372
diff
changeset
|
3 ;; Copyright (C) 1995, 1996 Free Software Foundation, Inc. |
15345 | 4 |
5 ;; Author: Tomoji Kagatani <kagatani@rbc.ncl.omron.co.jp> | |
15452
6f41e17b3452
(smtpmail-send-it): Don't handle FCC fields until after determining FROM field.
Richard M. Stallman <rms@gnu.org>
parents:
15451
diff
changeset
|
6 ;; Maintainer: Brian D. Carlstrom <bdc@ai.mit.edu> |
15345 | 7 ;; Keywords: mail |
8 | |
9 ;; This file is part of GNU Emacs. | |
10 | |
11 ;; GNU Emacs is free software; you can redistribute it and/or modify | |
12 ;; it under the terms of the GNU General Public License as published by | |
13 ;; the Free Software Foundation; either version 2, or (at your option) | |
14 ;; any later version. | |
15 | |
16 ;; GNU Emacs is distributed in the hope that it will be useful, | |
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
19 ;; GNU General Public License for more details. | |
20 | |
21 ;; You should have received a copy of the GNU General Public License | |
22 ;; along with GNU Emacs; see the file COPYING. If not, write to the | |
23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
24 ;; Boston, MA 02111-1307, USA. | |
25 | |
26 ;;; Commentary: | |
27 | |
28 ;; Send Mail to smtp host from smtpmail temp buffer. | |
29 | |
30 ;; Please add these lines in your .emacs(_emacs). | |
31 ;; | |
32 ;;(setq send-mail-function 'smtpmail-send-it) | |
33 ;;(setq smtpmail-default-smtp-server "YOUR SMTP HOST") | |
34 ;;(setq smtpmail-smtp-service "smtp") | |
35 ;;(setq smtpmail-local-domain "YOUR DOMAIN NAME") | |
36 ;;(setq smtpmail-debug-info t) | |
37 ;;(load-library "smtpmail") | |
38 ;;(setq smtpmail-code-conv-from nil) | |
15452
6f41e17b3452
(smtpmail-send-it): Don't handle FCC fields until after determining FROM field.
Richard M. Stallman <rms@gnu.org>
parents:
15451
diff
changeset
|
39 ;;(setq user-full-name "YOUR NAME HERE") |
15345 | 40 |
41 ;;; Code: | |
42 | |
43 (require 'sendmail) | |
44 | |
45 ;;; | |
46 (defvar smtpmail-default-smtp-server nil | |
47 "*Specify default SMTP server.") | |
48 | |
15451
89c1e7fe879a
(smtpmail-smtp-service): Use port 25 as default.
Richard M. Stallman <rms@gnu.org>
parents:
15372
diff
changeset
|
49 (defvar smtpmail-smtp-server |
89c1e7fe879a
(smtpmail-smtp-service): Use port 25 as default.
Richard M. Stallman <rms@gnu.org>
parents:
15372
diff
changeset
|
50 (or (getenv "SMTPSERVER") smtpmail-default-smtp-server) |
15345 | 51 "*The name of the host running SMTP server.") |
52 | |
15451
89c1e7fe879a
(smtpmail-smtp-service): Use port 25 as default.
Richard M. Stallman <rms@gnu.org>
parents:
15372
diff
changeset
|
53 (defvar smtpmail-smtp-service 25 |
15345 | 54 "*SMTP service port number. smtp or 25 .") |
55 | |
56 (defvar smtpmail-local-domain nil | |
57 "*Local domain name without a host name. | |
58 If the function (system-name) returns the full internet address, | |
59 don't define this value.") | |
60 | |
61 (defvar smtpmail-debug-info nil | |
62 "*smtpmail debug info printout. messages and process buffer.") | |
63 | |
64 (defvar smtpmail-code-conv-from nil ;; *junet* | |
65 "*smtpmail code convert from this code to *internal*..for tiny-mime..") | |
66 | |
67 ;;; | |
68 ;;; | |
69 ;;; | |
70 | |
71 (defun smtpmail-send-it () | |
15451
89c1e7fe879a
(smtpmail-smtp-service): Use port 25 as default.
Richard M. Stallman <rms@gnu.org>
parents:
15372
diff
changeset
|
72 (require 'mail-utils) |
15345 | 73 (let ((errbuf (if mail-interactive |
74 (generate-new-buffer " smtpmail errors") | |
75 0)) | |
76 (tembuf (generate-new-buffer " smtpmail temp")) | |
77 (case-fold-search nil) | |
78 resend-to-addresses | |
79 delimline | |
80 (mailbuf (current-buffer))) | |
81 (unwind-protect | |
82 (save-excursion | |
83 (set-buffer tembuf) | |
84 (erase-buffer) | |
85 (insert-buffer-substring mailbuf) | |
86 (goto-char (point-max)) | |
87 ;; require one newline at the end. | |
88 (or (= (preceding-char) ?\n) | |
89 (insert ?\n)) | |
90 ;; Change header-delimiter to be what sendmail expects. | |
91 (goto-char (point-min)) | |
92 (re-search-forward | |
93 (concat "^" (regexp-quote mail-header-separator) "\n")) | |
94 (replace-match "\n") | |
95 (backward-char 1) | |
96 (setq delimline (point-marker)) | |
15451
89c1e7fe879a
(smtpmail-smtp-service): Use port 25 as default.
Richard M. Stallman <rms@gnu.org>
parents:
15372
diff
changeset
|
97 ;; (sendmail-synch-aliases) |
15345 | 98 (if mail-aliases |
99 (expand-mail-aliases (point-min) delimline)) | |
100 (goto-char (point-min)) | |
101 ;; ignore any blank lines in the header | |
102 (while (and (re-search-forward "\n\n\n*" delimline t) | |
103 (< (point) delimline)) | |
104 (replace-match "\n")) | |
105 (let ((case-fold-search t)) | |
106 (goto-char (point-min)) | |
107 (goto-char (point-min)) | |
108 (while (re-search-forward "^Resent-to:" delimline t) | |
109 (setq resend-to-addresses | |
110 (save-restriction | |
111 (narrow-to-region (point) | |
112 (save-excursion | |
113 (end-of-line) | |
114 (point))) | |
115 (append (mail-parse-comma-list) | |
116 resend-to-addresses)))) | |
117 ;;; Apparently this causes a duplicate Sender. | |
118 ;;; ;; If the From is different than current user, insert Sender. | |
119 ;;; (goto-char (point-min)) | |
120 ;;; (and (re-search-forward "^From:" delimline t) | |
121 ;;; (progn | |
122 ;;; (require 'mail-utils) | |
123 ;;; (not (string-equal | |
124 ;;; (mail-strip-quoted-names | |
125 ;;; (save-restriction | |
126 ;;; (narrow-to-region (point-min) delimline) | |
127 ;;; (mail-fetch-field "From"))) | |
128 ;;; (user-login-name)))) | |
129 ;;; (progn | |
130 ;;; (forward-line 1) | |
131 ;;; (insert "Sender: " (user-login-name) "\n"))) | |
132 ;; Don't send out a blank subject line | |
133 (goto-char (point-min)) | |
134 (if (re-search-forward "^Subject:[ \t]*\n" delimline t) | |
135 (replace-match "")) | |
15452
6f41e17b3452
(smtpmail-send-it): Don't handle FCC fields until after determining FROM field.
Richard M. Stallman <rms@gnu.org>
parents:
15451
diff
changeset
|
136 ;; Put the "From:" field in unless for some odd reason |
6f41e17b3452
(smtpmail-send-it): Don't handle FCC fields until after determining FROM field.
Richard M. Stallman <rms@gnu.org>
parents:
15451
diff
changeset
|
137 ;; they put one in themselves. |
6f41e17b3452
(smtpmail-send-it): Don't handle FCC fields until after determining FROM field.
Richard M. Stallman <rms@gnu.org>
parents:
15451
diff
changeset
|
138 (goto-char (point-min)) |
6f41e17b3452
(smtpmail-send-it): Don't handle FCC fields until after determining FROM field.
Richard M. Stallman <rms@gnu.org>
parents:
15451
diff
changeset
|
139 (if (not (re-search-forward "^From:" delimline t)) |
6f41e17b3452
(smtpmail-send-it): Don't handle FCC fields until after determining FROM field.
Richard M. Stallman <rms@gnu.org>
parents:
15451
diff
changeset
|
140 (let* ((login user-mail-address) |
6f41e17b3452
(smtpmail-send-it): Don't handle FCC fields until after determining FROM field.
Richard M. Stallman <rms@gnu.org>
parents:
15451
diff
changeset
|
141 (fullname (user-full-name))) |
6f41e17b3452
(smtpmail-send-it): Don't handle FCC fields until after determining FROM field.
Richard M. Stallman <rms@gnu.org>
parents:
15451
diff
changeset
|
142 (cond ((eq mail-from-style 'angles) |
6f41e17b3452
(smtpmail-send-it): Don't handle FCC fields until after determining FROM field.
Richard M. Stallman <rms@gnu.org>
parents:
15451
diff
changeset
|
143 (insert "From: " fullname) |
6f41e17b3452
(smtpmail-send-it): Don't handle FCC fields until after determining FROM field.
Richard M. Stallman <rms@gnu.org>
parents:
15451
diff
changeset
|
144 (let ((fullname-start (+ (point-min) 6)) |
6f41e17b3452
(smtpmail-send-it): Don't handle FCC fields until after determining FROM field.
Richard M. Stallman <rms@gnu.org>
parents:
15451
diff
changeset
|
145 (fullname-end (point-marker))) |
6f41e17b3452
(smtpmail-send-it): Don't handle FCC fields until after determining FROM field.
Richard M. Stallman <rms@gnu.org>
parents:
15451
diff
changeset
|
146 (goto-char fullname-start) |
6f41e17b3452
(smtpmail-send-it): Don't handle FCC fields until after determining FROM field.
Richard M. Stallman <rms@gnu.org>
parents:
15451
diff
changeset
|
147 ;; Look for a character that cannot appear unquoted |
6f41e17b3452
(smtpmail-send-it): Don't handle FCC fields until after determining FROM field.
Richard M. Stallman <rms@gnu.org>
parents:
15451
diff
changeset
|
148 ;; according to RFC 822. |
6f41e17b3452
(smtpmail-send-it): Don't handle FCC fields until after determining FROM field.
Richard M. Stallman <rms@gnu.org>
parents:
15451
diff
changeset
|
149 (if (re-search-forward "[^- !#-'*+/-9=?A-Z^-~]" |
6f41e17b3452
(smtpmail-send-it): Don't handle FCC fields until after determining FROM field.
Richard M. Stallman <rms@gnu.org>
parents:
15451
diff
changeset
|
150 fullname-end 1) |
6f41e17b3452
(smtpmail-send-it): Don't handle FCC fields until after determining FROM field.
Richard M. Stallman <rms@gnu.org>
parents:
15451
diff
changeset
|
151 (progn |
6f41e17b3452
(smtpmail-send-it): Don't handle FCC fields until after determining FROM field.
Richard M. Stallman <rms@gnu.org>
parents:
15451
diff
changeset
|
152 ;; Quote fullname, escaping specials. |
6f41e17b3452
(smtpmail-send-it): Don't handle FCC fields until after determining FROM field.
Richard M. Stallman <rms@gnu.org>
parents:
15451
diff
changeset
|
153 (goto-char fullname-start) |
6f41e17b3452
(smtpmail-send-it): Don't handle FCC fields until after determining FROM field.
Richard M. Stallman <rms@gnu.org>
parents:
15451
diff
changeset
|
154 (insert "\"") |
6f41e17b3452
(smtpmail-send-it): Don't handle FCC fields until after determining FROM field.
Richard M. Stallman <rms@gnu.org>
parents:
15451
diff
changeset
|
155 (while (re-search-forward "[\"\\]" |
6f41e17b3452
(smtpmail-send-it): Don't handle FCC fields until after determining FROM field.
Richard M. Stallman <rms@gnu.org>
parents:
15451
diff
changeset
|
156 fullname-end 1) |
6f41e17b3452
(smtpmail-send-it): Don't handle FCC fields until after determining FROM field.
Richard M. Stallman <rms@gnu.org>
parents:
15451
diff
changeset
|
157 (replace-match "\\\\\\&" t)) |
6f41e17b3452
(smtpmail-send-it): Don't handle FCC fields until after determining FROM field.
Richard M. Stallman <rms@gnu.org>
parents:
15451
diff
changeset
|
158 (insert "\"")))) |
6f41e17b3452
(smtpmail-send-it): Don't handle FCC fields until after determining FROM field.
Richard M. Stallman <rms@gnu.org>
parents:
15451
diff
changeset
|
159 (insert " <" login ">\n")) |
6f41e17b3452
(smtpmail-send-it): Don't handle FCC fields until after determining FROM field.
Richard M. Stallman <rms@gnu.org>
parents:
15451
diff
changeset
|
160 ((eq mail-from-style 'parens) |
6f41e17b3452
(smtpmail-send-it): Don't handle FCC fields until after determining FROM field.
Richard M. Stallman <rms@gnu.org>
parents:
15451
diff
changeset
|
161 (insert "From: " login " (") |
6f41e17b3452
(smtpmail-send-it): Don't handle FCC fields until after determining FROM field.
Richard M. Stallman <rms@gnu.org>
parents:
15451
diff
changeset
|
162 (let ((fullname-start (point))) |
6f41e17b3452
(smtpmail-send-it): Don't handle FCC fields until after determining FROM field.
Richard M. Stallman <rms@gnu.org>
parents:
15451
diff
changeset
|
163 (insert fullname) |
6f41e17b3452
(smtpmail-send-it): Don't handle FCC fields until after determining FROM field.
Richard M. Stallman <rms@gnu.org>
parents:
15451
diff
changeset
|
164 (let ((fullname-end (point-marker))) |
6f41e17b3452
(smtpmail-send-it): Don't handle FCC fields until after determining FROM field.
Richard M. Stallman <rms@gnu.org>
parents:
15451
diff
changeset
|
165 (goto-char fullname-start) |
6f41e17b3452
(smtpmail-send-it): Don't handle FCC fields until after determining FROM field.
Richard M. Stallman <rms@gnu.org>
parents:
15451
diff
changeset
|
166 ;; RFC 822 says \ and nonmatching parentheses |
6f41e17b3452
(smtpmail-send-it): Don't handle FCC fields until after determining FROM field.
Richard M. Stallman <rms@gnu.org>
parents:
15451
diff
changeset
|
167 ;; must be escaped in comments. |
6f41e17b3452
(smtpmail-send-it): Don't handle FCC fields until after determining FROM field.
Richard M. Stallman <rms@gnu.org>
parents:
15451
diff
changeset
|
168 ;; Escape every instance of ()\ ... |
6f41e17b3452
(smtpmail-send-it): Don't handle FCC fields until after determining FROM field.
Richard M. Stallman <rms@gnu.org>
parents:
15451
diff
changeset
|
169 (while (re-search-forward "[()\\]" fullname-end 1) |
6f41e17b3452
(smtpmail-send-it): Don't handle FCC fields until after determining FROM field.
Richard M. Stallman <rms@gnu.org>
parents:
15451
diff
changeset
|
170 (replace-match "\\\\\\&" t)) |
6f41e17b3452
(smtpmail-send-it): Don't handle FCC fields until after determining FROM field.
Richard M. Stallman <rms@gnu.org>
parents:
15451
diff
changeset
|
171 ;; ... then undo escaping of matching parentheses, |
6f41e17b3452
(smtpmail-send-it): Don't handle FCC fields until after determining FROM field.
Richard M. Stallman <rms@gnu.org>
parents:
15451
diff
changeset
|
172 ;; including matching nested parentheses. |
6f41e17b3452
(smtpmail-send-it): Don't handle FCC fields until after determining FROM field.
Richard M. Stallman <rms@gnu.org>
parents:
15451
diff
changeset
|
173 (goto-char fullname-start) |
6f41e17b3452
(smtpmail-send-it): Don't handle FCC fields until after determining FROM field.
Richard M. Stallman <rms@gnu.org>
parents:
15451
diff
changeset
|
174 (while (re-search-forward |
6f41e17b3452
(smtpmail-send-it): Don't handle FCC fields until after determining FROM field.
Richard M. Stallman <rms@gnu.org>
parents:
15451
diff
changeset
|
175 "\\(\\=\\|[^\\]\\(\\\\\\\\\\)*\\)\\\\(\\(\\([^\\]\\|\\\\\\\\\\)*\\)\\\\)" |
6f41e17b3452
(smtpmail-send-it): Don't handle FCC fields until after determining FROM field.
Richard M. Stallman <rms@gnu.org>
parents:
15451
diff
changeset
|
176 fullname-end 1) |
6f41e17b3452
(smtpmail-send-it): Don't handle FCC fields until after determining FROM field.
Richard M. Stallman <rms@gnu.org>
parents:
15451
diff
changeset
|
177 (replace-match "\\1(\\3)" t) |
6f41e17b3452
(smtpmail-send-it): Don't handle FCC fields until after determining FROM field.
Richard M. Stallman <rms@gnu.org>
parents:
15451
diff
changeset
|
178 (goto-char fullname-start)))) |
6f41e17b3452
(smtpmail-send-it): Don't handle FCC fields until after determining FROM field.
Richard M. Stallman <rms@gnu.org>
parents:
15451
diff
changeset
|
179 (insert ")\n")) |
6f41e17b3452
(smtpmail-send-it): Don't handle FCC fields until after determining FROM field.
Richard M. Stallman <rms@gnu.org>
parents:
15451
diff
changeset
|
180 ((null mail-from-style) |
6f41e17b3452
(smtpmail-send-it): Don't handle FCC fields until after determining FROM field.
Richard M. Stallman <rms@gnu.org>
parents:
15451
diff
changeset
|
181 (insert "From: " login "\n"))))) |
15345 | 182 ;; Insert an extra newline if we need it to work around |
183 ;; Sun's bug that swallows newlines. | |
184 (goto-char (1+ delimline)) | |
185 (if (eval mail-mailer-swallows-blank-line) | |
186 (newline)) | |
15452
6f41e17b3452
(smtpmail-send-it): Don't handle FCC fields until after determining FROM field.
Richard M. Stallman <rms@gnu.org>
parents:
15451
diff
changeset
|
187 ;; Find and handle any FCC fields. |
6f41e17b3452
(smtpmail-send-it): Don't handle FCC fields until after determining FROM field.
Richard M. Stallman <rms@gnu.org>
parents:
15451
diff
changeset
|
188 (goto-char (point-min)) |
6f41e17b3452
(smtpmail-send-it): Don't handle FCC fields until after determining FROM field.
Richard M. Stallman <rms@gnu.org>
parents:
15451
diff
changeset
|
189 (if (re-search-forward "^FCC:" delimline t) |
6f41e17b3452
(smtpmail-send-it): Don't handle FCC fields until after determining FROM field.
Richard M. Stallman <rms@gnu.org>
parents:
15451
diff
changeset
|
190 (mail-do-fcc delimline)) |
15345 | 191 (if mail-interactive |
192 (save-excursion | |
193 (set-buffer errbuf) | |
194 (erase-buffer)))) | |
195 ;; | |
196 ;; | |
197 ;; | |
198 (setq smtpmail-address-buffer (generate-new-buffer "*smtp-mail*")) | |
199 (setq smtpmail-recipient-address-list | |
15595
0d4a7f47f31d
(smtpmail-send-it): Ignore `To:' if there is a `Resent-to':.
Miles Bader <miles@gnu.org>
parents:
15454
diff
changeset
|
200 (or resend-to-addresses |
0d4a7f47f31d
(smtpmail-send-it): Ignore `To:' if there is a `Resent-to':.
Miles Bader <miles@gnu.org>
parents:
15454
diff
changeset
|
201 (smtpmail-deduce-address-list tembuf (point-min) delimline))) |
15345 | 202 (kill-buffer smtpmail-address-buffer) |
203 | |
204 (smtpmail-do-bcc delimline) | |
205 | |
206 (if (not (null smtpmail-recipient-address-list)) | |
207 (if (not (smtpmail-via-smtp smtpmail-recipient-address-list tembuf)) | |
15346
4cd6ff2384dc
(smtpmail-send-it): Fix error messages.
Richard M. Stallman <rms@gnu.org>
parents:
15345
diff
changeset
|
208 (error "Sending failed; SMTP protocol error")) |
4cd6ff2384dc
(smtpmail-send-it): Fix error messages.
Richard M. Stallman <rms@gnu.org>
parents:
15345
diff
changeset
|
209 (error "Sending failed; no recipients")) |
15345 | 210 ) |
211 (kill-buffer tembuf) | |
212 (if (bufferp errbuf) | |
213 (kill-buffer errbuf))))) | |
214 | |
215 | |
216 ;(defun smtpmail-via-smtp (host,port,sender,destination,smtpmail-text-buffer) | |
217 | |
218 (defun smtpmail-fqdn () | |
219 (if smtpmail-local-domain | |
220 (concat (system-name) "." smtpmail-local-domain) | |
221 (system-name))) | |
222 | |
223 (defun smtpmail-via-smtp (recipient smtpmail-text-buffer) | |
224 (let ((process nil) | |
15346
4cd6ff2384dc
(smtpmail-send-it): Fix error messages.
Richard M. Stallman <rms@gnu.org>
parents:
15345
diff
changeset
|
225 (host smtpmail-smtp-server) |
4cd6ff2384dc
(smtpmail-send-it): Fix error messages.
Richard M. Stallman <rms@gnu.org>
parents:
15345
diff
changeset
|
226 (port smtpmail-smtp-service) |
15345 | 227 response-code |
15346
4cd6ff2384dc
(smtpmail-send-it): Fix error messages.
Richard M. Stallman <rms@gnu.org>
parents:
15345
diff
changeset
|
228 greeting |
4cd6ff2384dc
(smtpmail-send-it): Fix error messages.
Richard M. Stallman <rms@gnu.org>
parents:
15345
diff
changeset
|
229 process-buffer) |
15345 | 230 (unwind-protect |
231 (catch 'done | |
232 ;; get or create the trace buffer | |
233 (setq process-buffer | |
234 (get-buffer-create (format "*trace of SMTP session to %s*" host))) | |
235 | |
236 ;; clear the trace buffer of old output | |
237 (save-excursion | |
238 (set-buffer process-buffer) | |
239 (erase-buffer)) | |
240 | |
241 ;; open the connection to the server | |
242 (setq process (open-network-stream "SMTP" process-buffer host port)) | |
243 (and (null process) (throw 'done nil)) | |
244 | |
245 ;; set the send-filter | |
246 (set-process-filter process 'smtpmail-process-filter) | |
247 | |
248 (save-excursion | |
249 (set-buffer process-buffer) | |
250 (make-local-variable 'smtpmail-read-point) | |
251 (setq smtpmail-read-point (point-min)) | |
252 | |
253 | |
254 (if (or (null (car (setq greeting (smtpmail-read-response process)))) | |
255 (not (integerp (car greeting))) | |
256 (>= (car greeting) 400)) | |
257 (throw 'done nil) | |
258 ) | |
259 | |
260 ;; HELO | |
261 (smtpmail-send-command process (format "HELO %s" (smtpmail-fqdn))) | |
262 | |
263 (if (or (null (car (setq response-code (smtpmail-read-response process)))) | |
264 (not (integerp (car response-code))) | |
265 (>= (car response-code) 400)) | |
266 (throw 'done nil) | |
267 ) | |
268 | |
269 ;; MAIL FROM: <sender> | |
270 ; (smtpmail-send-command process (format "MAIL FROM:%s@%s" (user-login-name) (smtpmail-fqdn))) | |
15453
ad4f0ac5e7ef
(smtpmail-via-smtp): Bracket names in FROM and RCPT TO commands.
Richard M. Stallman <rms@gnu.org>
parents:
15452
diff
changeset
|
271 (smtpmail-send-command process (format "MAIL FROM: <%s>" user-mail-address)) |
15345 | 272 |
273 (if (or (null (car (setq response-code (smtpmail-read-response process)))) | |
274 (not (integerp (car response-code))) | |
275 (>= (car response-code) 400)) | |
276 (throw 'done nil) | |
277 ) | |
278 | |
279 ;; RCPT TO: <recipient> | |
15346
4cd6ff2384dc
(smtpmail-send-it): Fix error messages.
Richard M. Stallman <rms@gnu.org>
parents:
15345
diff
changeset
|
280 (let ((n 0)) |
4cd6ff2384dc
(smtpmail-send-it): Fix error messages.
Richard M. Stallman <rms@gnu.org>
parents:
15345
diff
changeset
|
281 (while (not (null (nth n recipient))) |
15453
ad4f0ac5e7ef
(smtpmail-via-smtp): Bracket names in FROM and RCPT TO commands.
Richard M. Stallman <rms@gnu.org>
parents:
15452
diff
changeset
|
282 (smtpmail-send-command process (format "RCPT TO: <%s>" (nth n recipient))) |
15346
4cd6ff2384dc
(smtpmail-send-it): Fix error messages.
Richard M. Stallman <rms@gnu.org>
parents:
15345
diff
changeset
|
283 (setq n (1+ n)) |
15345 | 284 |
15346
4cd6ff2384dc
(smtpmail-send-it): Fix error messages.
Richard M. Stallman <rms@gnu.org>
parents:
15345
diff
changeset
|
285 (if (or (null (car (setq response-code (smtpmail-read-response process)))) |
4cd6ff2384dc
(smtpmail-send-it): Fix error messages.
Richard M. Stallman <rms@gnu.org>
parents:
15345
diff
changeset
|
286 (not (integerp (car response-code))) |
4cd6ff2384dc
(smtpmail-send-it): Fix error messages.
Richard M. Stallman <rms@gnu.org>
parents:
15345
diff
changeset
|
287 (>= (car response-code) 400)) |
4cd6ff2384dc
(smtpmail-send-it): Fix error messages.
Richard M. Stallman <rms@gnu.org>
parents:
15345
diff
changeset
|
288 (throw 'done nil) |
4cd6ff2384dc
(smtpmail-send-it): Fix error messages.
Richard M. Stallman <rms@gnu.org>
parents:
15345
diff
changeset
|
289 ) |
4cd6ff2384dc
(smtpmail-send-it): Fix error messages.
Richard M. Stallman <rms@gnu.org>
parents:
15345
diff
changeset
|
290 )) |
15345 | 291 |
292 ;; DATA | |
293 (smtpmail-send-command process "DATA") | |
294 | |
295 (if (or (null (car (setq response-code (smtpmail-read-response process)))) | |
296 (not (integerp (car response-code))) | |
297 (>= (car response-code) 400)) | |
298 (throw 'done nil) | |
299 ) | |
300 | |
301 ;; Mail contents | |
302 (smtpmail-send-data process smtpmail-text-buffer) | |
303 | |
304 ;;DATA end "." | |
305 (smtpmail-send-command process ".") | |
306 | |
307 (if (or (null (car (setq response-code (smtpmail-read-response process)))) | |
308 (not (integerp (car response-code))) | |
309 (>= (car response-code) 400)) | |
310 (throw 'done nil) | |
311 ) | |
312 | |
313 ;;QUIT | |
314 ; (smtpmail-send-command process "QUIT") | |
315 ; (and (null (car (smtpmail-read-response process))) | |
316 ; (throw 'done nil)) | |
317 t )) | |
318 (if process | |
319 (save-excursion | |
320 (set-buffer (process-buffer process)) | |
321 (smtpmail-send-command process "QUIT") | |
322 (smtpmail-read-response process) | |
323 | |
324 ; (if (or (null (car (setq response-code (smtpmail-read-response process)))) | |
325 ; (not (integerp (car response-code))) | |
326 ; (>= (car response-code) 400)) | |
327 ; (throw 'done nil) | |
328 ; ) | |
329 (delete-process process)))))) | |
330 | |
331 | |
332 (defun smtpmail-process-filter (process output) | |
333 (save-excursion | |
334 (set-buffer (process-buffer process)) | |
335 (goto-char (point-max)) | |
336 (insert output))) | |
337 | |
338 (defun smtpmail-read-response (process) | |
339 (let ((case-fold-search nil) | |
340 (response-string nil) | |
341 (response-continue t) | |
342 (return-value '(nil "")) | |
343 match-end) | |
344 | |
345 ; (setq response-string nil) | |
346 ; (setq response-continue t) | |
347 ; (setq return-value '(nil "")) | |
348 | |
349 (while response-continue | |
15454
85313b347ed9
(smtpmail-read-response): Goto smtpmail-read-point
Richard M. Stallman <rms@gnu.org>
parents:
15453
diff
changeset
|
350 (goto-char smtpmail-read-point) |
15345 | 351 (while (not (search-forward "\r\n" nil t)) |
352 (accept-process-output process) | |
353 (goto-char smtpmail-read-point)) | |
354 | |
355 (setq match-end (point)) | |
356 (if (null response-string) | |
357 (setq response-string | |
358 (buffer-substring smtpmail-read-point (- match-end 2)))) | |
359 | |
360 (goto-char smtpmail-read-point) | |
361 (if (looking-at "[0-9]+ ") | |
362 (progn (setq response-continue nil) | |
363 ; (setq return-value response-string) | |
364 | |
365 (if smtpmail-debug-info | |
16907
3c4a708a2631
(smtpmail-read-response): Don't get confused by %'s in response-string.
Richard M. Stallman <rms@gnu.org>
parents:
15676
diff
changeset
|
366 (message "%s" response-string)) |
15345 | 367 |
368 (setq smtpmail-read-point match-end) | |
369 (setq return-value | |
370 (cons (string-to-int | |
371 (buffer-substring (match-beginning 0) (match-end 0))) | |
372 response-string))) | |
373 | |
374 (if (looking-at "[0-9]+-") | |
375 (progn (setq smtpmail-read-point match-end) | |
376 (setq response-continue t)) | |
377 (progn | |
378 (setq smtpmail-read-point match-end) | |
379 (setq response-continue nil) | |
380 (setq return-value | |
381 (cons nil response-string)) | |
382 ) | |
383 ))) | |
384 (setq smtpmail-read-point match-end) | |
385 return-value)) | |
386 | |
387 | |
388 (defun smtpmail-send-command (process command) | |
389 (goto-char (point-max)) | |
390 (if (= (aref command 0) ?P) | |
391 (insert "PASS <omitted>\r\n") | |
392 (insert command "\r\n")) | |
393 (setq smtpmail-read-point (point)) | |
394 (process-send-string process command) | |
395 (process-send-string process "\r\n")) | |
396 | |
397 (defun smtpmail-send-data-1 (process data) | |
398 (goto-char (point-max)) | |
399 | |
400 (if (not (null smtpmail-code-conv-from)) | |
401 (setq data (code-convert-string data smtpmail-code-conv-from *internal*))) | |
402 | |
403 (if smtpmail-debug-info | |
404 (insert data "\r\n")) | |
405 | |
406 (setq smtpmail-read-point (point)) | |
15676
46d74bda4351
(smtpmail-send-data-1): Escape "." at the start of
Karl Heuer <kwzh@gnu.org>
parents:
15648
diff
changeset
|
407 ;; Escape "." at start of a line |
46d74bda4351
(smtpmail-send-data-1): Escape "." at the start of
Karl Heuer <kwzh@gnu.org>
parents:
15648
diff
changeset
|
408 (if (eq (string-to-char data) ?.) |
46d74bda4351
(smtpmail-send-data-1): Escape "." at the start of
Karl Heuer <kwzh@gnu.org>
parents:
15648
diff
changeset
|
409 (process-send-string process ".")) |
15345 | 410 (process-send-string process data) |
411 (process-send-string process "\r\n") | |
412 ) | |
413 | |
414 (defun smtpmail-send-data (process buffer) | |
415 (let | |
416 ((data-continue t) | |
417 (sending-data nil) | |
418 this-line | |
419 this-line-end) | |
420 | |
421 (save-excursion | |
422 (set-buffer buffer) | |
423 (goto-char (point-min))) | |
424 | |
425 (while data-continue | |
426 (save-excursion | |
427 (set-buffer buffer) | |
428 (beginning-of-line) | |
429 (setq this-line (point)) | |
430 (end-of-line) | |
431 (setq this-line-end (point)) | |
432 (setq sending-data nil) | |
433 (setq sending-data (buffer-substring this-line this-line-end)) | |
434 (if (/= (forward-line 1) 0) | |
435 (setq data-continue nil))) | |
436 | |
437 (smtpmail-send-data-1 process sending-data) | |
438 ) | |
439 ) | |
440 ) | |
441 | |
442 | |
443 (defun smtpmail-deduce-address-list (smtpmail-text-buffer header-start header-end) | |
444 "Get address list suitable for smtp RCPT TO: <address>." | |
445 (require 'mail-utils) ;; pick up mail-strip-quoted-names | |
446 (let | |
447 ((case-fold-search t) | |
448 (simple-address-list "") | |
449 this-line | |
15648
2feeabc94834
(smtpmail-deduce-address-list): Handle RESENT-* fields.
Karl Heuer <kwzh@gnu.org>
parents:
15595
diff
changeset
|
450 this-line-end |
2feeabc94834
(smtpmail-deduce-address-list): Handle RESENT-* fields.
Karl Heuer <kwzh@gnu.org>
parents:
15595
diff
changeset
|
451 addr-regexp) |
15345 | 452 |
453 (unwind-protect | |
454 (save-excursion | |
455 ;; | |
456 (set-buffer smtpmail-address-buffer) (erase-buffer) | |
457 (insert-buffer-substring smtpmail-text-buffer header-start header-end) | |
458 (goto-char (point-min)) | |
15648
2feeabc94834
(smtpmail-deduce-address-list): Handle RESENT-* fields.
Karl Heuer <kwzh@gnu.org>
parents:
15595
diff
changeset
|
459 ;; RESENT-* fields should stop processing of regular fields. |
2feeabc94834
(smtpmail-deduce-address-list): Handle RESENT-* fields.
Karl Heuer <kwzh@gnu.org>
parents:
15595
diff
changeset
|
460 (save-excursion |
2feeabc94834
(smtpmail-deduce-address-list): Handle RESENT-* fields.
Karl Heuer <kwzh@gnu.org>
parents:
15595
diff
changeset
|
461 (if (re-search-forward "^RESENT-TO:" header-end t) |
2feeabc94834
(smtpmail-deduce-address-list): Handle RESENT-* fields.
Karl Heuer <kwzh@gnu.org>
parents:
15595
diff
changeset
|
462 (setq addr-regexp "^\\(RESENT-TO:\\|RESENT-CC:\\|RESENT-BCC:\\)") |
2feeabc94834
(smtpmail-deduce-address-list): Handle RESENT-* fields.
Karl Heuer <kwzh@gnu.org>
parents:
15595
diff
changeset
|
463 (setq addr-regexp "^\\(TO:\\|CC:\\|BCC:\\)"))) |
2feeabc94834
(smtpmail-deduce-address-list): Handle RESENT-* fields.
Karl Heuer <kwzh@gnu.org>
parents:
15595
diff
changeset
|
464 |
2feeabc94834
(smtpmail-deduce-address-list): Handle RESENT-* fields.
Karl Heuer <kwzh@gnu.org>
parents:
15595
diff
changeset
|
465 (while (re-search-forward addr-regexp header-end t) |
15345 | 466 (replace-match "") |
467 (setq this-line (match-beginning 0)) | |
468 (forward-line 1) | |
469 ;; get any continuation lines | |
470 (while (and (looking-at "^[ \t]+") (< (point) header-end)) | |
471 (forward-line 1)) | |
472 (setq this-line-end (point-marker)) | |
473 (setq simple-address-list | |
474 (concat simple-address-list " " | |
475 (mail-strip-quoted-names (buffer-substring this-line this-line-end)))) | |
476 ) | |
477 (erase-buffer) | |
478 (insert-string " ") | |
479 (insert-string simple-address-list) | |
480 (insert-string "\n") | |
481 (subst-char-in-region (point-min) (point-max) 10 ? t);; newline --> blank | |
482 (subst-char-in-region (point-min) (point-max) ?, ? t);; comma --> blank | |
483 (subst-char-in-region (point-min) (point-max) 9 ? t);; tab --> blank | |
484 | |
485 (goto-char (point-min)) | |
486 ;; tidyness in case hook is not robust when it looks at this | |
487 (while (re-search-forward "[ \t]+" header-end t) (replace-match " ")) | |
488 | |
489 (goto-char (point-min)) | |
15346
4cd6ff2384dc
(smtpmail-send-it): Fix error messages.
Richard M. Stallman <rms@gnu.org>
parents:
15345
diff
changeset
|
490 (let (recipient-address-list) |
15451
89c1e7fe879a
(smtpmail-smtp-service): Use port 25 as default.
Richard M. Stallman <rms@gnu.org>
parents:
15372
diff
changeset
|
491 (while (re-search-forward " \\([^ ]+\\) " (point-max) t) |
15346
4cd6ff2384dc
(smtpmail-send-it): Fix error messages.
Richard M. Stallman <rms@gnu.org>
parents:
15345
diff
changeset
|
492 (backward-char 1) |
15451
89c1e7fe879a
(smtpmail-smtp-service): Use port 25 as default.
Richard M. Stallman <rms@gnu.org>
parents:
15372
diff
changeset
|
493 (setq recipient-address-list (cons (buffer-substring (match-beginning 1) (match-end 1)) |
89c1e7fe879a
(smtpmail-smtp-service): Use port 25 as default.
Richard M. Stallman <rms@gnu.org>
parents:
15372
diff
changeset
|
494 recipient-address-list)) |
15346
4cd6ff2384dc
(smtpmail-send-it): Fix error messages.
Richard M. Stallman <rms@gnu.org>
parents:
15345
diff
changeset
|
495 ) |
4cd6ff2384dc
(smtpmail-send-it): Fix error messages.
Richard M. Stallman <rms@gnu.org>
parents:
15345
diff
changeset
|
496 (setq smtpmail-recipient-address-list recipient-address-list)) |
15345 | 497 |
498 ) | |
499 ) | |
500 ) | |
501 ) | |
502 | |
503 | |
504 (defun smtpmail-do-bcc (header-end) | |
505 "Delete BCC: and their continuation lines from the header area. | |
506 There may be multiple BCC: lines, and each may have arbitrarily | |
507 many continuation lines." | |
508 (let ((case-fold-search t)) | |
509 (save-excursion (goto-char (point-min)) | |
510 ;; iterate over all BCC: lines | |
511 (while (re-search-forward "^BCC:" header-end t) | |
512 (delete-region (match-beginning 0) (progn (forward-line 1) (point))) | |
513 ;; get rid of any continuation lines | |
514 (while (and (looking-at "^[ \t].*\n") (< (point) header-end)) | |
515 (replace-match "")) | |
516 ) | |
517 ) ;; save-excursion | |
518 ) ;; let | |
519 ) | |
520 | |
521 | |
522 | |
523 (provide 'smtpmail) | |
524 | |
525 ;; smtpmail.el ends here |