Mercurial > emacs
comparison lisp/mail/smtpmail.el @ 15345:4eef6c1687f8
Initial revision
author | Richard M. Stallman <rms@gnu.org> |
---|---|
date | Fri, 07 Jun 1996 14:21:50 +0000 |
parents | |
children | 4cd6ff2384dc |
comparison
equal
deleted
inserted
replaced
15344:82615c826910 | 15345:4eef6c1687f8 |
---|---|
1 ;; Simple SMTP protocol (RFC 821) for sending mail | |
2 | |
3 ;; Copyright (C) 1995 Free Software Foundation, Inc. | |
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 | |
48 (defvar smtpmail-smtp-server (or (getenv "SMTPSERVER") | |
49 smtpmail-default-smtp-server) | |
50 "*The name of the host running SMTP server.") | |
51 | |
52 (defvar smtpmail-smtp-service "smtp" | |
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 () | |
71 (let ((errbuf (if mail-interactive | |
72 (generate-new-buffer " smtpmail errors") | |
73 0)) | |
74 (tembuf (generate-new-buffer " smtpmail temp")) | |
75 (case-fold-search nil) | |
76 resend-to-addresses | |
77 delimline | |
78 (mailbuf (current-buffer))) | |
79 (unwind-protect | |
80 (save-excursion | |
81 (set-buffer tembuf) | |
82 (erase-buffer) | |
83 (insert-buffer-substring mailbuf) | |
84 (goto-char (point-max)) | |
85 ;; require one newline at the end. | |
86 (or (= (preceding-char) ?\n) | |
87 (insert ?\n)) | |
88 ;; Change header-delimiter to be what sendmail expects. | |
89 (goto-char (point-min)) | |
90 (re-search-forward | |
91 (concat "^" (regexp-quote mail-header-separator) "\n")) | |
92 (replace-match "\n") | |
93 (backward-char 1) | |
94 (setq delimline (point-marker)) | |
95 (if mail-aliases | |
96 (expand-mail-aliases (point-min) delimline)) | |
97 (goto-char (point-min)) | |
98 ;; ignore any blank lines in the header | |
99 (while (and (re-search-forward "\n\n\n*" delimline t) | |
100 (< (point) delimline)) | |
101 (replace-match "\n")) | |
102 (let ((case-fold-search t)) | |
103 (goto-char (point-min)) | |
104 ;; Find and handle any FCC fields. | |
105 (goto-char (point-min)) | |
106 (if (re-search-forward "^FCC:" delimline t) | |
107 (mail-do-fcc delimline)) | |
108 (goto-char (point-min)) | |
109 (require 'mail-utils) | |
110 (while (re-search-forward "^Resent-to:" delimline t) | |
111 (setq resend-to-addresses | |
112 (save-restriction | |
113 (narrow-to-region (point) | |
114 (save-excursion | |
115 (end-of-line) | |
116 (point))) | |
117 (append (mail-parse-comma-list) | |
118 resend-to-addresses)))) | |
119 ;;; Apparently this causes a duplicate Sender. | |
120 ;;; ;; If the From is different than current user, insert Sender. | |
121 ;;; (goto-char (point-min)) | |
122 ;;; (and (re-search-forward "^From:" delimline t) | |
123 ;;; (progn | |
124 ;;; (require 'mail-utils) | |
125 ;;; (not (string-equal | |
126 ;;; (mail-strip-quoted-names | |
127 ;;; (save-restriction | |
128 ;;; (narrow-to-region (point-min) delimline) | |
129 ;;; (mail-fetch-field "From"))) | |
130 ;;; (user-login-name)))) | |
131 ;;; (progn | |
132 ;;; (forward-line 1) | |
133 ;;; (insert "Sender: " (user-login-name) "\n"))) | |
134 ;; "S:" is an abbreviation for "Subject:". | |
135 (goto-char (point-min)) | |
136 (if (re-search-forward "^S:" delimline t) | |
137 (replace-match "Subject:")) | |
138 ;; Don't send out a blank subject line | |
139 (goto-char (point-min)) | |
140 (if (re-search-forward "^Subject:[ \t]*\n" delimline t) | |
141 (replace-match "")) | |
142 ;; Insert an extra newline if we need it to work around | |
143 ;; Sun's bug that swallows newlines. | |
144 (goto-char (1+ delimline)) | |
145 (if (eval mail-mailer-swallows-blank-line) | |
146 (newline)) | |
147 (if mail-interactive | |
148 (save-excursion | |
149 (set-buffer errbuf) | |
150 (erase-buffer)))) | |
151 ;; | |
152 ;; | |
153 ;; | |
154 (setq smtpmail-address-buffer (generate-new-buffer "*smtp-mail*")) | |
155 (setq smtpmail-recipient-address-list | |
156 (smtpmail-deduce-address-list tembuf (point-min) delimline)) | |
157 (kill-buffer smtpmail-address-buffer) | |
158 | |
159 (smtpmail-do-bcc delimline) | |
160 | |
161 (if (not (null smtpmail-recipient-address-list)) | |
162 (if (not (smtpmail-via-smtp smtpmail-recipient-address-list tembuf)) | |
163 (error "Sending... Failed. SMTP Protocol Error.")) | |
164 (error "Sending... failed. No recipients.")) | |
165 ) | |
166 (kill-buffer tembuf) | |
167 (if (bufferp errbuf) | |
168 (kill-buffer errbuf))))) | |
169 | |
170 | |
171 ;(defun smtpmail-via-smtp (host,port,sender,destination,smtpmail-text-buffer) | |
172 | |
173 (defun smtpmail-fqdn () | |
174 (if smtpmail-local-domain | |
175 (concat (system-name) "." smtpmail-local-domain) | |
176 (system-name))) | |
177 | |
178 (defun smtpmail-via-smtp (recipient smtpmail-text-buffer) | |
179 (let ((process nil) | |
180 host | |
181 port | |
182 response-code | |
183 ) | |
184 (setq host smtpmail-smtp-server) | |
185 (setq port smtpmail-smtp-service) | |
186 | |
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> | |
237 (setq n 0) | |
238 (while (not (null (nth n recipient))) | |
239 (smtpmail-send-command process (format "RCPT TO: %s" (nth n recipient))) | |
240 (setq n (1+ n)) | |
241 | |
242 (if (or (null (car (setq response-code (smtpmail-read-response process)))) | |
243 (not (integerp (car response-code))) | |
244 (>= (car response-code) 400)) | |
245 (throw 'done nil) | |
246 ) | |
247 ) | |
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 ;; check completely by T.Kagatani | |
290 (defun smtpmail-process-filter (process output) | |
291 (save-excursion | |
292 (set-buffer (process-buffer process)) | |
293 (goto-char (point-max)) | |
294 (insert output))) | |
295 | |
296 ;; check completely by T.Kagatani | |
297 (defun smtpmail-read-response (process) | |
298 (let ((case-fold-search nil) | |
299 (response-string nil) | |
300 (response-continue t) | |
301 (return-value '(nil "")) | |
302 match-end) | |
303 | |
304 ; (setq response-string nil) | |
305 ; (setq response-continue t) | |
306 ; (setq return-value '(nil "")) | |
307 | |
308 (goto-char smtpmail-read-point) | |
309 (while response-continue | |
310 (while (not (search-forward "\r\n" nil t)) | |
311 (accept-process-output process) | |
312 (goto-char smtpmail-read-point)) | |
313 | |
314 (setq match-end (point)) | |
315 (if (null response-string) | |
316 (setq response-string | |
317 (buffer-substring smtpmail-read-point (- match-end 2)))) | |
318 | |
319 (goto-char smtpmail-read-point) | |
320 (if (looking-at "[0-9]+ ") | |
321 (progn (setq response-continue nil) | |
322 ; (setq return-value response-string) | |
323 | |
324 (if smtpmail-debug-info | |
325 (message response-string)) | |
326 | |
327 (setq smtpmail-read-point match-end) | |
328 (setq return-value | |
329 (cons (string-to-int | |
330 (buffer-substring (match-beginning 0) (match-end 0))) | |
331 response-string))) | |
332 | |
333 (if (looking-at "[0-9]+-") | |
334 (progn (setq smtpmail-read-point match-end) | |
335 (setq response-continue t)) | |
336 (progn | |
337 (setq smtpmail-read-point match-end) | |
338 (setq response-continue nil) | |
339 (setq return-value | |
340 (cons nil response-string)) | |
341 ) | |
342 ))) | |
343 (setq smtpmail-read-point match-end) | |
344 return-value)) | |
345 | |
346 | |
347 ;; check completely by T.Kagatani | |
348 (defun smtpmail-send-command (process command) | |
349 (goto-char (point-max)) | |
350 (if (= (aref command 0) ?P) | |
351 (insert "PASS <omitted>\r\n") | |
352 (insert command "\r\n")) | |
353 (setq smtpmail-read-point (point)) | |
354 (process-send-string process command) | |
355 (process-send-string process "\r\n")) | |
356 | |
357 ;; check completely by T.Kagatani | |
358 (defun smtpmail-send-data-1 (process data) | |
359 (goto-char (point-max)) | |
360 | |
361 (if (not (null smtpmail-code-conv-from)) | |
362 (setq data (code-convert-string data smtpmail-code-conv-from *internal*))) | |
363 | |
364 (if smtpmail-debug-info | |
365 (insert data "\r\n")) | |
366 | |
367 (setq smtpmail-read-point (point)) | |
368 (process-send-string process data) | |
369 ;; . -> .. | |
370 (if (string-equal data ".") | |
371 (process-send-string process ".")) | |
372 (process-send-string process "\r\n") | |
373 ) | |
374 | |
375 (defun smtpmail-send-data (process buffer) | |
376 (let | |
377 ((data-continue t) | |
378 (sending-data nil) | |
379 this-line | |
380 this-line-end) | |
381 | |
382 (save-excursion | |
383 (set-buffer buffer) | |
384 (goto-char (point-min))) | |
385 | |
386 (while data-continue | |
387 (save-excursion | |
388 (set-buffer buffer) | |
389 (beginning-of-line) | |
390 (setq this-line (point)) | |
391 (end-of-line) | |
392 (setq this-line-end (point)) | |
393 (setq sending-data nil) | |
394 (setq sending-data (buffer-substring this-line this-line-end)) | |
395 (if (/= (forward-line 1) 0) | |
396 (setq data-continue nil))) | |
397 | |
398 (smtpmail-send-data-1 process sending-data) | |
399 ) | |
400 ) | |
401 ) | |
402 | |
403 | |
404 (defun smtpmail-deduce-address-list (smtpmail-text-buffer header-start header-end) | |
405 "Get address list suitable for smtp RCPT TO: <address>." | |
406 (require 'mail-utils) ;; pick up mail-strip-quoted-names | |
407 (let | |
408 ((case-fold-search t) | |
409 (simple-address-list "") | |
410 this-line | |
411 this-line-end) | |
412 | |
413 (unwind-protect | |
414 (save-excursion | |
415 ;; | |
416 (set-buffer smtpmail-address-buffer) (erase-buffer) | |
417 (insert-buffer-substring smtpmail-text-buffer header-start header-end) | |
418 (goto-char (point-min)) | |
419 (while (re-search-forward "^\\(TO:\\|CC:\\|BCC:\\)" header-end t) | |
420 (replace-match "") | |
421 (setq this-line (match-beginning 0)) | |
422 (forward-line 1) | |
423 ;; get any continuation lines | |
424 (while (and (looking-at "^[ \t]+") (< (point) header-end)) | |
425 (forward-line 1)) | |
426 (setq this-line-end (point-marker)) | |
427 (setq simple-address-list | |
428 (concat simple-address-list " " | |
429 (mail-strip-quoted-names (buffer-substring this-line this-line-end)))) | |
430 ) | |
431 (erase-buffer) | |
432 (insert-string " ") | |
433 (insert-string simple-address-list) | |
434 (insert-string "\n") | |
435 (subst-char-in-region (point-min) (point-max) 10 ? t);; newline --> blank | |
436 (subst-char-in-region (point-min) (point-max) ?, ? t);; comma --> blank | |
437 (subst-char-in-region (point-min) (point-max) 9 ? t);; tab --> blank | |
438 | |
439 (goto-char (point-min)) | |
440 ;; tidyness in case hook is not robust when it looks at this | |
441 (while (re-search-forward "[ \t]+" header-end t) (replace-match " ")) | |
442 | |
443 (goto-char (point-min)) | |
444 (setq recipient-address-list nil) | |
445 (while (re-search-forward " [^ ]+ " (point-max) t) | |
446 (backward-char 1) | |
447 (setq recipient-address-list(cons (buffer-substring (match-beginning 0) (match-end 0)) | |
448 recipient-address-list)) | |
449 ) | |
450 (setq smtpmail-recipient-address-list recipient-address-list) | |
451 | |
452 ) | |
453 ) | |
454 ) | |
455 ) | |
456 | |
457 | |
458 (defun smtpmail-do-bcc (header-end) | |
459 "Delete BCC: and their continuation lines from the header area. | |
460 There may be multiple BCC: lines, and each may have arbitrarily | |
461 many continuation lines." | |
462 (let ((case-fold-search t)) | |
463 (save-excursion (goto-char (point-min)) | |
464 ;; iterate over all BCC: lines | |
465 (while (re-search-forward "^BCC:" header-end t) | |
466 (delete-region (match-beginning 0) (progn (forward-line 1) (point))) | |
467 ;; get rid of any continuation lines | |
468 (while (and (looking-at "^[ \t].*\n") (< (point) header-end)) | |
469 (replace-match "")) | |
470 ) | |
471 ) ;; save-excursion | |
472 ) ;; let | |
473 ) | |
474 | |
475 | |
476 | |
477 (provide 'smtpmail) | |
478 | |
479 ;; smtpmail.el ends here |