* (smtp-server): Funcall `smtp-server' if it is a function.

(smtp-server): Make it can also be a function called from `smtp-via-smtp'
with arguments SENDER and RECIPIENTS.

diff --git a/ChangeLog b/ChangeLog
index 97a505a..0867221 100644 (file)
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,9 @@
+1999-04-09  Katsumi Yamaoka   <yamaoka@jpl.org>
+
+       * smtp.el (smtp-server): Funcall `smtp-server' if it is a function.
+       (smtp-server): Make it can also be a function called from
+       `smtp-via-smtp' with arguments SENDER and RECIPIENTS.
+
 1999-04-05  Shuhei KOBAYASHI  <shuhei@aqua.ocn.ne.jp>
 
        * FLIM-CFG: Make easier to install in VERSION_SPECIFIC_LISPDIR.

diff --git a/smtp.el b/smtp.el
index 79ef969..c2c9937 100644 (file)
--- a/smtp.el
+++ b/smtp.el
@@ -38,8 +38,10 @@
   :group 'smtp)
 
 (defcustom smtp-server (or (getenv "SMTPSERVER") smtp-default-server)
-  "*The name of the host running SMTP server."
-  :type '(choice (const nil) string)
+  "*The name of the host running SMTP server.  It can also be a function
+called from `smtp-via-smtp' with arguments SENDER and RECIPIENTS."
+  :type '(choice (string :tag "Name")
+                (function :tag "Function"))
   :group 'smtp)
 
 (defcustom smtp-service "smtp"
@@ -75,11 +77,14 @@ don't define this value."
       (error "Cannot generate valid FQDN. Set `smtp-local-domain' correctly.")))))
 
 (defun smtp-via-smtp (sender recipients smtp-text-buffer)
-  (let (process response extensions)
+  (let ((server (if (functionp smtp-server)
+                   (funcall smtp-server sender recipients)
+                 smtp-server))
+       process response extensions)
     (save-excursion
       (set-buffer
        (get-buffer-create
-       (format "*trace of SMTP session to %s*" smtp-server)))
+       (format "*trace of SMTP session to %s*" server)))
       (erase-buffer)
       (make-local-variable 'smtp-read-point)
       (setq smtp-read-point (point-min))
@@ -87,7 +92,7 @@ don't define this value."
       (unwind-protect
          (catch 'done
            (setq process (open-network-stream-as-binary
-                          "SMTP" (current-buffer) smtp-server smtp-service))
+                          "SMTP" (current-buffer) server smtp-service))
            (or process (throw 'done nil))
 
            (set-process-filter process 'smtp-process-filter)
@@ -121,7 +126,7 @@ don't define this value."
                        extensions)
                  (setq extension-lines (cdr extension-lines)))))
 
-            ;; ONEX --- One message transaction only (sendmail extension?)
+           ;; ONEX --- One message transaction only (sendmail extension?)
            (if (or (memq 'onex extensions)
                    (memq 'xone extensions))
                (progn
@@ -132,7 +137,7 @@ don't define this value."
                          (>= (car response) 400))
                      (throw 'done (car (cdr response))))))
 
-            ;; VERB --- Verbose (sendmail extension?)
+           ;; VERB --- Verbose (sendmail extension?)
            (if (and smtp-debug-info
                     (or (memq 'verb extensions)
                         (memq 'xvrb extensions)))
@@ -144,7 +149,7 @@ don't define this value."
                          (>= (car response) 400))
                      (throw 'done (car (cdr response))))))
 
-            ;; XUSR --- Initial (user) submission (sendmail extension?)
+           ;; XUSR --- Initial (user) submission (sendmail extension?)
            (if (memq 'xusr extensions)
                (progn
                  (smtp-send-command process "XUSR")
@@ -159,7 +164,7 @@ don't define this value."
             process
             (format "MAIL FROM:<%s>%s%s"
                     sender
-                     ;; SIZE --- Message Size Declaration (RFC1870)
+                    ;; SIZE --- Message Size Declaration (RFC1870)
                     (if (memq 'size extensions)
                         (format " SIZE=%d"
                                 (save-excursion
@@ -174,7 +179,7 @@ don't define this value."
                                      ;; those two bytes anyway:
                                      2)))
                       "")
-                     ;; 8BITMIME --- 8bit-MIMEtransport (RFC1652)
+                    ;; 8BITMIME --- 8bit-MIMEtransport (RFC1652)
                     (if (and (memq '8bitmime extensions)
                              smtp-use-8bitmime)
                         " BODY=8BITMIME"
@@ -184,7 +189,7 @@ don't define this value."
                    (not (integerp (car response)))
                    (>= (car response) 400))
                (throw 'done (car (cdr response))))
-       
+
            ;; RCPT TO:<recipient>
            (while recipients
              (smtp-send-command process
@@ -195,7 +200,7 @@ don't define this value."
                      (not (integerp (car response)))
                      (>= (car response) 400))
                  (throw 'done (car (cdr response)))))
-       
+
            ;; DATA
            (smtp-send-command process "DATA")
            (setq response (smtp-read-response process))