;;; smtpmail.el --- simple SMTP protocol (RFC 821) for sending mail
-;; Copyright (C) 1995, 1996, 2001, 2002, 2003, 2004, 2005
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1995, 1996, 2001, 2002, 2003, 2004, 2005,
+;; 2006, 2007, 2008 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 2, 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:
(autoload 'netrc-parse "netrc")
(autoload 'netrc-machine "netrc")
(autoload 'netrc-get "netrc")
+(autoload 'password-read "password-cache")
;;;
(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.
-The default value would be \"smtp\" or 25 ."
+ "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.
-If the function (system-name) returns the full internet address,
+ "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.)
: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
- "*Specify if mail is queued (if t) or sent immediately (if nil).
+ "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)
(defcustom smtpmail-starttls-credentials '(("" 25 "" ""))
"Specify STARTTLS keys and certificates for servers.
This is a list of four-element list with `servername' (a string),
-`port' (an integer), `key' (a filename) and `certificate' (a filename)."
+`port' (an integer), `key' (a filename) and `certificate' (a
+filename).
+If you do not have a certificate/key pair, leave the `key' and
+`certificate' fields as `nil'. A key/certificate pair is only
+needed if you want to use X.509 client authenticated
+connections."
:type '(repeat (list (string :tag "Server")
(integer :tag "Port")
(file :tag "Key")
: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"
- "File name of queued mail index,
-This is relative to `smtpmail-queue-dir'.")
+(defcustom smtpmail-queue-index-file "index"
+ "File name of queued mail index.
+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.")
-;;;
-;;;
-;;;
-
(defvar smtpmail-mail-address nil
"Value to use for envelope-from address for mail from ambient buffer.")
(save-excursion
(set-buffer tembuf)
(erase-buffer)
+ ;; 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)
(insert-buffer-substring mailbuf)
(goto-char (point-max))
;; require one newline at the end.
(goto-char (point-min))
(unless (re-search-forward "^Date:" delimline t)
(insert "Date: " (message-make-date) "\n"))
+ ;; Possibly add a MIME header for the current coding system
+ (let (charset)
+ (goto-char (point-min))
+ (and (eq mail-send-nonascii 'mime)
+ (not (re-search-forward "^MIME-version:" delimline t))
+ (progn (skip-chars-forward "\0-\177")
+ (/= (point) (point-max)))
+ smtpmail-code-conv-from
+ (setq charset
+ (coding-system-get smtpmail-code-conv-from
+ 'mime-charset))
+ (goto-char delimline)
+ (insert "MIME-version: 1.0\n"
+ "Content-type: text/plain; charset="
+ (symbol-name charset)
+ "\nContent-Transfer-Encoding: 8bit\n")))
;; Insert an extra newline if we need it to work around
;; Sun's bug that swallows newlines.
(goto-char (1+ delimline))
;; Find and handle any FCC fields.
(goto-char (point-min))
(if (re-search-forward "^FCC:" delimline t)
- (mail-do-fcc delimline))
+ ;; 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)))
(if mail-interactive
(with-current-buffer errbuf
(erase-buffer))))
(make-directory smtpmail-queue-dir t))
(with-current-buffer buffer-data
(erase-buffer)
- (insert-buffer-contents tembuf)
+ (set-buffer-file-coding-system smtpmail-code-conv-from nil t)
+ (insert-buffer-substring tembuf)
(write-file file-data)
(set-buffer buffer-elisp)
(erase-buffer)
(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))))
(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)
+ (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)
(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)))
(netrc-get hostentry "password"))))
(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
(decoded (base64-decode-string challenge))
(hash (rfc2104-hash 'md5 64 16 passwd decoded))
(response (concat (smtpmail-cred-user cred) " " hash))
- (encoded (base64-encode-string response)))
+ ;; Osamu Yamane <yamane@green.ocn.ne.jp>:
+ ;; SMTP auth fails because the SMTP server identifies
+ ;; only the first part of the string (delimited by
+ ;; new line characters) as a response from the
+ ;; client, and the rest as distinct commands.
+
+ ;; 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
+ ;; are taken as a response to the server, and the
+ ;; authentication fails.
+ (encoded (base64-encode-string response t)))
(smtpmail-send-command process (format "%s" encoded))
(if (or (null (car (setq ret (smtpmail-read-response process))))
(not (integerp (car ret)))
(>= (car ret) 400))
(throw 'done nil))
(smtpmail-send-command
- process (base64-encode-string (smtpmail-cred-user cred)))
+ process (base64-encode-string (smtpmail-cred-user cred) t))
(if (or (null (car (setq ret (smtpmail-read-response process))))
(not (integerp (car ret)))
(>= (car ret) 400))
(throw 'done nil))
- (smtpmail-send-command process (base64-encode-string passwd))
+ (smtpmail-send-command process (base64-encode-string passwd t))
(if (or (null (car (setq ret (smtpmail-read-response process))))
(not (integerp (car ret)))
(>= (car ret) 400))
(throw 'done nil)))
((eq mech 'plain)
+ ;; We used to send an empty initial request, and wait for an
+ ;; empty response, and then send the password, but this
+ ;; violate a SHOULD in RFC 2222 paragraph 5.1. Note that this
+ ;; is not sent if the server did not advertise AUTH PLAIN in
+ ;; the EHLO response. See RFC 2554 for more info.
(smtpmail-send-command process
(concat "AUTH PLAIN "
(base64-encode-string
(concat "\0"
(smtpmail-cred-user cred)
"\0"
- passwd))))
+ passwd) t)))
(if (or (null (car (setq ret (smtpmail-read-response process))))
(not (integerp (car ret)))
(not (equal (car ret) 235)))
(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)
(>= (car response-code) 400))
(throw 'done nil)))
(dolist (line (cdr (cdr response-code)))
- (let ((name (mapcar (lambda (s) (intern (downcase s)))
- (split-string (substring line 4) "[ ]"))))
+ (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
+ (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
+ 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
(provide 'smtpmail)
-;;; arch-tag: a76992df-6d71-43b7-9e72-4bacc6c05466
+;; arch-tag: a76992df-6d71-43b7-9e72-4bacc6c05466
;;; smtpmail.el ends here
HCoop / bpt / emacs.git / blobdiff