body-start
body-end))
- (luna-define-internal-accessors 'mime-buffer-entity)
- )
+ (luna-define-internal-accessors 'mime-buffer-entity))
(luna-define-method initialize-instance :after ((entity mime-buffer-entity)
&rest init-args)
(setq header-end (point-min)
body-start (point-min)))
(mime-buffer-entity-set-header-end-internal entity header-end)
- (mime-buffer-entity-set-body-start-internal entity body-start)
- )
+ (mime-buffer-entity-set-body-start-internal entity body-start))
(or (mime-entity-content-type-internal entity)
(save-restriction
(narrow-to-region header-start header-end)
entity
(let ((str (std11-fetch-field "Content-Type")))
(if str
- (mime-parse-Content-Type str)
- )))
- ))
- ))
+ (mime-parse-Content-Type str))))))))
entity)
(luna-define-method mime-entity-name ((entity mime-buffer-entity))
- (buffer-name (mime-buffer-entity-buffer-internal entity))
- )
+ (buffer-name (mime-buffer-entity-buffer-internal entity)))
;;; @ entity
(luna-define-method mime-insert-entity ((entity mime-buffer-entity))
(insert-buffer-substring (mime-buffer-entity-buffer-internal entity)
(mime-buffer-entity-header-start-internal entity)
- (mime-buffer-entity-body-end-internal entity))
- )
+ (mime-buffer-entity-body-end-internal entity)))
(luna-define-method mime-write-entity ((entity mime-buffer-entity) filename)
(save-excursion
(write-region-as-raw-text-CRLF
(mime-buffer-entity-header-start-internal entity)
(mime-buffer-entity-body-end-internal entity)
- filename)
- ))
+ filename)))
;;; @ entity header
(luna-define-method mime-insert-entity-body ((entity mime-buffer-entity))
(insert-buffer-substring (mime-buffer-entity-buffer-internal entity)
(mime-buffer-entity-body-start-internal entity)
- (mime-buffer-entity-body-end-internal entity))
- )
+ (mime-buffer-entity-body-end-internal entity)))
(luna-define-method mime-write-entity-body ((entity mime-buffer-entity)
filename)
(set-buffer (mime-buffer-entity-buffer-internal entity))
(write-region-as-binary (mime-buffer-entity-body-start-internal entity)
(mime-buffer-entity-body-end-internal entity)
- filename)
- ))
+ filename)))
;;; @ entity content
(mime-write-decoded-region (mime-buffer-entity-body-start-internal entity)
(mime-buffer-entity-body-end-internal entity)
filename
- (or (mime-entity-encoding entity) "7bit"))
- ))
+ (or (mime-entity-encoding entity) "7bit"))))
;;; @ header field
(or (symbolp field-name)
(setq field-name
(intern (capitalize (capitalize field-name)))))
- (mime-entity-set-original-header-internal
+ (mime-entity-set-original-header-internal
entity
(put-alist field-name ret
(mime-entity-original-header-internal entity)))
(mime-buffer-entity-buffer-internal entity)
(mime-buffer-entity-header-start-internal entity)
(mime-buffer-entity-header-end-internal entity)
- invisible-fields visible-fields)
- )
+ invisible-fields visible-fields))
;;; @ header buffer
;;;
;; (luna-define-method mime-entity-header-buffer ((entity mime-buffer-entity))
-;; (mime-buffer-entity-buffer-internal entity)
-;; )
+;; (mime-buffer-entity-buffer-internal entity))
;; (luna-define-method mime-goto-header-start-point ((entity mime-buffer-entity))
;; (set-buffer (mime-buffer-entity-buffer-internal entity))
-;; (goto-char (mime-buffer-entity-header-start-internal entity))
-;; )
+;; (goto-char (mime-buffer-entity-header-start-internal entity)))
;; (luna-define-method mime-entity-header-start-point ((entity
;; mime-buffer-entity))
-;; (mime-buffer-entity-header-start-internal entity)
-;; )
+;; (mime-buffer-entity-header-start-internal entity))
;; (luna-define-method mime-entity-header-end-point ((entity
;; mime-buffer-entity))
-;; (mime-buffer-entity-header-end-internal entity)
-;; )
+;; (mime-buffer-entity-header-end-internal entity))
;;; @ body buffer
;;;
;; (luna-define-method mime-entity-body-buffer ((entity mime-buffer-entity))
-;; (mime-buffer-entity-buffer-internal entity)
-;; )
+;; (mime-buffer-entity-buffer-internal entity))
;; (luna-define-method mime-goto-body-start-point ((entity mime-buffer-entity))
;; (set-buffer (mime-buffer-entity-buffer-internal entity))
-;; (goto-char (mime-buffer-entity-body-start-internal entity))
-;; )
+;; (goto-char (mime-buffer-entity-body-start-internal entity)))
;; (luna-define-method mime-goto-body-end-point ((entity mime-buffer-entity))
;; (set-buffer (mime-buffer-entity-buffer-internal entity))
-;; (goto-char (mime-buffer-entity-body-end-internal entity))
-;; )
+;; (goto-char (mime-buffer-entity-body-end-internal entity)))
;; (luna-define-method mime-entity-body-start-point ((entity mime-buffer-entity))
-;; (mime-buffer-entity-body-start-internal entity)
-;; )
+;; (mime-buffer-entity-body-start-internal entity))
;; (luna-define-method mime-entity-body-end-point ((entity mime-buffer-entity))
-;; (mime-buffer-entity-body-end-internal entity)
-;; )
+;; (mime-buffer-entity-body-end-internal entity))
;;; @ buffer (obsolete)
;;;
;; (luna-define-method mime-entity-buffer ((entity mime-buffer-entity))
-;; (mime-buffer-entity-buffer-internal entity)
-;; )
+;; (mime-buffer-entity-buffer-internal entity))
;; (luna-define-method mime-entity-point-min ((entity mime-buffer-entity))
-;; (mime-buffer-entity-header-start-internal entity)
-;; )
+;; (mime-buffer-entity-header-start-internal entity))
;; (luna-define-method mime-entity-point-max ((entity mime-buffer-entity))
-;; (mime-buffer-entity-body-end-internal entity)
-;; )
+;; (mime-buffer-entity-body-end-internal entity))
;;; @ children
;;;
-(defun mmbuffer-parse-multipart (entity)
+(defun mmbuffer-parse-multipart (entity &optional representation-type)
(with-current-buffer (mime-buffer-entity-buffer-internal entity)
- (let* ((representation-type
- (mime-entity-representation-type-internal entity))
- (content-type (mime-entity-content-type-internal entity))
+ (or representation-type
+ (setq representation-type
+ (mime-entity-representation-type-internal entity)))
+ (let* ((content-type (mime-entity-content-type-internal entity))
(dash-boundary
(concat "--"
(mime-content-type-parameter content-type "boundary")))
(dc-ctl
(if (eq (mime-content-type-subtype content-type) 'digest)
(make-mime-content-type 'message 'rfc822)
- (make-mime-content-type 'text 'plain)
- ))
+ (make-mime-content-type 'text 'plain)))
(body-start (mime-buffer-entity-body-start-internal entity))
(body-end (mime-buffer-entity-body-end-internal entity)))
(save-restriction
(save-restriction
(narrow-to-region cb ce)
(setq ret (mime-parse-message representation-type dc-ctl
- entity (cons i node-id)))
- )
+ entity (cons i node-id))))
(setq children (cons ret children))
(goto-char (setq cb ncb))
- (setq i (1+ i))
- )
+ (setq i (1+ i)))
(setq ce (point-max))
(save-restriction
(narrow-to-region cb ce)
(setq ret (mime-parse-message representation-type dc-ctl
- entity (cons i node-id)))
- )
+ entity (cons i node-id))))
(setq children (cons ret children))
- (mime-entity-set-children-internal entity (nreverse children))
- )
+ (mime-entity-set-children-internal entity (nreverse children)))
(mime-entity-set-content-type-internal
entity (make-mime-content-type 'message 'x-broken))
- nil)
- ))))
+ nil)))))
-(defun mmbuffer-parse-encapsulated (entity &optional external)
+(defun mmbuffer-parse-encapsulated (entity &optional external
+ representation-type)
(mime-entity-set-children-internal
entity
(with-current-buffer (mime-buffer-entity-buffer-internal entity)
(progn
(require 'mmexternal)
'mime-external-entity)
- (mime-entity-representation-type-internal entity))
+ (or representation-type
+ (mime-entity-representation-type-internal entity)))
nil
entity (cons 0 (mime-entity-node-id-internal entity))))))))
;;; Code:
(require 'pces)
-(require 'pcustom)
+(require 'custom)
(require 'mail-utils) ; mail-strip-quoted-names
(require 'sasl)
+(require 'luna)
(defgroup smtp nil
"SMTP protocol for sending mail."
(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
(defvar smtp-submit-package-function (function smtp-submit-package))
-;;; @ SMTP package structure
+;;; @ SMTP package
;;; A package contains a mail message, an envelope sender address,
;;; and one or more envelope recipient addresses. In ESMTP model
;;; the current sending package should be guaranteed to be accessible
;;; anywhere from the hook methods (or SMTP commands).
-(defmacro smtp-package-sender (package)
- "Return the sender of PACKAGE, a string."
- (` (aref (, package) 0)))
-
-(defmacro smtp-package-recipients (package)
- "Return the recipients of PACKAGE, a list of strings."
- (` (aref (, package) 1)))
+(eval-and-compile
+ (luna-define-class smtp-package ()
+ (sender
+ recipients
+ buffer))
-(defmacro smtp-package-buffer (package)
- "Return the data of PACKAGE, a buffer."
- (` (aref (, package) 2)))
+ (luna-define-internal-accessors 'smtp-package))
-(defmacro smtp-make-package (sender recipients buffer)
+(defun smtp-make-package (sender recipients buffer)
"Create a new package structure.
A package is a unit of SMTP message
SENDER specifies the package sender, a string.
RECIPIENTS is a list of recipients.
BUFFER may be a buffer or a buffer name which contains mail message."
- (` (vector (, sender) (, recipients) (, buffer))))
+ (luna-make-entity 'smtp-package :sender sender :recipients recipients :buffer buffer))
-(defun smtp-package-buffer-size (package)
+(defun smtp-package-buffer-internal-size (package)
"Return the size of PACKAGE, an integer."
(save-excursion
- (set-buffer (smtp-package-buffer package))
+ (set-buffer (smtp-package-buffer-internal package))
(let ((size
(+ (buffer-size)
;; Add one byte for each change-of-line
(setq size (1+ size)))
size)))
-;;; @ SMTP connection structure
+;;; @ SMTP connection
;;; We should consider the function `open-network-stream' is a emulation
;;; for another network stream. They are likely to be implemented with an
;;; external program and the function `process-contact' returns the
;;; process id instead of `(HOST SERVICE)' pair.
-(defmacro smtp-connection-process (connection)
- "Return the subprocess-object of CONNECTION."
- (` (aref (, connection) 0)))
-
-(defmacro smtp-connection-server (connection)
- "Return the server of CONNECTION, a string."
- (` (aref (, connection) 1)))
-
-(defmacro smtp-connection-service (connection)
- "Return the service of CONNECTION, a string or an integer."
- (` (aref (, connection) 2)))
-
-(defmacro smtp-connection-extensions (connection)
- "Return the SMTP extensions of CONNECTION, a list of strings."
- (` (aref (, connection) 3)))
+(eval-and-compile
+ (luna-define-class smtp-connection ()
+ (process
+ server
+ service
+ extensions
+ encoder
+ decoder))
-(defmacro smtp-connection-set-extensions (connection extensions)
- "Set the SMTP extensions of CONNECTION.
-EXTENSIONS is a list of cons cells of the form \(EXTENSION . PARAMETERS).
-Where EXTENSION is a symbol and PARAMETERS is a list of strings."
- (` (aset (, connection) 3 (, extensions))))
+ (luna-define-internal-accessors 'smtp-connection))
-(defmacro smtp-make-connection (process server service)
+(defun smtp-make-connection (process server service)
"Create a new connection structure.
PROCESS is an internal subprocess-object. SERVER is name of the host
to connect to. SERVICE is name of the service desired."
- (` (vector (, process) (, server) (, service) nil)))
+ (luna-make-entity 'smtp-connection :process process :server server :service service))
-(defun smtp-connection-opened (connection)
- "Say whether the CONNECTION to server has been opened."
- (let ((process (smtp-connection-process connection)))
+(luna-define-generic smtp-connection-opened (connection)
+ "Say whether the CONNECTION to server has been opened.")
+
+(luna-define-generic smtp-close-connection (connection)
+ "Close the CONNECTION to server.")
+
+(luna-define-method smtp-connection-opened ((connection smtp-connection))
+ (let ((process (smtp-connection-process-internal connection)))
(if (memq (process-status process) '(open run))
t)))
-(defun smtp-close-connection (connection)
- "Close the CONNECTION to server."
- (let ((process (smtp-connection-process connection)))
+(luna-define-method smtp-close-connection ((connection smtp-connection))
+ (let ((process (smtp-connection-process-internal connection)))
(delete-process process)))
(defun smtp-make-fqdn ()
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
- (as-binary-process
+ (let* ((coding-system-for-read 'binary)
+ (coding-system-for-write 'binary)
+ (process
(funcall smtp-open-connection-function
- "SMTP" buffer server service)))
- connection)
+ "SMTP" buffer server service))
+ connection)
(when process
(setq connection (smtp-make-connection process server service))
(set-process-filter process 'smtp-process-filter)
(let* ((connection
(smtp-find-connection (current-buffer)))
(response
- (smtp-read-response
- (smtp-connection-process connection))))
+ (smtp-read-response connection)))
(if (/= (car response) 220)
(smtp-response-error response))))
(defun smtp-primitive-ehlo (package)
(let* ((connection
(smtp-find-connection (current-buffer)))
- (process
- (smtp-connection-process connection))
response)
- (smtp-send-command process (format "EHLO %s" (smtp-make-fqdn)))
- (setq response (smtp-read-response process))
+ (smtp-send-command connection (format "EHLO %s" (smtp-make-fqdn)))
+ (setq response (smtp-read-response connection))
(if (/= (car response) 250)
(smtp-response-error response))
- (smtp-connection-set-extensions
+ (smtp-connection-set-extensions-internal
connection (mapcar
- (function
- (lambda (extension)
- (let ((extensions
- (split-string extension)))
- (setcar extensions
- (car (read-from-string
- (downcase (car extensions)))))
- extensions)))
+ (lambda (extension)
+ (let ((extensions
+ (split-string extension)))
+ (setcar extensions
+ (car (read-from-string
+ (downcase (car extensions)))))
+ extensions))
(cdr response)))))
(defun smtp-primitive-helo (package)
(let* ((connection
(smtp-find-connection (current-buffer)))
- (process
- (smtp-connection-process connection))
response)
- (smtp-send-command process (format "HELO %s" (smtp-make-fqdn)))
- (setq response (smtp-read-response process))
+ (smtp-send-command connection (format "HELO %s" (smtp-make-fqdn)))
+ (setq response (smtp-read-response connection))
(if (/= (car response) 250)
(smtp-response-error response))))
(defun smtp-primitive-auth (package)
(let* ((connection
(smtp-find-connection (current-buffer)))
- (process
- (smtp-connection-process connection))
(mechanisms
- (cdr (assq 'auth (smtp-connection-extensions connection))))
+ (cdr (assq 'auth (smtp-connection-extensions-internal connection))))
(sasl-mechanisms
(or smtp-sasl-mechanisms sasl-mechanisms))
(mechanism
(unless mechanism
(error "No authentication mechanism available"))
(setq client (sasl-make-client mechanism smtp-sasl-user-name "smtp"
- (smtp-connection-server connection)))
+ (smtp-connection-server-internal connection)))
(if smtp-sasl-properties
(sasl-client-set-properties client smtp-sasl-properties))
(setq name (sasl-mechanism-name mechanism)
;; Retrieve the initial response
step (sasl-next-step client nil))
(smtp-send-command
- process
+ connection
(if (sasl-step-data step)
(format "AUTH %s %s" name (base64-encode-string (sasl-step-data step) t))
(format "AUTH %s" name)))
(catch 'done
(while t
- (setq response (smtp-read-response process))
+ (setq response (smtp-read-response connection))
(when (= (car response) 235)
;; The authentication process is finished.
(setq step (sasl-next-step client step))
(sasl-step-set-data step (base64-decode-string (nth 1 response)))
(setq step (sasl-next-step client step))
(smtp-send-command
- process (if (sasl-step-data step)
- (base64-encode-string (sasl-step-data step) t)
- ""))))))
+ connection
+ (if (sasl-step-data step)
+ (base64-encode-string (sasl-step-data step) t)
+ ""))))
+ ;;; (smtp-connection-set-encoder-internal
+ ;;; connection (sasl-client-encoder client))
+ ;;; (smtp-connection-set-decoder-internal
+ ;;; connection (sasl-client-decoder client))
+ ))
(defun smtp-primitive-starttls (package)
(let* ((connection
(smtp-find-connection (current-buffer)))
- (process
- (smtp-connection-process connection))
response)
;; STARTTLS --- begin a TLS negotiation (RFC 2595)
- (smtp-send-command process "STARTTLS")
- (setq response (smtp-read-response process))
+ (smtp-send-command connection "STARTTLS")
+ (setq response (smtp-read-response connection))
(if (/= (car response) 220)
(smtp-response-error response))
- (starttls-negotiate process)))
+ (starttls-negotiate (smtp-connection-process-internal connection))))
(defun smtp-primitive-mailfrom (package)
(let* ((connection
(smtp-find-connection (current-buffer)))
- (process
- (smtp-connection-process connection))
(extensions
- (smtp-connection-extensions
+ (smtp-connection-extensions-internal
connection))
(sender
- (smtp-package-sender package))
+ (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))))
+ (setq extension (format "SIZE=%d" (smtp-package-buffer-internal-size package))))
;; 8BITMIME --- 8bit-MIMEtransport (RFC1652)
(if (and smtp-use-8bitmime
(assq '8bitmime extensions))
(setq extension (concat extension " BODY=8BITMIME")))
(smtp-send-command
- process
+ connection
(if extension
(format "MAIL FROM:<%s> %s" sender extension)
(format "MAIL FROM:<%s>" sender)))
- (setq response (smtp-read-response process))
+ (setq response (smtp-read-response connection))
(if (/= (car response) 250)
(smtp-response-error response))))
(defun smtp-primitive-rcptto (package)
(let* ((connection
(smtp-find-connection (current-buffer)))
- (process
- (smtp-connection-process connection))
(recipients
- (smtp-package-recipients package))
+ (smtp-package-recipients-internal package))
response)
(while recipients
(smtp-send-command
- process (format "RCPT TO:<%s>" (pop recipients)))
- (setq response (smtp-read-response process))
+ connection (format "RCPT TO:<%s>" (pop recipients)))
+ (setq response (smtp-read-response connection))
(unless (memq (car response) '(250 251))
(smtp-response-error response)))))
(defun smtp-primitive-data (package)
(let* ((connection
(smtp-find-connection (current-buffer)))
- (process
- (smtp-connection-process connection))
response)
- (smtp-send-command process "DATA")
- (setq response (smtp-read-response process))
+ (smtp-send-command connection "DATA")
+ (setq response (smtp-read-response connection))
(if (/= (car response) 354)
(smtp-response-error response))
(save-excursion
- (set-buffer (smtp-package-buffer package))
+ (set-buffer (smtp-package-buffer-internal package))
(goto-char (point-min))
(while (not (eobp))
(smtp-send-data
- process (buffer-substring (point) (progn (end-of-line)(point))))
+ connection (buffer-substring (point) (progn (end-of-line)(point))))
(beginning-of-line 2)))
- (smtp-send-command process ".")
- (setq response (smtp-read-response process))
+ (smtp-send-command connection ".")
+ (setq response (smtp-read-response connection))
(if (/= (car response) 250)
(smtp-response-error response))))
(defun smtp-primitive-quit (package)
(let* ((connection
(smtp-find-connection (current-buffer)))
- (process
- (smtp-connection-process connection))
response)
- (smtp-send-command process "QUIT")
- (setq response (smtp-read-response process))
+ (smtp-send-command connection "QUIT")
+ (setq response (smtp-read-response connection))
(if (/= (car response) 221)
(smtp-response-error response))))
(defun smtp-response-error (response)
(signal 'smtp-response-error response))
-(defun smtp-read-response (process)
- (let ((response-continue t)
+(defun smtp-read-response (connection)
+ (let ((decoder
+ (smtp-connection-decoder-internal connection))
+ (response-continue t)
response)
(while response-continue
(goto-char smtp-read-point)
(while (not (search-forward "\r\n" nil t))
- (accept-process-output process)
+ (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
response-continue nil)))
response))
-(defun smtp-send-command (process command)
+(defun smtp-send-command (connection command)
(save-excursion
- (set-buffer (process-buffer process))
- (goto-char (point-max))
- (insert command "\r\n")
- (setq smtp-read-point (point))
- (process-send-string process command)
- (process-send-string process "\r\n")))
-
-(defun smtp-send-data (process data)
- ;; Escape "." at start of a line.
- (if (eq (string-to-char data) ?.)
- (process-send-string process "."))
- (process-send-string process data)
- (process-send-string process "\r\n"))
+ (let ((process
+ (smtp-connection-process-internal connection))
+ (encoder
+ (smtp-connection-encoder-internal connection)))
+ (set-buffer (process-buffer process))
+ (goto-char (point-max))
+ (setq command (concat command "\r\n"))
+ (insert command)
+ (setq smtp-read-point (point))
+ (if encoder
+ (setq command (funcall encoder command)))
+ (process-send-string process command))))
+
+(defun smtp-send-data (connection data)
+ (let ((process
+ (smtp-connection-process-internal connection))
+ (encoder
+ (smtp-connection-encoder-internal connection)))
+ ;; Escape "." at start of a line.
+ (if (eq (string-to-char data) ?.)
+ (setq data (concat "." data "\r\n"))
+ (setq data (concat data "\r\n")))
+ (if encoder
+ (setq data (funcall encoder data)))
+ (process-send-string process data)))
(defun smtp-deduce-address-list (smtp-text-buffer header-start header-end)
"Get address list suitable for smtp RCPT TO:<address>."
projects / elisp / flim.git / commitdiff