;;; smtpmail.el --- simple SMTP protocol (RFC 821) for sending mail
-;; Copyright (C) 1995, 1996, 2001, 2002, 2003, 2004, 2005,
-;; 2006 Free Software Foundation, Inc.
+;; Copyright (C) 1995, 1996, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
+;; 2008, 2009 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:
;;; Code:
+;; This version of `smtpmail.el' should only be used with Emacs 21.
+(if (featurep 'xemacs)
+ (error "Please use `smtpmail.el' from the mail-lib package.")
+ (when (>= emacs-major-version 22)
+ (error "Please use `smtpmail.el' bundled with Emacs.")))
+
(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 'auth-source-user-or-password "auth-source")
;;;
(defgroup smtpmail nil
(defcustom smtpmail-smtp-service 25
"*SMTP service port number.
-The default value would be \"smtp\" or 25 ."
+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,
+If the function `system-name' returns the full internet address,
don't define this value."
:type '(choice (const nil) string)
:group 'smtpmail)
:group 'smtpmail)
(defcustom smtpmail-queue-mail nil
- "*Specify if mail is queued (if t) or sent immediately (if nil).
+ "*If set, 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)
(defvar smtpmail-queue-index-file "index"
- "File name of queued mail index,
+ "File name of queued mail index.
This is relative to `smtpmail-queue-dir'.")
(defvar smtpmail-address-buffer)
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.")
;;;
;;;
(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.
+ ;;
+ ;; This file (`gnus/contrib/smtpmail.el') is only useful for Emacs
+ ;; which doesn't support the third argument (NOMODIFY) of
+ ;; `set-buffer-file-coding-system'.
+ (set-buffer-file-coding-system smtpmail-code-conv-from nil)
+ (set-buffer-modified-p nil)
+ (force-mode-line-update)
(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)
+ (set-buffer-file-coding-system smtpmail-code-conv-from nil)
(insert-buffer-substring tembuf)
(write-file file-data)
(set-buffer buffer-elisp)
(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))
(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
(decoded (base64-decode-string challenge))
(hash (rfc2104-hash 'md5 64 16 passwd decoded))
(response (concat (smtpmail-cred-user cred) " " hash))
+ ;; 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))))
(provide 'smtpmail)
-;;; arch-tag: a76992df-6d71-43b7-9e72-4bacc6c05466
;;; smtpmail.el ends here
projects / gnus / blobdiff