1 ;;; smtp.el --- basic functions to send mail with SMTP server
3 ;; Copyright (C) 1995, 1996, 1998 Free Software Foundation, Inc.
5 ;; Author: Tomoji Kagatani <kagatani@rbc.ncl.omron.co.jp>
6 ;; Simon Leinen <simon@switch.ch> (ESMTP support)
7 ;; Shuhei KOBAYASHI <shuhei-k@jaist.ac.jp>
8 ;; Keywords: SMTP, mail
10 ;; This file is part of FLIM (Faithful Library about Internet Message).
12 ;; This program is free software; you can redistribute it and/or
13 ;; modify it under the terms of the GNU General Public License as
14 ;; published by the Free Software Foundation; either version 2, or (at
15 ;; your option) any later version.
17 ;; This program is distributed in the hope that it will be useful, but
18 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
20 ;; General Public License for more details.
22 ;; You should have received a copy of the GNU General Public License
23 ;; along with GNU Emacs; see the file COPYING. If not, write to the
24 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
25 ;; Boston, MA 02111-1307, USA.
29 (require 'mail-utils) ; pick up mail-strip-quoted-names
32 "SMTP protocol for sending mail."
35 (defcustom smtp-default-server nil
36 "*Specify default SMTP server."
37 :type '(choice (const nil) string)
40 (defcustom smtp-server (or (getenv "SMTPSERVER") smtp-default-server)
41 "*The name of the host running SMTP server."
42 :type '(choice (const nil) string)
45 (defcustom smtp-service "smtp"
46 "*SMTP service port number. \"smtp\" or 25."
47 :type '(choice (integer :tag "25" 25)
48 (string :tag "smtp" "smtp"))
51 (defcustom smtp-use-8bitmime t
52 "*If non-nil, use ESMTP 8BITMIME if available."
56 (defcustom smtp-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 :type '(choice (const nil) string)
63 (defcustom smtp-coding-system 'binary
64 "*Coding-system for SMTP output."
68 (defvar smtp-debug-info nil)
69 (defvar smtp-read-point nil)
71 (defun smtp-make-fqdn ()
72 "Return user's fully qualified domain name."
73 (let ((system-name (system-name)))
76 (concat system-name "." smtp-local-domain))
77 ((string-match "[^.]\\.[^.]" system-name)
80 (error "Cannot generate valid FQDN. Set `smtp-local-domain' correctly.")))))
82 (defun smtp-via-smtp (sender recipients smtp-text-buffer)
83 (let ((coding-system-for-read smtp-coding-system)
84 (coding-system-for-write smtp-coding-system)
85 process response extensions)
89 (format "*trace of SMTP session to %s*" smtp-server)))
91 (make-local-variable 'smtp-read-point)
92 (setq smtp-read-point (point-min))
96 (setq process (open-network-stream "SMTP"
98 smtp-server smtp-service))
99 (or process (throw 'done nil))
101 (set-process-filter process 'smtp-process-filter)
104 (setq response (smtp-read-response process))
105 (if (or (null (car response))
106 (not (integerp (car response)))
107 (>= (car response) 400))
108 (throw 'done (car (cdr response))))
111 (smtp-send-command process
112 (format "EHLO %s" (smtp-make-fqdn)))
113 (setq response (smtp-read-response process))
114 (if (or (null (car response))
115 (not (integerp (car response)))
116 (>= (car response) 400))
119 (smtp-send-command process
120 (format "HELO %s" (smtp-make-fqdn)))
121 (setq response (smtp-read-response process))
122 (if (or (null (car response))
123 (not (integerp (car response)))
124 (>= (car response) 400))
125 (throw 'done (car (cdr response)))))
126 (let ((extension-lines (cdr (cdr response))))
127 (while extension-lines
128 (push (intern (downcase (substring (car extension-lines) 4)))
130 (setq extension-lines (cdr extension-lines)))))
132 ;; ONEX --- One message transaction only (sendmail extension?)
133 (if (or (memq 'onex extensions)
134 (memq 'xone extensions))
136 (smtp-send-command process "ONEX")
137 (setq response (smtp-read-response process))
138 (if (or (null (car response))
139 (not (integerp (car response)))
140 (>= (car response) 400))
141 (throw 'done (car (cdr response))))))
143 ;; VERB --- Verbose (sendmail extension?)
144 (if (and smtp-debug-info
145 (or (memq 'verb extensions)
146 (memq 'xvrb extensions)))
148 (smtp-send-command process "VERB")
149 (setq response (smtp-read-response process))
150 (if (or (null (car response))
151 (not (integerp (car response)))
152 (>= (car response) 400))
153 (throw 'done (car (cdr response))))))
155 ;; XUSR --- Initial (user) submission (sendmail extension?)
156 (if (memq 'xusr extensions)
158 (smtp-send-command process "XUSR")
159 (setq response (smtp-read-response process))
160 (if (or (null (car response))
161 (not (integerp (car response)))
162 (>= (car response) 400))
163 (throw 'done (car (cdr response))))))
165 ;; MAIL FROM:<sender>
168 (format "MAIL FROM:<%s>%s%s"
170 ;; SIZE --- Message Size Declaration (RFC1870)
171 (if (memq 'size extensions)
174 (set-buffer smtp-text-buffer)
175 (+ (- (point-max) (point-min))
176 ;; Add one byte for each change-of-line
177 ;; because or CR-LF representation:
178 (count-lines (point-min) (point-max))
179 ;; For some reason, an empty line is
180 ;; added to the message. Maybe this
181 ;; is a bug, but it can't hurt to add
182 ;; those two bytes anyway:
185 ;; 8BITMIME --- 8bit-MIMEtransport (RFC1652)
186 (if (and (memq '8bitmime extensions)
190 (setq response (smtp-read-response process))
191 (if (or (null (car response))
192 (not (integerp (car response)))
193 (>= (car response) 400))
194 (throw 'done (car (cdr response))))
196 ;; RCPT TO:<recipient>
198 (smtp-send-command process
199 (format "RCPT TO:<%s>" (car recipients)))
200 (setq recipients (cdr recipients))
201 (setq response (smtp-read-response process))
202 (if (or (null (car response))
203 (not (integerp (car response)))
204 (>= (car response) 400))
205 (throw 'done (car (cdr response)))))
208 (smtp-send-command process "DATA")
209 (setq response (smtp-read-response process))
210 (if (or (null (car response))
211 (not (integerp (car response)))
212 (>= (car response) 400))
213 (throw 'done (car (cdr response))))
216 (smtp-send-data process smtp-text-buffer)
219 (smtp-send-command process ".")
220 (setq response (smtp-read-response process))
221 (if (or (null (car response))
222 (not (integerp (car response)))
223 (>= (car response) 400))
224 (throw 'done (car (cdr response))))
229 (eq (process-status process) 'open))
232 (smtp-send-command process "QUIT")
233 (smtp-read-response process)
234 (delete-process process)))))))
236 (defun smtp-process-filter (process output)
238 (set-buffer (process-buffer process))
239 (goto-char (point-max))
242 (defun smtp-read-response (process)
243 (let ((case-fold-search nil)
244 (response-strings nil)
245 (response-continue t)
246 (return-value '(nil ()))
249 (while response-continue
250 (goto-char smtp-read-point)
251 (while (not (search-forward "\r\n" nil t))
252 (accept-process-output process)
253 (goto-char smtp-read-point))
255 (setq match-end (point))
256 (setq response-strings
257 (cons (buffer-substring smtp-read-point (- match-end 2))
260 (goto-char smtp-read-point)
261 (if (looking-at "[0-9]+ ")
262 (let ((begin (match-beginning 0))
265 (message "%s" (car response-strings)))
267 (setq smtp-read-point match-end)
269 ;; ignore lines that start with "0"
270 (if (looking-at "0[0-9]+ ")
272 (setq response-continue nil)
275 (buffer-substring begin end))
276 (nreverse response-strings)))))
278 (if (looking-at "[0-9]+-")
279 (progn (if smtp-debug-info
280 (message "%s" (car response-strings)))
281 (setq smtp-read-point match-end)
282 (setq response-continue t))
284 (setq smtp-read-point match-end)
285 (setq response-continue nil)
287 (cons nil (nreverse response-strings)))))))
288 (setq smtp-read-point match-end)
291 (defun smtp-send-command (process command)
292 (goto-char (point-max))
293 (insert command "\r\n")
294 (setq smtp-read-point (point))
295 (process-send-string process command)
296 (process-send-string process "\r\n"))
298 (defun smtp-send-data-1 (process data)
299 (goto-char (point-max))
301 (insert data "\r\n"))
302 (setq smtp-read-point (point))
303 ;; Escape "." at start of a line.
304 (if (eq (string-to-char data) ?.)
305 (process-send-string process "."))
306 (process-send-string process data)
307 (process-send-string process "\r\n"))
309 (defun smtp-send-data (process buffer)
310 (let ((data-continue t)
317 (goto-char (point-min)))
323 (setq this-line (point))
325 (setq this-line-end (point))
326 (setq sending-data nil)
327 (setq sending-data (buffer-substring this-line this-line-end))
328 (if (or (/= (forward-line 1) 0) (eobp))
329 (setq data-continue nil)))
331 (smtp-send-data-1 process sending-data))))
333 (defun smtp-deduce-address-list (smtp-text-buffer header-start header-end)
334 "Get address list suitable for smtp RCPT TO:<address>."
335 (let ((case-fold-search t)
336 (simple-address-list "")
340 (smtp-address-buffer (generate-new-buffer " *smtp-mail*")))
344 (set-buffer smtp-address-buffer)
346 (insert (save-excursion
347 (set-buffer smtp-text-buffer)
348 (buffer-substring-no-properties header-start header-end)))
349 (goto-char (point-min))
350 ;; RESENT-* fields should stop processing of regular fields.
352 (if (re-search-forward "^RESENT-TO:" header-end t)
354 "^\\(RESENT-TO:\\|RESENT-CC:\\|RESENT-BCC:\\)")
355 (setq addr-regexp "^\\(TO:\\|CC:\\|BCC:\\)")))
357 (while (re-search-forward addr-regexp header-end t)
359 (setq this-line (match-beginning 0))
361 ;; get any continuation lines.
362 (while (and (looking-at "^[ \t]+") (< (point) header-end))
364 (setq this-line-end (point-marker))
365 (setq simple-address-list
366 (concat simple-address-list " "
367 (mail-strip-quoted-names
368 (buffer-substring this-line this-line-end)))))
371 (insert-string simple-address-list)
374 (subst-char-in-region (point-min) (point-max) 10 ? t)
376 (subst-char-in-region (point-min) (point-max) ?, ? t)
378 (subst-char-in-region (point-min) (point-max) 9 ? t)
380 (goto-char (point-min))
381 ;; tidyness in case hook is not robust when it looks at this
382 (while (re-search-forward "[ \t]+" header-end t) (replace-match " "))
384 (goto-char (point-min))
385 (let (recipient-address-list)
386 (while (re-search-forward " \\([^ ]+\\) " (point-max) t)
388 (setq recipient-address-list
389 (cons (buffer-substring (match-beginning 1) (match-end 1))
390 recipient-address-list)))
391 recipient-address-list))
392 (kill-buffer smtp-address-buffer))))
396 ;;; smtp.el ends here