Merge from emacs--rel--22

[bpt/emacs.git] / lisp / mail / smtpmail.el

diff --git a/lisp/mail/smtpmail.el b/lisp/mail/smtpmail.el
index ac87a93..66c4bdd 100644 (file)
--- 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,
-;;   2006 Free Software Foundation, Inc.
+;;   2006, 2007 Free Software Foundation, Inc.
 
 ;; Author: Tomoji Kagatani <kagatani@rbc.ncl.omron.co.jp>
 ;; Maintainer: Simon Josefsson <simon@josefsson.org>
@@ -99,13 +99,13 @@ This only has effect if you specify it before loading the smtpmail library."
 
 (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)
@@ -145,7 +145,7 @@ The commands enables verbose information from the SMTP server."
   :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
@@ -198,7 +198,7 @@ new SMTP extensions that might be useful to support."
   :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)
@@ -244,6 +244,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.
@@ -326,6 +331,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))
@@ -334,7 +355,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))))
@@ -370,6 +394,7 @@ This is relative to `smtpmail-queue-dir'.")
                (make-directory smtpmail-queue-dir t))
              (with-current-buffer buffer-data
                (erase-buffer)
+               (set-buffer-file-coding-system smtpmail-code-conv-from nil t)
                (insert-buffer-substring tembuf)
                (write-file file-data)
                (set-buffer buffer-elisp)
@@ -666,20 +691,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