From: ueno <ueno>
Date: Wed, 1 Nov 2000 02:28:30 +0000 (+0000)
Subject: * smtp.el: Add autoload settings for `starttls-open-stream' and
X-Git-Tag: deisui-1_14_0-1~26
X-Git-Url: http://git.chise.org/gitweb/?a=commitdiff_plain;h=37a1a1c71878f3d08a212b49f914ca98b4ae6380;p=elisp%2Fflim.git

* smtp.el: Add autoload settings for `starttls-open-stream' and
`starttls-negotiate'.
(smtp-connection-set-extensions-internal): New macro.
(smtp-connection-extensions-internal): New macro.
(smtp-make-connection): Set the `extension' slot to nil.
(smtp-primitive-ehlo): New function.
(smtp-submit-package): Rename from `smtp-commit'.
(smtp-submit-package-function): Rename from `smtp-commit-function'.
(smtp-primitive-starttls): New function.
(smtp-extensions): New group.
(smtp-use-8bitmime): New variable.
(smtp-use-size): New variable.
(smtp-use-starttls): New variable.
(smtp-via-smtp): Bind `smtp-open-connection-function'.
---

diff --git a/ChangeLog b/ChangeLog
index d2b285c..f890625 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,20 @@
+2000-11-01   Daiki Ueno  <ueno@unixuser.org>
+
+	* smtp.el: Add autoload settings for `starttls-open-stream' and
+	`starttls-negotiate'.
+	(smtp-connection-set-extensions-internal): New macro.
+	(smtp-connection-extensions-internal): New macro.
+	(smtp-make-connection): Set the `extension' slot to nil.
+	(smtp-primitive-ehlo): New function.
+	(smtp-submit-package): Rename from `smtp-commit'.
+	(smtp-submit-package-function): Rename from `smtp-commit-function'.
+	(smtp-primitive-starttls): New function.
+	(smtp-extensions): New group.
+	(smtp-use-8bitmime): New variable.
+	(smtp-use-size): New variable.
+	(smtp-use-starttls): New variable.
+	(smtp-via-smtp): Bind `smtp-open-connection-function'.
+
 2000-10-31   Daiki Ueno  <ueno@unixuser.org>
 
 	* smtp.el: New implementation; don't use `tram.el' and `luna.el'.
diff --git a/smtp.el b/smtp.el
index ab2a624..136e030 100644
--- a/smtp.el
+++ b/smtp.el
@@ -35,6 +35,10 @@
   "SMTP protocol for sending mail."
   :group 'mail)
 
+(defgroup smtp-extensions nil
+  "SMTP service extensions (RFC1869)."
+  :group 'smtp)
+
 (defcustom smtp-default-server nil
   "Specify default SMTP server."
   :type '(choice (const nil) string)
@@ -65,12 +69,29 @@ don't define this value."
   :type '(choice (const nil) string)
   :group 'smtp)
 
-(defvar smtp-open-connection-function (function open-network-stream))
+(defcustom smtp-use-8bitmime t
+  "If non-nil, use ESMTP 8BITMIME (RFC1652) if available."
+  :type 'boolean
+  :group 'smtp-extensions)
+
+(defcustom smtp-use-size t
+  "If non-nil, use ESMTP SIZE (RFC1870) if available."
+  :type 'boolean
+  :group 'smtp-extensions)
+
+(defcustom smtp-use-starttls nil
+  "If non-nil, use STARTTLS (RFC2595) if available."
+  :type 'boolean
+  :group 'smtp-extensions)
+
+(defvar smtp-open-connection-function #'open-network-stream)
 
 (defvar smtp-read-point nil)
 
 (defvar smtp-connection-alist nil)
 
+(defvar smtp-submit-package-function #'smtp-submit-package)
+
 ;;; @ SMTP package structure
 ;;; A package contains a mail message, an envelope sender address,
 ;;; and one or more envelope recipient addresses.  In ESMTP model,
@@ -89,6 +110,24 @@ don't define this value."
 (defmacro smtp-make-package (sender recipients buffer)
   `(vector ,sender ,recipients ,buffer))
 
+(defun smtp-package-buffer-size (package)
+  (save-excursion
+    (set-buffer (smtp-package-buffer-internal package))
+    (let ((size
+	   (+ (buffer-size)
+	      ;; Add one byte for each change-of-line
+	      ;; because or CR-LF representation:
+	      (count-lines (point-min) (point-max))
+	      ;; For some reason, an empty line is
+	      ;; added to the message.	Maybe this
+	      ;; is a bug, but it can't hurt to add
+	      ;; those two bytes anyway:
+	      2)))
+      (goto-char (point-min))
+      (while (re-search-forward "^\\." nil t)
+	(setq size (1+ size)))
+      size)))
+
 ;;; @ SMTP connection structure
 ;;; We should take care of a emulation for another network stream.
 ;;; They are likely to be implemented with a external program and the function
@@ -103,8 +142,14 @@ don't define this value."
 (defmacro smtp-connection-service-internal (connection)
   `(aref ,connection 2))
 
+(defmacro smtp-connection-extensions-internal (connection)
+  `(aref ,connection 3))
+
+(defmacro smtp-connection-set-extensions-internal (connection extensions)
+  `(aset ,connection 3 ,extensions))
+
 (defmacro smtp-make-connection (process server service)
-  `(vector ,process ,server ,service))
+  `(vector ,process ,server ,service nil))
 
 (defun smtp-connection-opened (connection)
   "Say whether the CONNECTION to server has been opened."
@@ -143,6 +188,10 @@ or `smtp-local-domain' correctly."))))))
 	      (delq entry smtp-connection-alist))
 	nil))))
 
+(eval-and-compile
+  (autoload 'starttls-open-stream "starttls")
+  (autoload 'starttls-negotiate "starttls"))
+
 (defun smtp-open-connection (buffer server service)
   (let ((process
 	 (as-binary-process
@@ -164,7 +213,11 @@ or `smtp-local-domain' correctly."))))))
 	     (funcall smtp-server sender recipients)
 	   smtp-server))
 	(package
-	 (smtp-make-package sender recipients buffer)))
+	 (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
@@ -177,11 +230,11 @@ or `smtp-local-domain' correctly."))))))
       (setq smtp-read-point (point-min))
       (condition-case nil
 	  (progn
-	    (smtp-commit package)
+	    (funcall smtp-submit-package-function package)
 	    t)
 	(smtp-response-error)))))
 
-(defun smtp-commit (package)
+(defun smtp-submit-package (package)
   (unwind-protect
       (progn
 	(smtp-primitive-greeting package)
@@ -195,7 +248,7 @@ or `smtp-local-domain' correctly."))))))
 	(smtp-primitive-quit package)
 	(smtp-close-connection connection)))))
 
-;;; @ hook methods for `smtp-commit'
+;;; @ hook methods for `smtp-submit-package'
 ;;;
 (defun smtp-primitive-greeting (package)
   (let* ((connection
@@ -206,6 +259,25 @@ or `smtp-local-domain' correctly."))))))
     (if (/= (car response) 220)
 	(smtp-response-error response))))
 
+(defun smtp-primitive-ehlo (package)
+  (let* ((connection
+	  (smtp-find-connection (current-buffer)))
+	 (process
+	  (smtp-connection-process-internal connection))
+	 response)
+    (smtp-send-command process (format "EHLO %s" (smtp-make-fqdn)))
+    (setq response (smtp-read-response process))
+    (if (/= (car response) 250)
+	(smtp-response-error response))
+    (smtp-connection-set-extensions-internal
+     connection (mapcar
+		 (lambda (extension)
+		   (mapcar
+		    (lambda (parameter)
+		      (car (read-from-string (downcase parameter))))
+		    (split-string extension)))
+		 (cdr response)))))
+
 (defun smtp-primitive-helo (package)
   (let* ((connection
 	  (smtp-find-connection (current-buffer)))
@@ -217,14 +289,42 @@ or `smtp-local-domain' correctly."))))))
     (if (/= (car response) 250)
 	(smtp-response-error response))))
 
+(defun smtp-primitive-starttls (package)
+  (let* ((connection
+	  (smtp-find-connection (current-buffer)))
+	 (process
+	  (smtp-connection-process-internal connection))
+	 response)
+    ;; STARTTLS --- begin a TLS negotiation (RFC 2595)
+    (smtp-send-command process "STARTTLS")
+    (setq response (smtp-read-response process))
+    (starttls-negotiate process)))
+
 (defun smtp-primitive-mailfrom (package)
   (let* ((connection
 	  (smtp-find-connection (current-buffer)))
 	 (process
 	  (smtp-connection-process-internal connection))
+	 (extensions
+	  (smtp-connection-extensions-internal
+	   connection))
+	 (sender
+	  (smtp-package-sender-internal package))
+	 extension
 	 response)
+    ;; SIZE --- Message Size Declaration (RFC1870)
+    (if (and smtp-use-size
+	     (assq 'size extensions))
+	(setq extension (format "SIZE=%d" (smtp-package-buffer-size package))))
+    ;; 8BITMIME --- 8bit-MIMEtransport (RFC1652)
+    (if (and smtp-use-8bitmime
+	     (assq '8bitmime extensions))
+	(setq extension (concat extension " BODY=8BITMIME")))
     (smtp-send-command
-     process (format "MAIL FROM:<%s>" (smtp-package-sender-internal package)))
+     process
+     (if extension
+	 (format "MAIL FROM:<%s> %s" sender extension)
+       (format "MAIL FROM:<%s>" sender)))
     (setq response (smtp-read-response process))
     (if (/= (car response) 250)
 	(smtp-response-error response))))