;;; smtpmail.el --- simple SMTP protocol (RFC 821) for sending mail
-;; Copyright (C) 1995, 1996, 2001 Free Software Foundation, Inc.
+;; Copyright (C) 1995, 1996, 2001, 2002, 2003, 2004
+;; Free Software Foundation, Inc.
;; Author: Tomoji Kagatani <kagatani@rbc.ncl.omron.co.jp>
;; Maintainer: Simon Josefsson <simon@josefsson.org>
;; '(("YOUR SMTP HOST" 25 "username" "password")))
;;(setq smtpmail-starttls-credentials
;; '(("YOUR SMTP HOST" 25 "~/.my_smtp_tls.key" "~/.my_smtp_tls.cert")))
+;; Where the 25 equals the value of `smtpmail-smtp-service', it can be an
+;; integer or a string, just as long as they match (eq).
-;; To queue mail, set smtpmail-queue-mail to t and use
+;; To queue mail, set smtpmail-queue-mail to t and use
;; smtpmail-send-queued-mail to send.
;; Modified by Stephen Cranefield <scranefield@infoscience.otago.ac.nz>,
;;; Code:
(require 'sendmail)
-(require 'time-stamp)
(autoload 'starttls-open-stream "starttls")
(autoload 'starttls-negotiate "starttls")
(autoload 'mail-strip-quoted-names "mail-utils")
(autoload 'message-make-message-id "message")
(autoload 'rfc2104-hash "rfc2104")
(autoload 'netrc-parse "netrc")
+(autoload 'netrc-machine "netrc")
+(autoload 'netrc-get "netrc")
;;;
(defgroup smtpmail nil
(defcustom smtpmail-default-smtp-server nil
- "*Specify default SMTP server."
+ "*Specify default SMTP server.
+This only has effect if you specify it before loading the smtpmail library."
:type '(choice (const nil) string)
:group 'smtpmail)
-(defcustom smtpmail-smtp-server
+(defcustom smtpmail-smtp-server
(or (getenv "SMTPSERVER") smtpmail-default-smtp-server)
"*The name of the host running SMTP server."
:type '(choice (const nil) string)
:type 'boolean
:group 'smtpmail)
-(defcustom smtpmail-queue-mail nil
+(defcustom smtpmail-queue-mail nil
"*Specify if mail is queued (if t) or sent immediately (if nil).
If queued, it is stored in the directory `smtpmail-queue-dir'
and sent with `smtpmail-send-queued-mail'."
(string :tag "Username")
(choice (const :tag "Query when needed" nil)
(string :tag "Password")))))
- :version "21.3"
+ :version "21.4"
:group 'smtpmail)
(defcustom smtpmail-starttls-credentials '(("" 25 "" ""))
;;;
;;;
+(defvar smtpmail-mail-address nil
+ "Value to use for envelope-from address for mail from ambient buffer.")
+
;;;###autoload
(defun smtpmail-send-it ()
(let ((errbuf (if mail-interactive
(case-fold-search nil)
delimline
(mailbuf (current-buffer))
+ ;; Examine this variable now, so that
+ ;; local binding in the mail buffer will take effect.
+ (smtpmail-mail-address
+ (or (and mail-specify-envelope-from (mail-envelope-from))
+ user-mail-address))
(smtpmail-code-conv-from
(if enable-multibyte-characters
(let ((sendmail-coding-system smtpmail-code-conv-from))
;; they put one in themselves.
(goto-char (point-min))
(if (not (re-search-forward "^From:" delimline t))
- (let* ((login user-mail-address)
+ (let* ((login smtpmail-mail-address)
(fullname (user-full-name)))
(cond ((eq mail-from-style 'angles)
(insert "From: " fullname)
;; ... then undo escaping of matching parentheses,
;; including matching nested parentheses.
(goto-char fullname-start)
- (while (re-search-forward
+ (while (re-search-forward
"\\(\\=\\|[^\\]\\(\\\\\\\\\\)*\\)\\\\(\\(\\([^\\]\\|\\\\\\\\\\)*\\)\\\\)"
fullname-end 1)
(replace-match "\\1(\\3)" t)
(setq smtpmail-recipient-address-list
(smtpmail-deduce-address-list tembuf (point-min) delimline))
(kill-buffer smtpmail-address-buffer)
-
+
(smtpmail-do-bcc delimline)
; Send or queue
(if (not smtpmail-queue-mail)
(if (not (null smtpmail-recipient-address-list))
- (if (not (smtpmail-via-smtp
+ (if (not (smtpmail-via-smtp
smtpmail-recipient-address-list tembuf))
(error "Sending failed; SMTP protocol error"))
(error "Sending failed; no recipients"))
- (let* ((file-data (concat
- smtpmail-queue-dir
- (concat (time-stamp-yyyy-mm-dd)
- "_" (time-stamp-hh:mm:ss)
- "_"
- (setq smtpmail-queue-counter
- (1+ smtpmail-queue-counter)))))
- (file-elisp (concat file-data ".el"))
+ (let* ((file-data
+ (expand-file-name
+ (format "%s_%i"
+ (format-time-string "%Y-%m-%d_%H:%M:%S")
+ (setq smtpmail-queue-counter
+ (1+ smtpmail-queue-counter)))
+ smtpmail-queue-dir))
+ (file-data (convert-standard-filename file-data))
+ (file-elisp (concat file-data ".el"))
(buffer-data (create-file-buffer file-data))
(buffer-elisp (create-file-buffer file-elisp))
(buffer-scratch "*queue-mail*"))
+ (unless (file-exists-p smtpmail-queue-dir)
+ (make-directory smtpmail-queue-dir t))
(with-current-buffer buffer-data
(erase-buffer)
(insert-buffer tembuf)
(insert (concat
"(setq smtpmail-recipient-address-list '"
(prin1-to-string smtpmail-recipient-address-list)
- ")\n"))
+ ")\n"))
(write-file file-elisp)
(set-buffer (generate-new-buffer buffer-scratch))
(insert (concat file-data "\n"))
- (append-to-file (point-min)
- (point-max)
+ (append-to-file (point-min)
+ (point-max)
smtpmail-queue-index)
)
(kill-buffer buffer-scratch)
(if (bufferp errbuf)
(kill-buffer errbuf)))))
+;;;###autoload
(defun smtpmail-send-queued-mail ()
"Send mail that was queued as a result of setting `smtpmail-queue-mail'."
(interactive)
(with-temp-buffer
(let ((coding-system-for-read 'no-conversion))
(insert-file-contents file-msg))
- (if (not (null smtpmail-recipient-address-list))
- (if (not (smtpmail-via-smtp smtpmail-recipient-address-list
- (current-buffer)))
- (error "Sending failed; SMTP protocol error"))
- (error "Sending failed; no recipients")))
+ (let ((smtpmail-mail-address
+ (or (and mail-specify-envelope-from (mail-envelope-from))
+ user-mail-address)))
+ (if (not (null smtpmail-recipient-address-list))
+ (if (not (smtpmail-via-smtp smtpmail-recipient-address-list
+ (current-buffer)))
+ (error "Sending failed; SMTP protocol error"))
+ (error "Sending failed; no recipients"))))
(delete-file file-msg)
(delete-file (concat file-msg ".el"))
- (kill-line 1))
+ (delete-region (point-at-bol) (point-at-bol 2)))
(write-region (point-min) (point-max) smtpmail-queue-index))))
;(defun smtpmail-via-smtp (host,port,sender,destination,smtpmail-text-buffer)
(let ((cred (smtpmail-find-credentials
smtpmail-starttls-credentials host port)))
(if (null (and cred (condition-case ()
- (call-process "starttls")
+ (progn
+ (require 'starttls)
+ (call-process starttls-program))
(error nil))))
;; The normal case.
(open-network-stream "SMTP" process-buffer host port)
(setq cred-key (expand-file-name cred-key)))
(file-regular-p
(setq cred-cert (expand-file-name cred-cert))))
- (list "--key-file" cred-key "--cert-file" cred-cert))))
+ (list "--key-file" cred-key "--cert-file" cred-cert)))
+ (starttls-extra-arguments
+ (when (and (stringp cred-key) (stringp cred-cert)
+ (file-regular-p
+ (setq cred-key (expand-file-name cred-key)))
+ (file-regular-p
+ (setq cred-cert (expand-file-name cred-cert))))
+ (list "--x509keyfile" cred-key "--x509certfile" cred-cert))))
(starttls-open-stream "SMTP" process-buffer host port)))))
(defun smtpmail-try-auth-methods (process supported-extensions host port)
(mech (car (smtpmail-intersection smtpmail-auth-supported mechs)))
(cred (if (stringp smtpmail-auth-credentials)
(let* ((netrc (netrc-parse smtpmail-auth-credentials))
- (hostentry (netrc-machine
- netrc host (format "%s" (or port "smtp"))
- "smtp")))
- (list host port
- (netrc-get hostentry "login")
- (netrc-get hostentry "password")))
+ (port-name (format "%s" (or port "smtp")))
+ (hostentry (netrc-machine netrc host port-name
+ port-name)))
+ (when hostentry
+ (list host port
+ (netrc-get hostentry "login")
+ (netrc-get hostentry "password"))))
(smtpmail-find-credentials
smtpmail-auth-credentials host port)))
(passwd (when cred
(smtpmail-cred-server cred)
(smtpmail-cred-port cred))))))
ret)
- (when cred
+ (when (and cred mech)
(cond
((eq mech 'cram-md5)
(smtpmail-send-command process (format "AUTH %s" mech))
(>= (car ret) 400))
(throw 'done nil)))
(t
- (error "Mechanism %s not implemented" mech)))
+ (error "Mechanism %s not implemented" mech)))
;; Remember the password.
(when (and (not (stringp smtpmail-auth-credentials))
(null (smtpmail-cred-passwd cred)))
(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 (or smtpmail-mail-address
+ (and mail-specify-envelope-from
+ (mail-envelope-from))
+ user-mail-address))
response-code
greeting
process-buffer
(make-local-variable 'smtpmail-read-point)
(setq smtpmail-read-point (point-min))
-
+
(if (or (null (car (setq greeting (smtpmail-read-response process))))
(not (integerp (car greeting)))
(>= (car greeting) 400))
(if (and do-starttls
(smtpmail-find-credentials smtpmail-starttls-credentials host port)
(member 'starttls supported-extensions)
- (process-id process))
+ (numberp (process-id process)))
(progn
(smtpmail-send-command process (format "STARTTLS"))
(if (or (null (car (setq response-code (smtpmail-read-response process))))
(starttls-negotiate process)
(setq do-starttls nil))
(setq do-ehlo nil))))
-
+
(smtpmail-try-auth-methods process supported-extensions host port)
(if (or (member 'onex supported-extensions)
(>= (car response-code) 400))
(throw 'done nil))))
- ;; MAIL FROM: <sender>
+ ;; MAIL FROM:<sender>
(let ((size-part
(if (or (member 'size supported-extensions)
(assoc 'size supported-extensions))
;; size estimate:
(+ (- (point-max) (point-min))
;; 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)))
+ ;; because of CR-LF representation:
+ (count-lines (point-min) (point-max)))))
""))
(body-part
(if (member '8bitmime supported-extensions)
"")
"")))
; (smtpmail-send-command process (format "MAIL FROM:%s@%s" (user-login-name) (smtpmail-fqdn)))
- (smtpmail-send-command process (format "MAIL FROM: <%s>%s%s"
- (or mail-envelope-from
- user-mail-address)
+ (smtpmail-send-command process (format "MAIL FROM:<%s>%s%s"
+ envelope-from
size-part
body-part))
(>= (car response-code) 400))
(throw 'done nil)
))
-
- ;; RCPT TO: <recipient>
+
+ ;; 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))))
+ (smtpmail-send-command process (format "RCPT TO:<%s>" (smtpmail-maybe-append-domain (nth n recipient))))
(setq n (1+ n))
(setq response-code (smtpmail-read-response process))
(throw 'done nil)
)
))
-
+
;; DATA
(smtpmail-send-command process "DATA")
; (>= (car response-code) 400))
; (throw 'done nil)
; )
- (delete-process process))))))
+ (delete-process process)
+ (unless smtpmail-debug-info
+ (kill-buffer process-buffer)))))))
(defun smtpmail-process-filter (process output)
(response-continue t)
(return-value '(nil ()))
match-end)
-
- (while response-continue
- (goto-char smtpmail-read-point)
- (while (not (search-forward "\r\n" nil t))
- (accept-process-output process)
- (goto-char smtpmail-read-point))
-
- (setq match-end (point))
- (setq response-strings
- (cons (buffer-substring smtpmail-read-point (- match-end 2))
- response-strings))
-
- (goto-char smtpmail-read-point)
- (if (looking-at "[0-9]+ ")
- (let ((begin (match-beginning 0))
- (end (match-end 0)))
- (if smtpmail-debug-info
- (message "%s" (car response-strings)))
-
- (setq smtpmail-read-point match-end)
-
- ;; ignore lines that start with "0"
- (if (looking-at "0[0-9]+ ")
- nil
+ (catch 'done
+ (while response-continue
+ (goto-char smtpmail-read-point)
+ (while (not (search-forward "\r\n" nil t))
+ (unless (memq (process-status process) '(open run))
+ (throw 'done nil))
+ (accept-process-output process)
+ (goto-char smtpmail-read-point))
+
+ (setq match-end (point))
+ (setq response-strings
+ (cons (buffer-substring smtpmail-read-point (- match-end 2))
+ response-strings))
+
+ (goto-char smtpmail-read-point)
+ (if (looking-at "[0-9]+ ")
+ (let ((begin (match-beginning 0))
+ (end (match-end 0)))
+ (if smtpmail-debug-info
+ (message "%s" (car response-strings)))
+
+ (setq smtpmail-read-point match-end)
+
+ ;; ignore lines that start with "0"
+ (if (looking-at "0[0-9]+ ")
+ nil
+ (setq response-continue nil)
+ (setq return-value
+ (cons (string-to-int
+ (buffer-substring begin end))
+ (nreverse response-strings)))))
+
+ (if (looking-at "[0-9]+-")
+ (progn (if smtpmail-debug-info
+ (message "%s" (car response-strings)))
+ (setq smtpmail-read-point match-end)
+ (setq response-continue t))
+ (progn
+ (setq smtpmail-read-point match-end)
(setq response-continue nil)
(setq return-value
- (cons (string-to-int
- (buffer-substring begin end))
- (nreverse response-strings)))))
-
- (if (looking-at "[0-9]+-")
- (progn (if smtpmail-debug-info
- (message "%s" (car response-strings)))
- (setq smtpmail-read-point match-end)
- (setq response-continue t))
- (progn
- (setq smtpmail-read-point match-end)
- (setq response-continue nil)
- (setq return-value
- (cons nil (nreverse response-strings)))
- )
- )))
- (setq smtpmail-read-point match-end)
+ (cons nil (nreverse response-strings)))))))
+ (setq smtpmail-read-point match-end))
return-value))
smtpmail-code-conv-from)
(setq data (string-as-multibyte
(encode-coding-string data smtpmail-code-conv-from))))
-
+
(if smtpmail-debug-info
(insert data "\r\n"))
)
(defun smtpmail-send-data (process buffer)
- (let
- ((data-continue t)
- (sending-data nil)
- this-line
- this-line-end)
-
+ (let ((data-continue t) sending-data)
(with-current-buffer buffer
(goto-char (point-min)))
-
(while data-continue
(with-current-buffer buffer
- (beginning-of-line)
- (setq this-line (point))
- (end-of-line)
- (setq this-line-end (point))
- (setq sending-data nil)
- (setq sending-data (buffer-substring this-line this-line-end))
- (if (/= (forward-line 1) 0)
- (setq data-continue nil)))
-
- (smtpmail-send-data-1 process sending-data)
- )
- )
- )
-
+ (setq sending-data (buffer-substring (point-at-bol) (point-at-eol)))
+ (end-of-line 2)
+ (setq data-continue (not (eobp))))
+ (smtpmail-send-data-1 process sending-data))))
(defun smtpmail-deduce-address-list (smtpmail-text-buffer header-start header-end)
"Get address list suitable for smtp RCPT TO: <address>."
(provide 'smtpmail)
+;;; arch-tag: a76992df-6d71-43b7-9e72-4bacc6c05466
;;; smtpmail.el ends here