This commit was manufactured by cvs2svn to create tag 'gnus-6_2_5'.
[elisp/gnus.git-] / lisp / smtpmail.el
1 ;;; smtpmail.el --- simple SMTP protocol (RFC 821) for sending mail
2
3 ;; Copyright (C) 1995, 1996 Free Software Foundation, Inc.
4
5 ;; Author: Tomoji Kagatani <kagatani@rbc.ncl.omron.co.jp>
6 ;; Maintainer: Brian D. Carlstrom <bdc@ai.mit.edu>
7 ;; ESMTP support: Simon Leinen <simon@switch.ch>
8 ;; Keywords: mail
9
10 ;; This file is part of GNU Emacs.
11
12 ;; GNU Emacs is free software; you can redistribute it and/or modify
13 ;; it under the terms of the GNU General Public License as published by
14 ;; the Free Software Foundation; either version 2, or (at your option)
15 ;; any later version.
16
17 ;; GNU Emacs is distributed in the hope that it will be useful,
18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
20 ;; GNU General Public License for more details.
21
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.
26
27 ;;; Commentary:
28
29 ;; Send Mail to smtp host from smtpmail temp buffer.
30
31 ;; Please add these lines in your .emacs(_emacs).
32 ;;
33 ;;(setq send-mail-function 'smtpmail-send-it)
34 ;;(setq smtp-default-server "YOUR SMTP HOST")
35 ;;(setq smtp-service "smtp")
36 ;;(setq smtp-local-domain "YOUR DOMAIN NAME")
37 ;;(setq smtp-debug-info t)
38 ;;(autoload 'smtpmail-send-it "smtpmail")
39 ;;(setq user-full-name "YOUR NAME HERE")
40
41 ;; To queue mail, set smtpmail-queue-mail to t and use 
42 ;; smtpmail-send-queued-mail to send.
43
44
45 ;;; Code:
46
47 (require 'smtp)
48 (require 'sendmail)
49 (require 'time-stamp)
50
51 ;;;
52
53 (defcustom smtpmail-queue-mail nil 
54   "*Specify if mail is queued (if t) or sent immediately (if nil).
55 If queued, it is stored in the directory `smtpmail-queue-dir'
56 and sent with `smtpmail-send-queued-mail'."
57   :type 'boolean
58   :group 'smtp)
59
60 (defcustom smtpmail-queue-dir "~/Mail/queued-mail/"
61   "*Directory where `smtpmail.el' stores queued mail."
62   :type 'directory
63   :group 'smtp)
64
65 (defvar smtpmail-queue-index-file "index"
66   "File name of queued mail index,
67 This is relative to `smtpmail-queue-dir'.")
68
69 (defvar smtpmail-queue-index (concat smtpmail-queue-dir
70                                      smtpmail-queue-index-file))
71
72 (defvar smtpmail-recipient-address-list nil)
73
74
75 ;;;
76 ;;;
77 ;;;
78
79 (defun smtpmail-send-it ()
80   (require 'mail-utils)
81   (let ((errbuf (if mail-interactive
82                     (generate-new-buffer " smtpmail errors")
83                   0))
84         (tembuf (generate-new-buffer " smtpmail temp"))
85         (case-fold-search nil)
86         resend-to-addresses
87         delimline
88         (mailbuf (current-buffer)))
89     (unwind-protect
90         (save-excursion
91           (set-buffer tembuf)
92           (erase-buffer)
93           (insert-buffer-substring mailbuf)
94           (goto-char (point-max))
95           ;; require one newline at the end.
96           (or (= (preceding-char) ?\n)
97               (insert ?\n))
98           ;; Change header-delimiter to be what sendmail expects.
99           (goto-char (point-min))
100           (re-search-forward
101             (concat "^" (regexp-quote mail-header-separator) "\n"))
102           (replace-match "\n")
103           (backward-char 1)
104           (setq delimline (point-marker))
105 ;;        (sendmail-synch-aliases)
106           (if mail-aliases
107               (expand-mail-aliases (point-min) delimline))
108           (goto-char (point-min))
109           ;; ignore any blank lines in the header
110           (while (and (re-search-forward "\n\n\n*" delimline t)
111                       (< (point) delimline))
112             (replace-match "\n"))
113           (let ((case-fold-search t))
114             (goto-char (point-min))
115             (goto-char (point-min))
116             (while (re-search-forward "^Resent-to:" delimline t)
117               (setq resend-to-addresses
118                     (save-restriction
119                       (narrow-to-region (point)
120                                         (save-excursion
121                                           (end-of-line)
122                                           (point)))
123                       (append (mail-parse-comma-list)
124                               resend-to-addresses))))
125 ;;; Apparently this causes a duplicate Sender.
126 ;;;         ;; If the From is different than current user, insert Sender.
127 ;;;         (goto-char (point-min))
128 ;;;         (and (re-search-forward "^From:"  delimline t)
129 ;;;              (progn
130 ;;;                (require 'mail-utils)
131 ;;;                (not (string-equal
132 ;;;                      (mail-strip-quoted-names
133 ;;;                       (save-restriction
134 ;;;                         (narrow-to-region (point-min) delimline)
135 ;;;                         (mail-fetch-field "From")))
136 ;;;                      (user-login-name))))
137 ;;;              (progn
138 ;;;                (forward-line 1)
139 ;;;                (insert "Sender: " (user-login-name) "\n")))
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             ;; Put the "From:" field in unless for some odd reason
145             ;; they put one in themselves.
146             (goto-char (point-min))
147             (if (not (re-search-forward "^From:" delimline t))
148                 (let* ((login user-mail-address)
149                        (fullname (user-full-name)))
150                   (cond ((eq mail-from-style 'angles)
151                          (insert "From: " fullname)
152                          (let ((fullname-start (+ (point-min) 6))
153                                (fullname-end (point-marker)))
154                            (goto-char fullname-start)
155                            ;; Look for a character that cannot appear unquoted
156                            ;; according to RFC 822.
157                            (if (re-search-forward "[^- !#-'*+/-9=?A-Z^-~]"
158                                                   fullname-end 1)
159                                (progn
160                                  ;; Quote fullname, escaping specials.
161                                  (goto-char fullname-start)
162                                  (insert "\"")
163                                  (while (re-search-forward "[\"\\]"
164                                                            fullname-end 1)
165                                    (replace-match "\\\\\\&" t))
166                                  (insert "\""))))
167                          (insert " <" login ">\n"))
168                         ((eq mail-from-style 'parens)
169                          (insert "From: " login " (")
170                          (let ((fullname-start (point)))
171                            (insert fullname)
172                            (let ((fullname-end (point-marker)))
173                              (goto-char fullname-start)
174                              ;; RFC 822 says \ and nonmatching parentheses
175                              ;; must be escaped in comments.
176                              ;; Escape every instance of ()\ ...
177                              (while (re-search-forward "[()\\]" fullname-end 1)
178                                (replace-match "\\\\\\&" t))
179                              ;; ... then undo escaping of matching parentheses,
180                              ;; including matching nested parentheses.
181                              (goto-char fullname-start)
182                              (while (re-search-forward 
183                                      "\\(\\=\\|[^\\]\\(\\\\\\\\\\)*\\)\\\\(\\(\\([^\\]\\|\\\\\\\\\\)*\\)\\\\)"
184                                      fullname-end 1)
185                                (replace-match "\\1(\\3)" t)
186                                (goto-char fullname-start))))
187                          (insert ")\n"))
188                         ((null mail-from-style)
189                          (insert "From: " login "\n")))))
190             ;; Insert an extra newline if we need it to work around
191             ;; Sun's bug that swallows newlines.
192             (goto-char (1+ delimline))
193             (if (eval mail-mailer-swallows-blank-line)
194                 (newline))
195             ;; Find and handle any FCC fields.
196             (goto-char (point-min))
197             (if (re-search-forward "^FCC:" delimline t)
198                 (mail-do-fcc delimline))
199             (if mail-interactive
200                 (save-excursion
201                   (set-buffer errbuf)
202                   (erase-buffer))))
203           ;;
204           ;;
205           ;;
206           (setq smtpmail-recipient-address-list
207                 (or resend-to-addresses
208                     (smtp-deduce-address-list tembuf (point-min) delimline)))
209
210           (smtp-do-bcc delimline)
211           ; Send or queue
212           (if (not smtpmail-queue-mail)
213               (if smtpmail-recipient-address-list
214                   (if (not (smtp-via-smtp
215                             smtpmail-recipient-address-list tembuf))
216                       (error "Sending failed; SMTP protocol error"))
217                 (error "Sending failed; no recipients"))
218             (let* ((file-data (concat 
219                                smtpmail-queue-dir
220                                (time-stamp-strftime 
221                                 "%02y%02m%02d-%02H%02M%02S")))
222                    (file-elisp (concat file-data ".el"))
223                    (buffer-data (create-file-buffer file-data))
224                    (buffer-elisp (create-file-buffer file-elisp))
225                    (buffer-scratch "*queue-mail*"))
226               (save-excursion
227                 (set-buffer buffer-data)
228                 (erase-buffer)
229                 (insert-buffer tembuf)
230                 (write-file file-data)
231                 (set-buffer buffer-elisp)
232                 (erase-buffer)
233                 (insert (concat
234                          "(setq smtpmail-recipient-address-list '"
235                          (prin1-to-string smtpmail-recipient-address-list)
236                          ")\n"))                    
237                 (write-file file-elisp)
238                 (set-buffer (generate-new-buffer buffer-scratch))
239                 (insert (concat file-data "\n"))
240                 (append-to-file (point-min) 
241                                 (point-max) 
242                                 smtpmail-queue-index)
243                 )
244               (kill-buffer buffer-scratch)
245               (kill-buffer buffer-data)
246               (kill-buffer buffer-elisp))))
247       (kill-buffer tembuf)
248       (if (bufferp errbuf)
249           (kill-buffer errbuf)))))
250
251 (defun smtpmail-send-queued-mail ()
252   "Send mail that was queued as a result of setting `smtpmail-queue-mail'."
253   (interactive)
254   ;;; Get index, get first mail, send it, get second mail, etc...
255   (let ((buffer-index (find-file-noselect smtpmail-queue-index))
256         (file-msg "")
257         (tembuf nil))
258     (save-excursion
259       (set-buffer buffer-index)
260       (beginning-of-buffer)
261       (while (not (eobp))
262         (setq file-msg (buffer-substring (point) (save-excursion
263                                                    (end-of-line)
264                                                    (point))))
265         (load file-msg)
266         (setq tembuf (find-file-noselect file-msg))
267         (if smtpmail-recipient-address-list
268             (if (not (smtp-via-smtp smtpmail-recipient-address-list tembuf))
269                 (error "Sending failed; SMTP protocol error"))
270           (error "Sending failed; no recipients"))  
271         (delete-file file-msg)
272         (delete-file (concat file-msg ".el"))
273         (kill-buffer tembuf)
274         (kill-line 1))      
275       (set-buffer buffer-index)
276       (save-buffer smtpmail-queue-index)
277       (kill-buffer buffer-index)
278       )))
279
280
281 ;;;
282
283 (provide 'smtpmail)
284
285 ;;; smtpmail.el ends here