+(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)
+ "Like `smtp-send-buffer', but sucks in any errors."
+ (condition-case nil
+ (progn
+ (smtp-send-buffer sender recipients buffer)
+ t)
+ (smtp-error)))
+
+(make-obsolete 'smtp-via-smtp "It's old API.")
+
+;;;###autoload
+(defun smtp-send-buffer (sender recipients buffer)
+ "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)
+ 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)))))
+
+(defun smtp-submit-package (package)
+ (unwind-protect
+ (progn
+ (smtp-primitive-greeting package)
+ (condition-case nil
+ (smtp-primitive-ehlo package)
+ (smtp-response-error
+ (smtp-primitive-helo package)))
+ (if smtp-use-starttls
+ (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))))
+ (when (smtp-connection-opened connection)
+ (smtp-primitive-quit package)
+ (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'
+;;;
+
+(defun smtp-primitive-greeting (package)
+ (let* ((connection
+ (smtp-find-connection (current-buffer)))
+ (response
+ (smtp-read-response connection)))
+ (if (/= (car response) 220)
+ (smtp-response-error response))))
+
+(defun smtp-primitive-ehlo (package)
+ (let* ((connection
+ (smtp-find-connection (current-buffer)))
+ response)
+ (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-internal
+ connection (mapcar
+ (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)))
+ response)
+ (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)))
+ (mechanisms
+ (cdr (assq 'auth (smtp-connection-extensions-internal connection))))
+ (sasl-mechanisms
+ (or smtp-sasl-mechanisms sasl-mechanisms))
+ (mechanism
+ (sasl-find-mechanism mechanisms))
+ client
+ name
+ step
+ response)
+ (unless mechanism
+ (error "No authentication mechanism available"))
+ (setq client (sasl-make-client mechanism smtp-sasl-user-name "smtp"
+ (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
+ 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 connection))
+ (when (= (car response) 235)
+ ;; The authentication process is finished.
+ (setq step (sasl-next-step client step))
+ (if (null step)
+ (throw 'done nil))
+ (smtp-response-error response)) ;Bogus server?
+ (if (/= (car response) 334)
+ (smtp-response-error response))
+ (sasl-step-set-data step (base64-decode-string (nth 1 response)))
+ (setq step (sasl-next-step client step))
+ (smtp-send-command
+ 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)))
+ response)
+ ;; STARTTLS --- begin a TLS negotiation (RFC 2595)
+ (smtp-send-command connection "STARTTLS")
+ (setq response (smtp-read-response connection))
+ (if (/= (car response) 220)
+ (smtp-response-error response))
+ (starttls-negotiate (smtp-connection-process-internal connection))))
+
+(defun smtp-primitive-mailfrom (package)
+ (let* ((connection
+ (smtp-find-connection (current-buffer)))
+ (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-internal-size package))))
+ ;; 8BITMIME --- 8bit-MIMEtransport (RFC1652)
+ (if (and smtp-use-8bitmime
+ (assq '8bitmime extensions))
+ (setq extension (concat extension " BODY=8BITMIME")))
+ (smtp-send-command
+ connection
+ (if extension
+ (format "MAIL FROM:<%s> %s" sender extension)
+ (format "MAIL FROM:<%s>" sender)))
+ (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)))
+ (recipients
+ (smtp-package-recipients-internal package))
+ response)
+ (while recipients
+ (smtp-send-command
+ 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)))
+ response)
+ (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-internal package))
+ (goto-char (point-min))
+ (while (not (eobp))
+ (smtp-send-data
+ connection (buffer-substring (point) (progn (end-of-line)(point))))
+ (beginning-of-line 2)))
+ (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)))
+ response)
+ (smtp-send-command connection "QUIT")
+ (setq response (smtp-read-response connection))
+ (if (/= (car response) 221)
+ (smtp-response-error response))))
+
+;;; @ low level process manipulating function
+;;;