Revision: emacs@sv.gnu.org/emacs--unicode--0--patch-46
[bpt/emacs.git] / lisp / mail / rmail.el
index 377cb0e..29f2d95 100644 (file)
@@ -1,7 +1,7 @@
 ;;; rmail.el --- main code of "RMAIL" mail reader for Emacs
 
-;; Copyright (C) 1985,86,87,88,93,94,95,96,97,98,2000,01,2004,2005
-;;             Free Software Foundation, Inc.
+;; Copyright (C) 1985, 1986, 1987, 1988, 1993, 1994, 1995, 1996, 1997, 1998,
+;;   2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
 
 ;; Maintainer: FSF
 ;; Keywords: mail
@@ -20,8 +20,8 @@
 
 ;; 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., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
 
 ;;; Commentary:
 
 (require 'mail-utils)
 (eval-when-compile (require 'mule-util)) ; for detect-coding-with-priority
 
+(defvar deleted-head)
+(defvar font-lock-fontified)
+(defvar mail-abbrev-syntax-table)
+(defvar mail-abbrevs)
+(defvar messages-head)
+(defvar rmail-use-spam-filter)
+(defvar rsf-beep)
+(defvar rsf-sleep-after-message)
+(defvar total-messages)
+
 ; These variables now declared in paths.el.
 ;(defvar rmail-spool-directory "/usr/spool/mail/"
 ;  "This is the name of the directory used by the system mailer for\n\
@@ -108,7 +118,7 @@ Please use `rmail-remote-password' instead."
   :group 'rmail-obsolete)
 
 (defcustom rmail-pop-password-required nil
-  "*Non-nil if a password is required when reading mail from a POP server. 
+  "*Non-nil if a password is required when reading mail from a POP server.
 Please use rmail-remote-password-required instead."
   :type 'boolean
   :group 'rmail-obsolete)
@@ -251,21 +261,33 @@ It is useful to set this variable in the site customization file.")
          "\\|^x400-received:\\|^x400-mts-identifier:\\|^x400-content-type:"
          "\\|^\\(resent-\\|\\)message-id:\\|^summary-line:\\|^resent-date:"
          "\\|^nntp-posting-host:\\|^path:\\|^x-char.*:\\|^x-face:\\|^face:"
-         "\\|^x-mailer:\\|^delivered-to:\\|^lines:\\|^mime-version:"
+         "\\|^x-mailer:\\|^delivered-to:\\|^lines:"
          "\\|^content-transfer-encoding:\\|^x-coding-system:"
          "\\|^return-path:\\|^errors-to:\\|^return-receipt-to:"
-         "\\|^x-sign:\\|^x-beenthere:\\|^x-mailman-version:\\|^x-mailman-copy:"
          "\\|^precedence:\\|^list-help:\\|^list-post:\\|^list-subscribe:"
          "\\|^list-id:\\|^list-unsubscribe:\\|^list-archive:"
-         "\\|^content-type:\\|^content-length:"
-         "\\|^x-attribution:\\|^x-disclaimer:\\|^x-trace:"
-         "\\|^x-complaints-to:\\|^nntp-posting-date:\\|^user-agent"
-         "\\|^importance:\\|^envelope-to:\\|^delivery-date"
-         "\\|^x.*-priority:\\|^x-mimeole:\\|^x-archive:"
-         "\\|^resent-face:\\|^resent-x.*:\\|^resent-organization\\|^resent-openpgp"
-         "\\|^openpgp:\\|^x-request-pgp:\\|^x-original.*:"
-         "\\|^x-virus-scanned:\\|^x-spam-[^s].*:")
+         "\\|^content-length:\\|^nntp-posting-date:\\|^user-agent"
+         "\\|^importance:\\|^envelope-to:\\|^delivery-date\\|^openpgp:"
+         "\\|^mbox-line:\\|^cancel-lock:\\|^DomainKey-Signature:"
+         "\\|^resent-face:\\|^resent-x.*:\\|^resent-organization:\\|^resent-openpgp:"
+
+         "\\|^x-.*:")
   "*Regexp to match header fields that Rmail should normally hide.
+\(See also `rmail-nonignored-headers', which overrides this regexp.)
+This variable is used for reformatting the message header,
+which normally happens once for each message,
+when you view the message for the first time in Rmail.
+To make a change in this variable take effect
+for a message that you have already viewed,
+go to that message and type \\[rmail-toggle-header] twice."
+  :type 'regexp
+  :group 'rmail-headers)
+
+(defcustom rmail-nonignored-headers "^x-spam-status:"
+  "*Regexp to match X header fields that Rmail should show.
+This regexp overrides `rmail-ignored-headers'; if both this regexp
+and that one match a certain header field, Rmail shows the field.
+
 This variable is used for reformatting the message header,
 which normally happens once for each message,
 when you view the message for the first time in Rmail.
@@ -297,8 +319,14 @@ See also `rmail-highlight-face'."
   :type 'regexp
   :group 'rmail-headers)
 
+(defface rmail-highlight
+  '((t :default highlight))
+  "Face to use for highlighting the most important header fields."
+  :group 'rmail-headers
+  :version "22.1")
+
 ;;;###autoload
-(defcustom rmail-highlight-face nil "\
+(defcustom rmail-highlight-face 'rmail-highlight "\
 *Face used by Rmail for highlighting headers."
   :type '(choice (const :tag "Default" nil)
                 face)
@@ -426,6 +454,8 @@ examples:
 
 ;; Some mailers use "Re(2):" or "Re^2:" or "Re: Re:" or "Re[2]:".
 ;; This pattern should catch all the common variants.
+;; rms: I deleted the change to delete tags in square brackets
+;; because they mess up RT tags.
 (defvar rmail-reply-regexp "\\`\\(Re\\(([0-9]+)\\|\\[[0-9]+\\]\\|\\^[0-9]+\\)?: *\\)*"
   "Regexp to delete from Subject line before inserting `rmail-reply-prefix'.")
 
@@ -519,7 +549,11 @@ This is set to nil by default.")
   "*If non-nil, RMAIL uses MIME feature.
 If the value is t, RMAIL automatically shows MIME decoded message.
 If the value is neither t nor nil, RMAIL does not show MIME decoded message
-until a user explicitly requires it."
+until a user explicitly requires it.
+
+Even if the value is non-nil, you can't use MIME feature
+if the feature specified by `rmail-mime-feature' is not available
+in your session."
   :type '(choice (const :tag "on" t)
                 (const :tag "off" nil)
                 (other :tag "when asked" ask))
@@ -571,7 +605,10 @@ LIMIT is the position specifying the end of header.")
 (defvar rmail-mime-feature 'rmail-mime
   "Feature to require to load MIME support in Rmail.
 When starting Rmail, if `rmail-enable-mime' is non-nil,
-this feature is required with `require'.")
+this feature is required with `require'.
+
+The default value is `rmail-mime'.  This feature is provided by
+the rmail-mime package available at <http://www.m17n.org/rmail-mime/>.")
 
 ;;;###autoload
 (defvar rmail-decode-mime-charset t
@@ -662,11 +699,12 @@ The first parenthesized expression should match the MIME-charset name.")
            ;; Use MATCH-ANCHORED to effectively anchor the regexp left side.
            `(,cite-chars
              (,(concat "\\=[ \t]*"
-                       "\\(\\([" cite-prefix "]+[" cite-suffix "]*\\)?"
-                       "\\(" cite-chars "[ \t]*\\)\\)+"
+                       "\\(\\(\\([" cite-prefix "]+[" cite-suffix "]*\\)?"
+                       "\\(" cite-chars "[ \t]*\\)\\)+\\)"
                        "\\(.*\\)")
               (beginning-of-line) (end-of-line)
-              (3 font-lock-comment-face nil t)))
+              (1 font-lock-comment-delimiter-face nil t)
+              (5 font-lock-comment-face nil t)))
            '("^\\(X-[a-z0-9-]+\\|In-reply-to\\|Date\\):.*\\(\n[ \t]+.*\\)*$"
              . font-lock-string-face))))
   "Additional expressions to highlight in Rmail mode.")
@@ -710,8 +748,14 @@ isn't provided."
     (condition-case err
        (require rmail-mime-feature)
       (error
-       (message "Feature `%s' not provided" rmail-mime-feature)
-       (sit-for 1)
+       (display-warning
+       :warning
+       (format "Although MIME support is requested
+by setting `rmail-enable-mime' to non-nil, the required feature
+`%s' (the value of `rmail-mime-feature')
+is not available in the current session.
+So, the MIME support is turned off for the moment." 
+               rmail-mime-feature))
        (setq rmail-enable-mime nil)))))
 
 
@@ -951,6 +995,7 @@ Note:    it means the file has no messages in it.\n\^_")))
   (define-key rmail-mode-map "w"      'rmail-output-body-to-file)
   (define-key rmail-mode-map "x"      'rmail-expunge)
   (define-key rmail-mode-map "."      'rmail-beginning-of-message)
+  (define-key rmail-mode-map "/"      'rmail-end-of-message)
   (define-key rmail-mode-map "<"      'rmail-first-message)
   (define-key rmail-mode-map ">"      'rmail-last-message)
   (define-key rmail-mode-map " "      'scroll-up)
@@ -1095,7 +1140,8 @@ Note:    it means the file has no messages in it.\n\^_")))
 All normal editing commands are turned off.
 Instead, these commands are available:
 
-\\[rmail-beginning-of-message] Move point to front of this message (same as \\[beginning-of-buffer]).
+\\[rmail-beginning-of-message] Move point to front of this message.
+\\[rmail-end-of-message]       Move point to bottom of this message.
 \\[scroll-up]  Scroll to next screen of this message.
 \\[scroll-down]        Scroll to previous screen of this message.
 \\[rmail-next-undeleted-message]       Move to Next non-deleted message.
@@ -1155,7 +1201,7 @@ Instead, these commands are available:
       (when rmail-display-summary
        (rmail-summary))
       (rmail-construct-io-menu))
-    (run-hooks 'rmail-mode-hook)))
+    (run-mode-hooks 'rmail-mode-hook)))
 
 (defun rmail-mode-2 ()
   (kill-all-local-variables)
@@ -1633,7 +1679,7 @@ is non-nil if the user has supplied the password interactively.
            (pass  (match-string 5 file))
            (host  (substring file (or (match-end 2)
                                       (+ 3 (match-end 1))))))
-       
+
        (if (not pass)
            (when rmail-remote-password-required
              (setq got-password (not (rmail-have-password)))
@@ -1651,19 +1697,19 @@ is non-nil if the user has supplied the password interactively.
                (or (string-equal proto "pop") (string-equal proto "imap"))
                supplied-password
                got-password))))
-   
+
    ((string-match "^po:\\([^:]+\\)\\(:\\(.*\\)\\)?" file)
     (let (got-password supplied-password
           (proto "pop")
          (user  (match-string 1 file))
          (host  (match-string 3 file)))
-      
+
       (when rmail-remote-password-required
        (setq got-password (not (rmail-have-password)))
        (setq supplied-password (rmail-get-remote-password nil)))
 
       (list file "pop" supplied-password got-password)))
-   
+
    (t
     (list file nil nil nil))))
 
@@ -1989,7 +2035,7 @@ is non-nil if the user has supplied the password interactively.
                                              header-end t)
                              (let ((beg (point))
                                    (eol (progn (end-of-line) (point))))
-                               (string-to-int (buffer-substring beg eol)))))))
+                               (string-to-number (buffer-substring beg eol)))))))
                 (and size
                      (if (and (natnump size)
                               (<= (+ header-end size) (point-max))
@@ -2180,7 +2226,8 @@ If the optional argument IGNORED-HEADERS is non-nil,
 delete all header fields whose names match that regexp.
 Otherwise, if `rmail-displayed-headers' is non-nil,
 delete all header fields *except* those whose names match that regexp.
-Otherwise, delete all header fields whose names match `rmail-ignored-headers'."
+Otherwise, delete all header fields whose names match `rmail-ignored-headers'
+unless they also match `rmail-nonignored-headers'."
   (when (search-forward "\n\n" nil t)
     (forward-char -1)
     (let ((case-fold-search t)
@@ -2204,15 +2251,17 @@ Otherwise, delete all header fields whose names match `rmail-ignored-headers'."
        (or ignored-headers (setq ignored-headers rmail-ignored-headers))
        (save-restriction
          (narrow-to-region (point-min) (point))
+         (goto-char (point-min))
          (while (and ignored-headers
-                     (progn
-                       (goto-char (point-min))
-                       (re-search-forward ignored-headers nil t)))
+                     (re-search-forward ignored-headers nil t))
            (beginning-of-line)
-           (delete-region (point)
-                          (if (re-search-forward "\n[^ \t]" nil t)
-                              (1- (point))
-                            (point-max)))))))))
+           (if (looking-at rmail-nonignored-headers)
+               (forward-line 1)
+             (delete-region (point)
+                            (save-excursion
+                              (if (re-search-forward "\n[^ \t]" nil t)
+                                  (1- (point))
+                                (point-max)))))))))))
 
 (defun rmail-msg-is-pruned ()
   (rmail-maybe-set-message-counters)
@@ -2603,7 +2652,19 @@ change the invisible header text."
 (defun rmail-beginning-of-message ()
   "Show current message starting from the beginning."
   (interactive)
-  (rmail-show-message rmail-current-message))
+  (let ((rmail-show-message-hook
+        (list (function (lambda ()
+                          (goto-char (point-min)))))))
+    (rmail-show-message rmail-current-message)))
+
+(defun rmail-end-of-message ()
+  "Show bottom of current message."
+  (interactive)
+  (let ((rmail-show-message-hook
+        (list (function (lambda ()
+                          (goto-char (point-max))
+                          (recenter (1- (window-height))))))))
+    (rmail-show-message rmail-current-message)))
 
 (defun rmail-unknown-mail-followup-to ()
   "Handle a \"Mail-Followup-To\" header field with an unknown mailing list.
@@ -2613,7 +2674,7 @@ Ask the user whether to add that list name to `mail-mailing-lists'."
      (let ((mail-followup-to (mail-fetch-field "mail-followup-to" nil t)))
        (when mail-followup-to
         (let ((addresses
-               (split-string 
+               (split-string
                 (mail-strip-quoted-names mail-followup-to)
                 ",[[:space:]]+" t)))
           (dolist (addr addresses)
@@ -2998,13 +3059,14 @@ Interactively, empty argument means use same regexp used last time."
   (interactive
     (let* ((reversep (< (prefix-numeric-value current-prefix-arg) 0))
           (prompt
-           (concat (if reversep "Reverse " "") "Rmail search (regexp): "))
+           (concat (if reversep "Reverse " "") "Rmail search (regexp"))
           regexp)
-      (if rmail-search-last-regexp
-         (setq prompt (concat prompt
-                              "(default "
-                              rmail-search-last-regexp
-                              ") ")))
+      (setq prompt
+           (concat prompt
+                   (if rmail-search-last-regexp
+                       (concat ", default "
+                               rmail-search-last-regexp "): ")
+                     "): ")))
       (setq regexp (read-string prompt))
       (cond ((not (equal regexp ""))
             (setq rmail-search-last-regexp regexp))
@@ -3069,13 +3131,14 @@ Interactively, empty argument means use same regexp used last time."
   (interactive
     (let* ((reversep (>= (prefix-numeric-value current-prefix-arg) 0))
           (prompt
-           (concat (if reversep "Reverse " "") "Rmail search (regexp): "))
+           (concat (if reversep "Reverse " "") "Rmail search (regexp"))
           regexp)
-      (if rmail-search-last-regexp
-         (setq prompt (concat prompt
-                              "(default "
-                              rmail-search-last-regexp
-                              ") ")))
+      (setq prompt
+           (concat prompt
+                   (if rmail-search-last-regexp
+                       (concat ", default "
+                               rmail-search-last-regexp "): ")
+                     "): ")))
       (setq regexp (read-string prompt))
       (cond ((not (equal regexp ""))
             (setq rmail-search-last-regexp regexp))
@@ -3101,25 +3164,52 @@ Interactively, empty argument means use same regexp used last time."
 ;;     (rmail-show-message found))
     found))
 
+(defun rmail-current-subject ()
+  "Return the current subject.
+The subject is stripped of leading and trailing whitespace, and
+of typical reply prefixes such as Re:."
+  (let ((subject (or (mail-fetch-field "Subject") "")))
+    (if (string-match "\\`[ \t]+" subject)
+       (setq subject (substring subject (match-end 0))))
+    (if (string-match rmail-reply-regexp subject)
+       (setq subject (substring subject (match-end 0))))
+    (if (string-match "[ \t]+\\'" subject)
+       (setq subject (substring subject 0 (match-beginning 0))))
+    subject))
+
+(defun rmail-current-subject-regexp ()
+  "Return a regular expression matching the current subject.
+The regular expression matches the subject header line of
+messages about the same subject.  The subject itself is stripped
+of leading and trailing whitespace, of typical reply prefixes
+such as Re: and whitespace within the subject is replaced by a
+regular expression matching whitespace in general in order to
+take into account that subject header lines may include newlines
+and more whitespace.  The returned regular expressions contains
+`rmail-reply-regexp' and ends with a newline."
+  (let ((subject (rmail-current-subject)))
+    ;; If Subject is long, mailers will break it into several lines at
+    ;; arbitrary places, so replace whitespace with a regexp that will
+    ;; match any sequence of spaces, TABs, and newlines.
+    (setq subject (regexp-quote subject))
+    (setq subject
+         (replace-regexp-in-string "[ \t\n]+" "[ \t\n]+" subject t t))
+    (concat "^Subject: "
+           (if (string= "\\`" (substring rmail-reply-regexp 0 2))
+               (substring rmail-reply-regexp 2)
+             rmail-reply-regexp)
+           subject "[ \t]*\n")))
+
 (defun rmail-next-same-subject (n)
   "Go to the next mail message having the same subject header.
 With prefix argument N, do this N times.
 If N is negative, go backwards instead."
   (interactive "p")
-  (let ((subject (mail-fetch-field "Subject"))
+  (let ((search-regexp (rmail-current-subject-regexp))
        (forward (> n 0))
        (i rmail-current-message)
        (case-fold-search t)
-       search-regexp found)
-    (if (string-match "\\`[ \t]+" subject)
-       (setq subject (substring subject (match-end 0))))
-    (if (string-match "Re:[ \t]*" subject)
-       (setq subject (substring subject (match-end 0))))
-    (if (string-match "[ \t]+\\'" subject)
-       (setq subject (substring subject 0 (match-beginning 0))))
-    (setq search-regexp (concat "^Subject: *\\(Re:[ \t]*\\)?"
-                               (regexp-quote subject)
-                               "[ \t]*\n"))
+       found)
     (save-excursion
       (save-restriction
        (widen)
@@ -3315,10 +3405,10 @@ See also user-option `rmail-confirm-expunge'."
          (narrow-to-region (- (buffer-size) omin) (- (buffer-size) omax)))
       (if (not dont-show)
          (rmail-show-message
-          (if (zerop rmail-current-message) 1 nil)
-       (if rmail-enable-mime
-           (goto-char (+ (point-min) opoint))
-         (goto-char (+ (point) opoint))))))))
+          (if (zerop rmail-current-message) 1 nil)))
+      (if rmail-enable-mime
+         (goto-char (+ (point-min) opoint))
+       (goto-char (+ (point) opoint))))))
 
 (defun rmail-expunge ()
   "Erase deleted messages from Rmail file and summary buffer."
@@ -3397,18 +3487,11 @@ use \\[mail-yank-original] to yank the original message into it."
                              (progn (search-forward "\n*** EOOH ***\n")
                                     (beginning-of-line) (point)))))
        (setq from (mail-fetch-field "from")
-             reply-to (or (if just-sender
-                              (mail-fetch-field "mail-reply-to" nil t)
-                            (mail-fetch-field "mail-followup-to" nil t))
+             reply-to (or (mail-fetch-field "mail-reply-to" nil t)
                           (mail-fetch-field "reply-to" nil t)
                           from)
-             cc (and (not just-sender)
-                     ;; mail-followup-to, if given, overrides cc.
-                     (not (mail-fetch-field "mail-followup-to" nil t))
-                     (mail-fetch-field "cc" nil t))
              subject (mail-fetch-field "subject")
              date (mail-fetch-field "date")
-             to (or (mail-fetch-field "to" nil t) "")
              message-id (mail-fetch-field "message-id")
              references (mail-fetch-field "references" nil nil t)
              resent-reply-to (mail-fetch-field "resent-reply-to" nil t)
@@ -3418,7 +3501,16 @@ use \\[mail-yank-original] to yank the original message into it."
 ;;;          resent-subject (mail-fetch-field "resent-subject")
 ;;;          resent-date (mail-fetch-field "resent-date")
 ;;;          resent-message-id (mail-fetch-field "resent-message-id")
-             )))
+             )
+       (unless just-sender
+         (if (mail-fetch-field "mail-followup-to" nil t)
+             ;; If this header field is present, use it instead of the To and CC fields.
+             (setq to (mail-fetch-field "mail-followup-to" nil t))
+           (setq cc (or (mail-fetch-field "cc" nil t) "")
+                 to (or (mail-fetch-field "to" nil t) ""))))
+
+       ))
+
     ;; Merge the resent-to and resent-cc into the to and cc.
     (if (and resent-to (not (equal resent-to "")))
        (if (not (equal to ""))
@@ -3443,7 +3535,11 @@ use \\[mail-yank-original] to yank the original message into it."
      ;; I don't know whether there are other mailers that still
      ;; need the names to be stripped.
 ;;;     (mail-strip-quoted-names reply-to)
-     reply-to
+     ;; Remove unwanted names from reply-to, since Mail-Followup-To
+     ;; header causes all the names in it to wind up in reply-to, not
+     ;; in cc.  But if what's left is an empty list, use the original.
+     (let* ((reply-to-list (rmail-dont-reply-to reply-to)))
+       (if (string= reply-to-list "") reply-to reply-to-list))
      subject
      (rmail-make-in-reply-to-field from date message-id)
      (if just-sender
@@ -4053,7 +4149,6 @@ encoded string (and the same mask) will decode the string."
 
 ;;;;  Desktop support
 
-;;;###autoload
 (defun rmail-restore-desktop-buffer (desktop-buffer-file-name
                                      desktop-buffer-name
                                      desktop-buffer-misc)
@@ -4068,6 +4163,9 @@ encoded string (and the same mask) will decode the string."
       (kill-buffer (current-buffer))
       nil)))
 
+(add-to-list 'desktop-buffer-mode-handlers
+            '(rmail-mode . rmail-restore-desktop-buffer))
+
 (provide 'rmail)
 
 ;;; arch-tag: cff0a950-57fe-4f73-a86e-91ff75afd06c