update.

[elisp/flim.git] / smtp.el

diff --git a/smtp.el b/smtp.el
index 25b5f72..fe511e9 100644 (file)
--- a/smtp.el
+++ b/smtp.el
@@ -1,6 +1,7 @@
 ;;; smtp.el --- basic functions to send mail with SMTP server
 
 ;;; smtp.el --- basic functions to send mail with SMTP server
 

-;; Copyright (C) 1995, 1996, 1998, 1999 Free Software Foundation, Inc.
+;; Copyright (C) 1995, 1996, 1998, 1999, 2000, 2001 ,2002, 2004
+;; Free Software Foundation, Inc.

 
 ;; Author: Tomoji Kagatani <kagatani@rbc.ncl.omron.co.jp>
 ;;     Simon Leinen <simon@switch.ch> (ESMTP support)
 
 ;; Author: Tomoji Kagatani <kagatani@rbc.ncl.omron.co.jp>
 ;;     Simon Leinen <simon@switch.ch> (ESMTP support)

@@ -22,12 +23,12 @@
 
 ;; You should have received a copy of the GNU General Public License
 ;; along with this program; see the file COPYING.  If not, write to the
 
 ;; You should have received a copy of the GNU General Public License
 ;; along with this program; see the file COPYING.  If not, write to the

-;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.

 
 
 ;;; Commentary:
 
 
 ;;; Commentary:

-;; 
+;;

 
 ;;; Code:
 
 
 ;;; Code:
 

@@ -35,6 +36,7 @@
 (require 'mail-utils)                  ; mail-strip-quoted-names
 (require 'sasl)
 (require 'luna)
 (require 'mail-utils)                  ; mail-strip-quoted-names
 (require 'sasl)
 (require 'luna)

+(require 'mel) ; binary-funcall

 
 (defgroup smtp nil
   "SMTP protocol for sending mail."
 
 (defgroup smtp nil
   "SMTP protocol for sending mail."

@@ -57,10 +59,16 @@ called from `smtp-via-smtp' with arguments SENDER and RECIPIENTS."
                 (function :tag "Function"))
   :group 'smtp)
 
                 (function :tag "Function"))
   :group 'smtp)
 

+(defcustom smtp-send-by-myself nil
+  "If non-nil, smtp.el send a mail by myself without smtp-server.
+This option requires \"dig.el\"."
+  :type 'boolean
+  :group 'smtp)
+

 (defcustom smtp-service "smtp"
   "SMTP service port number.  \"smtp\" or 25."
   :type '(choice (integer :tag "25" 25)
 (defcustom smtp-service "smtp"
   "SMTP service port number.  \"smtp\" or 25."
   :type '(choice (integer :tag "25" 25)

-                 (string :tag "smtp" "smtp"))
+                (string :tag "smtp" "smtp"))

   :group 'smtp)
 
 (defcustom smtp-local-domain nil
   :group 'smtp)
 
 (defcustom smtp-local-domain nil

@@ -90,6 +98,19 @@ don't define this value."
   :type 'boolean
   :group 'smtp-extensions)
 
   :type 'boolean
   :group 'smtp-extensions)
 

+(defcustom smtp-use-starttls-ignore-error nil
+  "If non-nil, do not use STARTTLS if STARTTLS is not available."
+  :type 'boolean
+  :group 'smtp-extensions)
+
+(defcustom smtp-starttls-program "starttls"
+  "The program to run in a subprocess to open an TLSv1 connection."
+  :group 'smtp-extensions)
+
+(defcustom smtp-starttls-extra-args nil
+  "Extra arguments to `starttls-program'"
+  :group 'smtp-extensions)
+

 (defcustom smtp-use-sasl nil
   "If non-nil, use SMTP Authentication (RFC2554) if available."
   :type 'boolean
 (defcustom smtp-use-sasl nil
   "If non-nil, use SMTP Authentication (RFC2554) if available."
   :type 'boolean

@@ -110,10 +131,30 @@ don't define this value."
   :type '(repeat string)
   :group 'smtp-extensions)
 
   :type '(repeat string)
   :group 'smtp-extensions)
 

+(defcustom smtp-debug nil
+  "*If non-nil, smtp debug info printout into messages."
+  :type 'boolean
+  :group 'smtp)
+

 (defvar sasl-mechanisms)
 
 (defvar sasl-mechanisms)
 

-(autoload 'binary-open-network-stream "raw-io")
-(defvar smtp-open-connection-function #'binary-open-network-stream)
+;;;###autoload
+(defvar smtp-open-connection-function #'open-network-stream
+  "*Function used for connecting to a SMTP server.
+The function will be called with the same four arguments as
+`open-network-stream' and should return a process object.
+Here is an example:
+
+\(setq smtp-open-connection-function
+      #'(lambda (name buffer host service)
+         (let ((process-connection-type nil))
+           (start-process name buffer \"ssh\" \"-C\" host
+                          \"nc\" host service))))
+
+It connects to a SMTP server using \"ssh\" before actually connecting
+to the SMTP port.  Where the command \"nc\" is the netcat executable;
+see http://www.atstake.com/research/tools/index.html#network_utilities
+for details.")

 
 (defvar smtp-read-point nil)
 
 
 (defvar smtp-read-point nil)
 

@@ -235,8 +276,8 @@ Return a newly allocated connection-object.
 BUFFER is the buffer to associate with the connection.  SERVER is name
 of the host to connect to.  SERVICE is name of the service desired."
   (let ((process
 BUFFER is the buffer to associate with the connection.  SERVER is name
 of the host to connect to.  SERVICE is name of the service desired."
   (let ((process

-        (funcall smtp-open-connection-function
-                 "SMTP" buffer  server service))
+        (binary-funcall smtp-open-connection-function
+                        "SMTP" buffer server service))

        connection)
     (when process
       (setq connection (smtp-make-connection process server service))
        connection)
     (when process
       (setq connection (smtp-make-connection process server service))

@@ -246,8 +287,54 @@ of the host to connect to.  SERVICE is name of the service desired."
                  smtp-connection-alist))
       connection)))
 
                  smtp-connection-alist))
       connection)))
 

+(eval-and-compile
+  (autoload 'dig-invoke "dig")
+  (autoload 'dig-extract-rr "dig"))
+
+(defun smtp-find-mx (domain &optional doerror)
+  (let (server)
+    ;; dig.el resolves only primally MX.
+    (cond ((setq server (smtp-dig domain "MX"))
+          (progn (string-match " \\([^ ]*\\)$" server)
+                 (match-string 1 server)))
+         ((smtp-dig domain "A")
+           domain)
+         (t
+          (if doerror
+               (error (format "SMTP cannot resolve %s" domain)))))))
+
+(defun smtp-dig (domain type)
+  (let (dig-buf)
+    (set-buffer
+     (setq dig-buf (dig-invoke domain type)))
+    (prog1
+       (dig-extract-rr domain type)
+      (kill-buffer dig-buf))))
+
+(defun smtp-find-server (recipients)
+  (save-excursion
+    (let ((rec
+          (mapcar (lambda (recipient)
+                    (let (server)
+                      (if (and (string-match "@\\([^\t\n ]*\\)" recipient)
+                               (setq server
+                                     (smtp-find-mx
+                                      (match-string 1 recipient))))
+                          (cons server (list recipient))
+                        (error (format "cannot find server for %s." recipient)))))
+                  recipients))
+         ret rets rlist)
+      (while (setq rets (pop rec))
+       (if (setq ret (assoc (car rets) rec))
+           (setcdr ret
+                   (append (cdr ret) (cdr rets)))
+         (setq rlist
+               (append rlist (list rets)))))
+      rlist)))
+

 ;;;###autoload
 (defun smtp-via-smtp (sender recipients buffer)
 ;;;###autoload
 (defun smtp-via-smtp (sender recipients buffer)

+  "Like `smtp-send-buffer', but sucks in any errors."

   (condition-case nil
       (progn
        (smtp-send-buffer sender recipients buffer)
   (condition-case nil
       (progn
        (smtp-send-buffer sender recipients buffer)

@@ -258,27 +345,36 @@ of the host to connect to.  SERVICE is name of the service desired."
 
 ;;;###autoload
 (defun smtp-send-buffer (sender recipients buffer)
 
 ;;;###autoload
 (defun smtp-send-buffer (sender recipients buffer)

-  (let ((server
-        (if (functionp smtp-server)
-            (funcall smtp-server sender recipients)
-          smtp-server))
-       (package
-        (smtp-make-package sender recipients buffer))
-       (smtp-open-connection-function
-        (if smtp-use-starttls
-            #'starttls-open-stream
-          smtp-open-connection-function)))
-    (save-excursion
-      (set-buffer
-       (get-buffer-create
-       (format "*trace of SMTP session to %s*" server)))
-      (erase-buffer)
-      (buffer-disable-undo)
-      (unless (smtp-find-connection (current-buffer))
-       (smtp-open-connection (current-buffer) server smtp-service))
-      (make-local-variable 'smtp-read-point)
-      (setq smtp-read-point (point-min))
-      (funcall smtp-submit-package-function package))))
+  "Send a message.
+SENDER is an envelope sender address.
+RECIPIENTS is a list of envelope recipient addresses.
+BUFFER may be a buffer or a buffer name which contains mail message."
+  (if smtp-send-by-myself
+      (smtp-send-buffer-by-myself sender recipients buffer)
+    (let* ((server
+           (if (functionp smtp-server)
+               (funcall smtp-server sender recipients)
+             (or smtp-server
+                 (error "`smtp-server' not defined"))))
+          (package
+           (smtp-make-package sender recipients buffer))
+          (starttls-program smtp-starttls-program)
+          (starttls-extra-args smtp-starttls-extra-args)
+          (smtp-open-connection-function
+           (if smtp-use-starttls
+               #'starttls-open-stream
+             smtp-open-connection-function)))
+      (save-excursion
+       (set-buffer
+        (get-buffer-create
+         (format "*trace of SMTP session to %s*" server)))
+       (erase-buffer)
+       (buffer-disable-undo)
+       (unless (smtp-find-connection (current-buffer))
+         (smtp-open-connection (current-buffer) server smtp-service))
+       (make-local-variable 'smtp-read-point)
+       (setq smtp-read-point (point-min))
+       (funcall smtp-submit-package-function package)))))

 
 (defun smtp-submit-package (package)
   (unwind-protect
 
 (defun smtp-submit-package (package)
   (unwind-protect

@@ -289,17 +385,62 @@ of the host to connect to.  SERVICE is name of the service desired."
          (smtp-response-error
           (smtp-primitive-helo package)))
        (if smtp-use-starttls
          (smtp-response-error
           (smtp-primitive-helo package)))
        (if smtp-use-starttls

-           (smtp-primitive-starttls package))
+           (if (assq 'starttls
+                     (smtp-connection-extensions-internal
+                      (smtp-find-connection (current-buffer))))
+               (progn
+                 (smtp-primitive-starttls package)
+                 (smtp-primitive-ehlo package))
+             (unless smtp-use-starttls-ignore-error
+               (error "STARTTLS is not supported on this server"))))

        (if smtp-use-sasl
            (smtp-primitive-auth package))
        (smtp-primitive-mailfrom package)
        (smtp-primitive-rcptto package)
        (smtp-primitive-data package))
     (let ((connection (smtp-find-connection (current-buffer))))
        (if smtp-use-sasl
            (smtp-primitive-auth package))
        (smtp-primitive-mailfrom package)
        (smtp-primitive-rcptto package)
        (smtp-primitive-data package))
     (let ((connection (smtp-find-connection (current-buffer))))

-      (when (smtp-connection-opened connection)
-       (smtp-primitive-quit package)
+      (when (and connection (smtp-connection-opened connection))
+       (condition-case nil
+           (smtp-primitive-quit package)
+         (smtp-error))

        (smtp-close-connection connection)))))
 
        (smtp-close-connection connection)))))
 

+(defun smtp-send-buffer-by-myself (sender recipients buffer)
+  "Send a message by myself.
+SENDER is an envelope sender address.
+RECIPIENTS is a list of envelope recipient addresses.
+BUFFER may be a buffer or a buffer name which contains mail message."
+  (let ((servers
+        (smtp-find-server recipients))
+       (smtp-open-connection-function
+        (if smtp-use-starttls
+            #'starttls-open-stream
+          smtp-open-connection-function))
+       server package)
+      (while (car servers)
+       (setq server (caar servers))
+       (setq recipients (cdar servers))
+       (if (not (and server recipients))
+           ;; MAILER-DAEMON is required. :)
+           (error (format "Cannot send <%s>"
+                          (mapconcat 'concat recipients ">,<"))))
+       (setq package
+             (smtp-make-package sender recipients buffer))
+       (save-excursion
+         (set-buffer
+          (get-buffer-create
+           (format "*trace of SMTP session to %s*" server)))
+         (erase-buffer)
+         (buffer-disable-undo)
+         (unless (smtp-find-connection (current-buffer))
+           (smtp-open-connection (current-buffer) server smtp-service))
+         (make-local-variable 'smtp-read-point)
+         (setq smtp-read-point (point-min))
+         (let ((smtp-use-sasl nil)
+               (smtp-use-starttls-ignore-error t))
+           (funcall smtp-submit-package-function package)))
+       (setq servers (cdr servers)))))
+

 ;;; @ hook methods for `smtp-submit-package'
 ;;;
 
 ;;; @ hook methods for `smtp-submit-package'
 ;;;
 

@@ -414,7 +555,7 @@ of the host to connect to.  SERVICE is name of the service desired."
     ;; SIZE --- Message Size Declaration (RFC1870)
     (if (and smtp-use-size
             (assq 'size extensions))
     ;; SIZE --- Message Size Declaration (RFC1870)
     (if (and smtp-use-size
             (assq 'size extensions))

-       (setq extension (format "SIZE=%d" (smtp-package-buffer-internal-size package))))
+       (setq extension (format " SIZE=%d" (smtp-package-buffer-internal-size package))))

     ;; 8BITMIME --- 8bit-MIMEtransport (RFC1652)
     (if (and smtp-use-8bitmime
             (assq '8bitmime extensions))
     ;; 8BITMIME --- 8bit-MIMEtransport (RFC1652)
     (if (and smtp-use-8bitmime
             (assq '8bitmime extensions))

@@ -422,7 +563,7 @@ of the host to connect to.  SERVICE is name of the service desired."
     (smtp-send-command
      connection
      (if extension
     (smtp-send-command
      connection
      (if extension

-        (format "MAIL FROM:<%s> %s" sender extension)
+        (format "MAIL FROM:<%s>%s" sender extension)

        (format "MAIL FROM:<%s>" sender)))
     (setq response (smtp-read-response connection))
     (if (/= (car response) 250)
        (format "MAIL FROM:<%s>" sender)))
     (setq response (smtp-read-response connection))
     (if (/= (car response) 250)

@@ -494,24 +635,31 @@ of the host to connect to.  SERVICE is name of the service desired."
        response)
     (while response-continue
       (goto-char smtp-read-point)
        response)
     (while response-continue
       (goto-char smtp-read-point)

-      (while (not (search-forward "\r\n" nil t))
+      (while (not (re-search-forward "\r?\n" nil t))
+       (unless (smtp-connection-opened connection)
+         (signal 'smtp-error "Connection closed"))

        (accept-process-output (smtp-connection-process-internal connection))
        (goto-char smtp-read-point))
        (accept-process-output (smtp-connection-process-internal connection))
        (goto-char smtp-read-point))

-      (if decoder
-         (let ((string (buffer-substring smtp-read-point (- (point) 2))))
-           (delete-region smtp-read-point (point))
-           (insert (funcall decoder string) "\r\n")))
-      (setq response
-           (nconc response
-                  (list (buffer-substring
-                         (+ 4 smtp-read-point)
-                         (- (point) 2)))))
-      (goto-char
-       (prog1 smtp-read-point
-        (setq smtp-read-point (point))))
-      (if (looking-at "[1-5][0-9][0-9] ")
-         (setq response (cons (read (point-marker)) response)
-               response-continue nil)))
+      (let ((bol smtp-read-point)
+           (eol (match-beginning 0)))
+       (when decoder
+         (let ((string (buffer-substring bol eol)))
+           (delete-region bol (point))
+           (insert (funcall decoder string))
+           (setq eol (point))
+           (insert "\r\n")))
+       (setq smtp-read-point (point))
+       (goto-char bol)
+       (cond
+        ((looking-at "[1-5][0-9][0-9]\\([ -]\\)")
+         (setq response
+               (nconc response
+                      (list (buffer-substring (match-end 0) eol))))
+         (when (string= (match-string 1) " ")
+           (setq response (cons (read (point-marker)) response)
+                 response-continue nil)))
+        (smtp-debug
+         (message "Invalid response: %s" (buffer-substring bol eol))))))

     response))
 
 (defun smtp-send-command (connection command)
     response))
 
 (defun smtp-send-command (connection command)

@@ -579,9 +727,7 @@ of the host to connect to.  SERVICE is name of the service desired."
                          (mail-strip-quoted-names
                           (buffer-substring this-line this-line-end)))))
          (erase-buffer)
                          (mail-strip-quoted-names
                           (buffer-substring this-line this-line-end)))))
          (erase-buffer)

-         (insert-string " ")
-         (insert-string simple-address-list)
-         (insert-string "\n")
+         (insert " " simple-address-list "\n")

          ;; newline --> blank
          (subst-char-in-region (point-min) (point-max) 10 ?  t)
          ;; comma   --> blank
          ;; newline --> blank
          (subst-char-in-region (point-min) (point-max) 10 ?  t)
          ;; comma   --> blank