Function: smtpmail-via-smtp
smtpmail-via-smtp is a byte-compiled function defined in
smtpmail.el.gz.
Signature
(smtpmail-via-smtp RECIPIENT SMTPMAIL-TEXT-BUFFER &optional ASK-FOR-PASSWORD SEND-ATTEMPTS)
Source Code
;; Defined in /usr/src/emacs/lisp/mail/smtpmail.el.gz
(defun smtpmail-via-smtp (recipient smtpmail-text-buffer
&optional ask-for-password
send-attempts)
(unless smtpmail-smtp-server
(smtpmail-query-smtp-server))
(let ((process nil)
(send-attempts (or send-attempts 1))
(host (or smtpmail-smtp-server
(error "`smtpmail-smtp-server' not defined")))
(port smtpmail-smtp-service)
;; `smtpmail-mail-address' should be set to the appropriate
;; buffer-local value by the caller, but in case not:
(envelope-from
(save-restriction
;; Only look at the headers when fetching the
;; envelope address.
(message-narrow-to-headers)
(or smtpmail-mail-address
(and mail-specify-envelope-from
(mail-envelope-from))
(let ((from (mail-fetch-field "from")))
(and from
(cadr (mail-extract-address-components from))))
(smtpmail-user-mail-address))))
process-buffer
result
auth-mechanisms
(supported-extensions '()))
(when (and smtpmail-servers-requiring-authorization
(string-match-p smtpmail-servers-requiring-authorization
smtpmail-smtp-server))
(setq ask-for-password t))
(unwind-protect
(catch 'done
;; get or create the trace buffer
(setq process-buffer
(get-buffer-create
(format "*trace of SMTP session to %s*" host)))
;; clear the trace buffer of old output
(with-current-buffer process-buffer
(setq buffer-undo-list t)
(erase-buffer))
;; Open the connection to the server.
;; FIXME: Should we use raw-text-dos coding system to handle the r\n
;; for us?
(let ((coding-system-for-read 'binary)
(coding-system-for-write 'binary))
(setq result
(open-network-stream
"smtpmail" process-buffer host port
:type smtpmail-stream-type
:return-list t
:warn-unless-encrypted ask-for-password
:capability-command (format "EHLO %s\r\n" (smtpmail-fqdn))
:end-of-command "^[0-9]+ .*\r\n"
:success "^2.*\n"
:always-query-capabilities t
:starttls-function
(lambda (capabilities)
(and (string-match "[ -]STARTTLS" capabilities)
"STARTTLS\r\n"))
:client-certificate t
:use-starttls-if-possible t)))
;; If we couldn't access the server at all, we give up.
(unless (setq process (car result))
(throw 'done (if (plist-get (cdr result) :error)
(plist-get (cdr result) :error)
"Unable to contact server")))
;; set the send-filter
(set-process-filter process #'smtpmail-process-filter)
(let* ((greeting (plist-get (cdr result) :greeting))
(code (smtpmail-response-code greeting)))
(unless code
(throw 'done (format "No greeting: %s" greeting)))
(when (>= code 400)
(throw 'done (format "Connection not allowed: %s" greeting))))
(with-current-buffer process-buffer
(set-process-coding-system process 'raw-text-unix 'raw-text-unix)
(setq-local smtpmail-read-point (point-min))
(let* ((capabilities (plist-get (cdr result) :capabilities))
(code (smtpmail-response-code capabilities)))
(if (or (null code)
(>= code 400))
;; The server didn't accept EHLO, so we fall back on HELO.
(smtpmail-command-or-throw
process (format "HELO %s" (smtpmail-fqdn)))
;; EHLO was successful, so we parse the extensions.
(dolist (line (delete
""
(split-string
(plist-get (cdr result) :capabilities)
"\r\n")))
(let ((name
;; Use ASCII case-table to prevent I
;; downcasing to a dotless i under some
;; language environments. See
;; https://lists.gnu.org/archive/html/emacs-devel/2007-03/msg01760.html.
(with-case-table ascii-case-table
(mapcar (lambda (s) (intern (downcase s)))
(split-string (substring line 4) "[ ]")))))
(when (= (length name) 1)
(setq name (car name)))
(when name
(cond ((memq (if (consp name) (car name) name)
'(verb xvrb 8bitmime onex xone
expn size dsn etrn
enhancedstatuscodes
help xusr
auth=login auth starttls))
(setq supported-extensions
(cons name supported-extensions)))
(smtpmail-warn-about-unknown-extensions
(message "Unknown extension %s" name))))))))
(setq auth-mechanisms
(smtpmail-try-auth-methods
process supported-extensions host port
ask-for-password))
(when (or (member 'onex supported-extensions)
(member 'xone supported-extensions))
(smtpmail-command-or-throw process "ONEX"))
(when (and smtpmail-debug-verb
(or (member 'verb supported-extensions)
(member 'xvrb supported-extensions)))
(smtpmail-command-or-throw process "VERB"))
(when (member 'xusr supported-extensions)
(smtpmail-command-or-throw process "XUSR"))
;; MAIL FROM:<sender>
(let ((size-part
(if (or (member 'size supported-extensions)
(assoc 'size supported-extensions))
(format " SIZE=%d"
(with-current-buffer smtpmail-text-buffer
;; size estimate:
(+ (- (point-max) (point-min))
;; Add one byte for each change-of-line
;; because of CR-LF representation:
(count-lines (point-min) (point-max)))))
""))
(body-part
(if (member '8bitmime supported-extensions)
;; FIXME:
;; Code should be added here that transforms
;; the contents of the message buffer into
;; something the receiving SMTP can handle.
;; For a receiver that supports 8BITMIME, this
;; may mean converting BINARY to BASE64, or
;; adding Content-Transfer-Encoding and the
;; other MIME headers. The code should also
;; return an indication of what encoding the
;; message buffer is now, i.e. ASCII or
;; 8BITMIME.
(if nil
" BODY=8BITMIME"
"")
"")))
(smtpmail-send-command
process (format "MAIL FROM:<%s>%s%s"
envelope-from size-part body-part))
(cond
((smtpmail-ok-p (setq result (smtpmail-read-response process)))
;; Success.
)
((and (numberp (car result))
(<= 400 (car result) 499)
(< send-attempts smtpmail-retries))
(message "Got transient error code %s when sending; retrying attempt %d..."
(car result) send-attempts)
;; Retry on getting a transient 4xx code; see
;; https://tools.ietf.org/html/rfc5321#section-4.2.1
(ignore-errors
(smtpmail-send-command process "QUIT")
(smtpmail-read-response process))
(delete-process process)
(sleep-for 1)
(setq process nil)
(throw 'done
(smtpmail-via-smtp recipient smtpmail-text-buffer
ask-for-password
(1+ send-attempts))))
((and auth-mechanisms
(not ask-for-password)
(eq (car result) 530))
;; We got a "530 auth required", so we close and try
;; again, this time asking the user for a password.
;; We ignore any errors here, because some MTAs just
;; close the connection immediately after giving the
;; error message.
(ignore-errors
(smtpmail-send-command process "QUIT")
(smtpmail-read-response process))
(delete-process process)
(setq process nil)
(throw 'done
(smtpmail-via-smtp recipient smtpmail-text-buffer t)))
(t
;; Return the error code.
(throw 'done
(smtpmail-response-text result)))))
;; RCPT TO:<recipient>
(let ((n 0))
(while (not (null (nth n recipient)))
(smtpmail-send-command
process (format "RCPT TO:<%s>"
(smtpmail-maybe-append-domain
(nth n recipient))))
(cond
((smtpmail-ok-p (setq result (smtpmail-read-response process)))
;; Success.
nil)
((and auth-mechanisms
(not ask-for-password)
(integerp (car result))
(>= (car result) 550)
(<= (car result) 554))
;; We got a "550 relay not permitted" (or the like),
;; and the server accepts credentials, so we try
;; again, but ask for a password first.
(smtpmail-send-command process "QUIT")
(smtpmail-read-response process)
(delete-process process)
(setq process nil)
(throw 'done
(smtpmail-via-smtp recipient smtpmail-text-buffer t)))
(t
;; Return the error code.
(throw 'done
(smtpmail-response-text result))))
(setq n (1+ n))))
;; Send the contents.
(smtpmail-command-or-throw process "DATA")
(smtpmail-send-data process smtpmail-text-buffer)
;; Return success.
nil))
(when (and process
(buffer-live-p process-buffer))
(with-current-buffer (process-buffer process)
(smtpmail-send-command process "QUIT")
(smtpmail-read-response process)
(delete-process process)
(unless smtpmail-debug-info
(kill-buffer process-buffer)))))))