X-Git-Url: http://git.hcoop.net/bpt/emacs.git/blobdiff_plain/bffa514a8b8c947c655b463e8073e8e5ac061bc7..aa3e7364a46695cba2e43a3d8c0a6ccacefd1569:/lisp/mail/smtpmail.el diff --git a/lisp/mail/smtpmail.el b/lisp/mail/smtpmail.el index 1a280ffc7f..c4e31972fe 100644 --- a/lisp/mail/smtpmail.el +++ b/lisp/mail/smtpmail.el @@ -1,7 +1,7 @@ ;;; 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 ;; Maintainer: Simon Josefsson @@ -16,7 +16,7 @@ ;; 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) +;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, @@ -78,6 +78,7 @@ (autoload 'netrc-parse "netrc") (autoload 'netrc-machine "netrc") (autoload 'netrc-get "netrc") +(autoload 'password-read "password-cache") ;;; (defgroup smtpmail nil @@ -86,32 +87,32 @@ (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.) @@ -139,20 +140,22 @@ The commands enables verbose information from the SMTP server." :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) @@ -176,7 +179,12 @@ looks like `user@realm'." (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") @@ -185,16 +193,21 @@ This is a list of four-element list with `servername' (a string), :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) @@ -204,16 +217,9 @@ This is relative to `smtpmail-queue-dir'.") ;; 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.") @@ -239,6 +245,11 @@ This is relative to `smtpmail-queue-dir'.") (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. @@ -321,6 +332,22 @@ This is relative to `smtpmail-queue-dir'.") (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)) @@ -329,7 +356,10 @@ This is relative to `smtpmail-queue-dir'.") ;; 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)))) @@ -365,7 +395,8 @@ This is relative to `smtpmail-queue-dir'.") (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) @@ -378,8 +409,8 @@ This is relative to `smtpmail-queue-dir'.") (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)))) @@ -394,8 +425,10 @@ This is relative to `smtpmail-queue-dir'.") (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))) @@ -417,7 +450,7 @@ This is relative to `smtpmail-queue-dir'.") (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) @@ -502,6 +535,9 @@ This is relative to `smtpmail-queue-dir'.") (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))) @@ -516,12 +552,12 @@ This is relative to `smtpmail-queue-dir'.") (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 @@ -536,7 +572,18 @@ This is relative to `smtpmail-queue-dir'.") (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 : + ;; 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))) @@ -549,27 +596,29 @@ This is relative to `smtpmail-queue-dir'.") (>= (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) - (smtpmail-send-command process "AUTH PLAIN") - (if (or (null (car (setq ret (smtpmail-read-response process)))) - (not (integerp (car ret))) - (not (equal (car ret) 334))) - (throw 'done nil)) - (smtpmail-send-command process (base64-encode-string + ;; 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" - (smtpmail-cred-passwd cred)))) + passwd) t))) (if (or (null (car (setq ret (smtpmail-read-response process)))) (not (integerp (car ret))) (not (equal (car ret) 235))) @@ -578,9 +627,8 @@ This is relative to `smtpmail-queue-dir'.") (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) @@ -605,6 +653,7 @@ This is relative to `smtpmail-queue-dir'.") ;; 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 @@ -647,20 +696,22 @@ This is relative to `smtpmail-queue-dir'.") (>= (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 @@ -974,5 +1025,5 @@ many continuation lines." (provide 'smtpmail) -;;; arch-tag: a76992df-6d71-43b7-9e72-4bacc6c05466 +;; arch-tag: a76992df-6d71-43b7-9e72-4bacc6c05466 ;;; smtpmail.el ends here