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