;;; smtpmail.el --- simple SMTP protocol (RFC 821) for sending mail
-;; Copyright (C) 1995, 1996, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008 Free Software Foundation, Inc.
+;; Copyright (C) 1995-1996, 2001-2011 Free Software Foundation, Inc.
;; Author: Tomoji Kagatani <kagatani@rbc.ncl.omron.co.jp>
;; Maintainer: Simon Josefsson <simon@josefsson.org>
;; This file is part of GNU Emacs.
-;; GNU Emacs is free software; you can redistribute it and/or modify
+;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 3, or (at your option)
-;; any later version.
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to the
-;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
-;; Boston, MA 02110-1301, USA.
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; 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
-;; smtpmail-send-queued-mail to send.
+;; 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>,
;; 22/6/99, to support SMTP Authentication by the AUTH=LOGIN mechanism.
;;; Code:
(require 'sendmail)
+(autoload 'starttls-any-program-available "starttls")
(autoload 'starttls-open-stream "starttls")
(autoload 'starttls-negotiate "starttls")
(autoload 'mail-strip-quoted-names "mail-utils")
(autoload 'netrc-parse "netrc")
(autoload 'netrc-machine "netrc")
(autoload 'netrc-get "netrc")
+(autoload 'password-read "password-cache")
+(autoload 'auth-source-user-or-password "auth-source")
;;;
(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
(or (getenv "SMTPSERVER") smtpmail-default-smtp-server)
- "*The name of the host running SMTP server."
+ "The name of the host running SMTP server."
:type '(choice (const nil) string)
:group 'smtpmail)
(defcustom smtpmail-smtp-service 25
- "*SMTP service port number.
+ "SMTP service port number.
The default value would be \"smtp\" or 25."
:type '(choice (integer :tag "Port") (string :tag "Service"))
:group 'smtpmail)
(defcustom smtpmail-local-domain nil
- "*Local domain name without a host name.
+ "Local domain name without a host name.
If the function `system-name' returns the full internet address,
don't define this value."
:type '(choice (const nil) string)
:group 'smtpmail)
(defcustom smtpmail-sendto-domain nil
- "*Local domain name without a host name.
+ "Local domain name without a host name.
This is appended (with an @-sign) to any specified recipients which do
not include an @-sign, so that each RCPT TO address is fully qualified.
\(Some configurations of sendmail require this.)
when sending mail, and the *trace of SMTP session to <somewhere>*
buffer includes an exchange like:
RCPT TO: <someone>
- 501 <someone>: recipient address must contain a domain
-"
+ 501 <someone>: recipient address must contain a domain."
:type '(choice (const nil) string)
:group 'smtpmail)
:type 'boolean
:group 'smtpmail)
-(defcustom smtpmail-code-conv-from nil ;; *junet*
- "*smtpmail code convert from this code to *internal*..for tiny-mime.."
- :type 'boolean
+(defcustom smtpmail-code-conv-from nil
+ "Coding system for encoding outgoing mail.
+Used for the value of `sendmail-coding-system' when
+`select-message-coding-system' is called. "
+ :type 'coding-system
:group 'smtpmail)
(defcustom smtpmail-queue-mail nil
- "*If set, mail is queued; otherwise it is sent immediately.
+ "Non-nil means mail is queued; otherwise it is sent immediately.
If queued, it is stored in the directory `smtpmail-queue-dir'
and sent with `smtpmail-send-queued-mail'."
:type 'boolean
:group 'smtpmail)
(defcustom smtpmail-queue-dir "~/Mail/queued-mail/"
- "*Directory where `smtpmail.el' stores queued mail."
+ "Directory where `smtpmail.el' stores queued mail."
:type 'directory
:group 'smtpmail)
looks like `user@realm'."
:type '(choice file
(repeat (list (string :tag "Server")
- (integer :tag "Port")
- (string :tag "Username")
- (choice (const :tag "Query when needed" nil)
+ (integer :tag "Port")
+ (string :tag "Username")
+ (choice (const :tag "Query when needed" nil)
(string :tag "Password")))))
:version "22.1"
:group 'smtpmail)
:group 'smtpmail)
(defcustom smtpmail-warn-about-unknown-extensions nil
- "*If set, print warnings about unknown SMTP extensions.
+ "If set, print warnings about unknown SMTP extensions.
This is mainly useful for development purposes, to learn about
new SMTP extensions that might be useful to support."
:type 'boolean
:version "21.1"
:group 'smtpmail)
-(defvar smtpmail-queue-index-file "index"
+(defcustom smtpmail-queue-index-file "index"
"File name of queued mail index.
-This is relative to `smtpmail-queue-dir'.")
+This is relative to `smtpmail-queue-dir'."
+ :type 'string
+ :group 'smtpmail)
+
+;; End of customizable variables.
+
(defvar smtpmail-address-buffer)
(defvar smtpmail-recipient-address-list)
;; Buffer-local variable.
(defvar smtpmail-read-point)
-(defvar smtpmail-queue-index (concat smtpmail-queue-dir
- smtpmail-queue-index-file))
-
(defconst smtpmail-auth-supported '(cram-md5 plain login)
- "List of supported SMTP AUTH mechanisms.")
-
-;;;
-;;;
-;;;
+ "List of supported SMTP AUTH mechanisms.
+The list is in preference order.")
(defvar smtpmail-mail-address nil
"Value to use for envelope-from address for mail from ambient buffer.")
(let ((sendmail-coding-system smtpmail-code-conv-from))
(select-message-coding-system)))))
(unwind-protect
- (save-excursion
- (set-buffer tembuf)
+ (with-current-buffer tembuf
(erase-buffer)
- ;; Use the same buffer-file-coding-system as in the mail
- ;; buffer, otherwise any write-region invocations (e.g., in
+ ;; Use the same `buffer-file-coding-system' as in the mail
+ ;; buffer, otherwise any `write-region' invocations (e.g., in
;; mail-do-fcc below) will annoy with asking for a suitable
;; encoding.
(set-buffer-file-coding-system smtpmail-code-conv-from nil t)
;; Change header-delimiter to be what sendmail expects.
(mail-sendmail-undelimit-header)
(setq delimline (point-marker))
-;; (sendmail-synch-aliases)
+ ;; (sendmail-synch-aliases)
(if mail-aliases
(expand-mail-aliases (point-min) delimline))
(goto-char (point-min))
(let ((case-fold-search t))
;; We used to process Resent-... headers here,
;; but it was not done properly, and the job
- ;; is done correctly in smtpmail-deduce-address-list.
+ ;; is done correctly in `smtpmail-deduce-address-list'.
;; Don't send out a blank subject line
(goto-char (point-min))
(if (re-search-forward "^Subject:\\([ \t]*\n\\)+\\b" delimline t)
;; Find and handle any FCC fields.
(goto-char (point-min))
(if (re-search-forward "^FCC:" delimline t)
- ;; Force mail-do-fcc to use the encoding of the mail
+ ;; Force `mail-do-fcc' to use the encoding of the mail
;; buffer to encode outgoing messages on FCC files.
(let ((coding-system-for-write smtpmail-code-conv-from))
(mail-do-fcc delimline)))
(with-current-buffer errbuf
(erase-buffer))))
;;
- ;;
- ;;
(setq smtpmail-address-buffer (generate-new-buffer "*smtp-mail*"))
(setq smtpmail-recipient-address-list
- (smtpmail-deduce-address-list tembuf (point-min) delimline))
+ (smtpmail-deduce-address-list tembuf (point-min) delimline))
(kill-buffer smtpmail-address-buffer)
(smtpmail-do-bcc delimline)
- ; Send or queue
+ ;; Send or queue
(if (not smtpmail-queue-mail)
(if (not (null smtpmail-recipient-address-list))
(if (not (smtpmail-via-smtp
(make-directory smtpmail-queue-dir t))
(with-current-buffer buffer-data
(erase-buffer)
- (set-buffer-file-coding-system smtpmail-code-conv-from nil t)
+ (set-buffer-file-coding-system
+ ;; We will be reading the file with no-conversion in
+ ;; smtpmail-send-queued-mail below, so write it out
+ ;; with Unix EOLs.
+ (coding-system-change-eol-conversion
+ (or smtpmail-code-conv-from 'undecided)
+ 'unix)
+ nil t)
(insert-buffer-substring tembuf)
(write-file file-data)
(set-buffer buffer-elisp)
(insert (concat file-data "\n"))
(append-to-file (point-min)
(point-max)
- smtpmail-queue-index)
- )
+ (expand-file-name smtpmail-queue-index-file
+ smtpmail-queue-dir)))
(kill-buffer buffer-scratch)
(kill-buffer buffer-data)
(kill-buffer buffer-elisp))))
"Send mail that was queued as a result of setting `smtpmail-queue-mail'."
(interactive)
(with-temp-buffer
- ;;; Get index, get first mail, send it, update index, get second
- ;;; mail, send it, etc...
- (let ((file-msg ""))
- (insert-file-contents smtpmail-queue-index)
+ ;; Get index, get first mail, send it, update index, get second
+ ;; mail, send it, etc...
+ (let ((file-msg "")
+ (qfile (expand-file-name smtpmail-queue-index-file
+ smtpmail-queue-dir)))
+ (insert-file-contents qfile)
(goto-char (point-min))
(while (not (eobp))
(setq file-msg (buffer-substring (point) (line-end-position)))
(delete-file file-msg)
(delete-file (concat file-msg ".el"))
(delete-region (point-at-bol) (point-at-bol 2)))
- (write-region (point-min) (point-max) smtpmail-queue-index))))
+ (write-region (point-min) (point-max) qfile))))
-;(defun smtpmail-via-smtp (host,port,sender,destination,smtpmail-text-buffer)
+;; (defun smtpmail-via-smtp (host,port,sender,destination,smtpmail-text-buffer)
(defun smtpmail-fqdn ()
(if smtpmail-local-domain
(defun smtpmail-open-stream (process-buffer host port)
(let ((cred (smtpmail-find-credentials
smtpmail-starttls-credentials host port)))
- (if (null (and cred (condition-case ()
- (with-no-warnings
- (require 'starttls)
- (call-process (if starttls-use-gnutls
- starttls-gnutls-program
- starttls-program)))
- (error nil))))
+ (if (null (and cred (starttls-any-program-available)))
;; The normal case.
(open-network-stream "SMTP" process-buffer host port)
(let* ((cred-key (smtpmail-cred-key cred))
(list "--x509keyfile" cred-key "--x509certfile" cred-cert)))))
(starttls-open-stream "SMTP" process-buffer host port)))))
+;; `password-read' autoloads password-cache.
+(declare-function password-cache-add "password-cache" (key password))
+
(defun smtpmail-try-auth-methods (process supported-extensions host port)
(let* ((mechs (cdr-safe (assoc 'auth supported-extensions)))
- (mech (car (smtpmail-intersection smtpmail-auth-supported mechs)))
- (cred (if (stringp smtpmail-auth-credentials)
- (let* ((netrc (netrc-parse smtpmail-auth-credentials))
- (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)))
+ (mech (car (smtpmail-intersection mechs smtpmail-auth-supported)))
+ (auth-user (auth-source-user-or-password
+ "login" host (or port "smtp")))
+ (auth-pass (auth-source-user-or-password
+ "password" host (or port "smtp")))
+ (cred (if (and auth-user auth-pass) ; try user-auth-* before netrc-*
+ (list host port auth-user auth-pass)
+ ;; else, if auth-source didn't return them...
+ (if (stringp smtpmail-auth-credentials)
+ (let* ((netrc (netrc-parse smtpmail-auth-credentials))
+ (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"))))
+ ;; else, try `smtpmail-find-credentials' since
+ ;; `smtpmail-auth-credentials' is not a string
+ (smtpmail-find-credentials
+ smtpmail-auth-credentials host port))))
+ (prompt (when cred (format "SMTP password for %s:%s: "
+ (smtpmail-cred-server cred)
+ (smtpmail-cred-port cred))))
(passwd (when cred
(or (smtpmail-cred-passwd cred)
- (read-passwd
- (format "SMTP password for %s:%s: "
- (smtpmail-cred-server cred)
- (smtpmail-cred-port cred))))))
+ (password-read prompt prompt))))
ret)
(when (and cred mech)
(cond
;; In my case, the response string is 80 characters
;; long. Without the no-line-break option for
- ;; base64-encode-sting, only the first 76 characters
+ ;; `base64-encode-string', only the first 76 characters
;; are taken as a response to the server, and the
;; authentication fails.
(encoded (base64-encode-string response t)))
(t
(error "Mechanism %s not implemented" mech)))
;; Remember the password.
- (when (and (not (stringp smtpmail-auth-credentials))
- (null (smtpmail-cred-passwd cred)))
- (setcar (cdr (cdr (cdr cred))) passwd)))))
+ (when (null (smtpmail-cred-passwd cred))
+ (password-cache-add prompt passwd)))))
(defun smtpmail-via-smtp (recipient smtpmail-text-buffer)
(let ((process nil)
(host (or smtpmail-smtp-server
(error "`smtpmail-smtp-server' not defined")))
(port smtpmail-smtp-service)
- ;; smtpmail-mail-address should be set to the appropriate
+ ;; `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
(if (or (null (car (setq greeting (smtpmail-read-response process))))
(not (integerp (car greeting)))
(>= (car greeting) 400))
- (throw 'done nil)
- )
+ (throw 'done nil))
(let ((do-ehlo t)
(do-starttls t))
(while do-ehlo
- ;; EHLO
- (smtpmail-send-command process (format "EHLO %s" (smtpmail-fqdn)))
-
- (if (or (null (car (setq response-code
- (smtpmail-read-response process))))
- (not (integerp (car response-code)))
- (>= (car response-code) 400))
- (progn
- ;; HELO
- (smtpmail-send-command
- process (format "HELO %s" (smtpmail-fqdn)))
-
- (if (or (null (car (setq response-code
- (smtpmail-read-response process))))
- (not (integerp (car response-code)))
- (>= (car response-code) 400))
- (throw 'done nil)))
- (dolist (line (cdr (cdr response-code)))
- (let ((name
- (with-case-table ascii-case-table
- (mapcar (lambda (s) (intern (downcase s)))
- (split-string (substring line 4) "[ ]")))))
- (and (eq (length name) 1)
- (setq name (car name)))
- (and 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)))))))
-
- (if (and do-starttls
- (smtpmail-find-credentials smtpmail-starttls-credentials host port)
- (member 'starttls supported-extensions)
- (numberp (process-id process)))
- (progn
- (smtpmail-send-command process (format "STARTTLS"))
- (if (or (null (car (setq response-code (smtpmail-read-response process))))
- (not (integerp (car response-code)))
- (>= (car response-code) 400))
- (throw 'done nil))
- (starttls-negotiate process)
- (setq do-starttls nil))
- (setq do-ehlo nil))))
+ ;; EHLO
+ (smtpmail-send-command process (format "EHLO %s" (smtpmail-fqdn)))
+
+ (if (or (null (car (setq response-code
+ (smtpmail-read-response process))))
+ (not (integerp (car response-code)))
+ (>= (car response-code) 400))
+ (progn
+ ;; HELO
+ (smtpmail-send-command
+ process (format "HELO %s" (smtpmail-fqdn)))
+
+ (if (or (null (car (setq response-code
+ (smtpmail-read-response process))))
+ (not (integerp (car response-code)))
+ (>= (car response-code) 400))
+ (throw 'done nil)))
+ (dolist (line (cdr (cdr response-code)))
+ (let ((name
+ (with-case-table ascii-case-table
+ (mapcar (lambda (s) (intern (downcase s)))
+ (split-string (substring line 4) "[ ]")))))
+ (and (eq (length name) 1)
+ (setq name (car name)))
+ (and 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)))))))
+
+ (if (and do-starttls
+ (smtpmail-find-credentials smtpmail-starttls-credentials host port)
+ (member 'starttls supported-extensions)
+ (numberp (process-id process)))
+ (progn
+ (smtpmail-send-command process (format "STARTTLS"))
+ (if (or (null (car (setq response-code (smtpmail-read-response process))))
+ (not (integerp (car response-code)))
+ (>= (car response-code) 400))
+ (throw 'done nil))
+ (starttls-negotiate process)
+ (setq do-starttls nil))
+ (setq do-ehlo nil))))
(smtpmail-try-auth-methods process supported-extensions host port)
" BODY=8BITMIME"
"")
"")))
-; (smtpmail-send-command process (format "MAIL FROM:%s@%s" (user-login-name) (smtpmail-fqdn)))
+ ;; (smtpmail-send-command process (format "MAIL FROM:%s@%s" (user-login-name) (smtpmail-fqdn)))
(smtpmail-send-command process (format "MAIL FROM:<%s>%s%s"
envelope-from
size-part
(if (or (null (car (setq response-code (smtpmail-read-response process))))
(not (integerp (car response-code)))
(>= (car response-code) 400))
- (throw 'done nil)
- ))
+ (throw 'done nil)))
;; RCPT TO:<recipient>
(let ((n 0))
(if (or (null (car response-code))
(not (integerp (car response-code)))
(>= (car response-code) 400))
- (throw 'done nil)
- )
- ))
+ (throw 'done nil))))
;; DATA
(smtpmail-send-command process "DATA")
(if (or (null (car (setq response-code (smtpmail-read-response process))))
(not (integerp (car response-code)))
(>= (car response-code) 400))
- (throw 'done nil)
- )
+ (throw 'done nil))
;; Mail contents
(smtpmail-send-data process smtpmail-text-buffer)
- ;;DATA end "."
+ ;; DATA end "."
(smtpmail-send-command process ".")
(if (or (null (car (setq response-code (smtpmail-read-response process))))
(not (integerp (car response-code)))
(>= (car response-code) 400))
- (throw 'done nil)
- )
-
- ;;QUIT
-; (smtpmail-send-command process "QUIT")
-; (and (null (car (smtpmail-read-response process)))
-; (throw 'done nil))
- t ))
+ (throw 'done nil))
+
+ ;; QUIT
+ ;; (smtpmail-send-command process "QUIT")
+ ;; (and (null (car (smtpmail-read-response process)))
+ ;; (throw 'done nil))
+ t))
(if process
(with-current-buffer (process-buffer process)
(smtpmail-send-command process "QUIT")
(smtpmail-read-response process)
-; (if (or (null (car (setq response-code (smtpmail-read-response process))))
-; (not (integerp (car response-code)))
-; (>= (car response-code) 400))
-; (throw 'done nil)
-; )
+ ;; (if (or (null (car (setq response-code (smtpmail-read-response process))))
+ ;; (not (integerp (car response-code)))
+ ;; (>= (car response-code) 400))
+ ;; (throw 'done nil))
(delete-process process)
(unless smtpmail-debug-info
(kill-buffer process-buffer)))))))
(if (eq (string-to-char data) ?.)
(process-send-string process "."))
(process-send-string process data)
- (process-send-string process "\r\n")
- )
+ (process-send-string process "\r\n"))
(defun smtpmail-send-data (process buffer)
(let ((data-continue t) sending-data)
(unwind-protect
(with-current-buffer smtpmail-address-buffer
(erase-buffer)
- (let
- ((case-fold-search t)
- (simple-address-list "")
- this-line
- this-line-end
- addr-regexp)
+ (let ((case-fold-search t)
+ (simple-address-list "")
+ this-line
+ this-line-end
+ addr-regexp)
(insert-buffer-substring smtpmail-text-buffer header-start header-end)
(goto-char (point-min))
;; RESENT-* fields should stop processing of regular fields.
(setq this-line-end (point-marker))
(setq simple-address-list
(concat simple-address-list " "
- (mail-strip-quoted-names (buffer-substring this-line this-line-end))))
- )
+ (mail-strip-quoted-names (buffer-substring this-line this-line-end)))))
(erase-buffer)
(insert " " simple-address-list "\n")
- (subst-char-in-region (point-min) (point-max) 10 ? t);; newline --> blank
- (subst-char-in-region (point-min) (point-max) ?, ? t);; comma --> blank
- (subst-char-in-region (point-min) (point-max) 9 ? t);; tab --> blank
+ (subst-char-in-region (point-min) (point-max) 10 ? t) ; newline --> blank
+ (subst-char-in-region (point-min) (point-max) ?, ? t) ; comma --> blank
+ (subst-char-in-region (point-min) (point-max) 9 ? t) ; tab --> blank
(goto-char (point-min))
;; tidyness in case hook is not robust when it looks at this
(while (re-search-forward " \\([^ ]+\\) " (point-max) t)
(backward-char 1)
(setq recipient-address-list (cons (buffer-substring (match-beginning 1) (match-end 1))
- recipient-address-list))
- )
- (setq smtpmail-recipient-address-list recipient-address-list))
-
- )
- )
- )
- )
-
+ recipient-address-list)))
+ (setq smtpmail-recipient-address-list recipient-address-list))))))
(defun smtpmail-do-bcc (header-end)
"Delete [Resent-]BCC: and their continuation lines from the header area.
(while (and (looking-at "^[ \t].*\n") (< (point) header-end))
(replace-match ""))))))
-
(provide 'smtpmail)
-;;; arch-tag: a76992df-6d71-43b7-9e72-4bacc6c05466
;;; smtpmail.el ends here
HCoop / bpt / emacs.git / blobdiff