From: yamaoka <yamaoka>
Date: Fri, 9 Apr 1999 05:55:57 +0000 (+0000)
Subject: * (smtp-server): Funcall `smtp-server' if it is a function.
X-Git-Tag: flim-1_12_6~14
X-Git-Url: http://git.chise.org/gitweb/?a=commitdiff_plain;h=d1b31ca02a3234ed51aadcb16f355bf566abc841;p=elisp%2Fflim.git

* (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
--- 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
--- 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))