;;; 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, 2007 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: mail
(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)
+(defvar tool-bar-map)
+
; 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\
: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)
"\\|^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.
: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)
Called with region narrowed to the message, including headers,
before obeying `rmail-ignored-headers'."
:group 'rmail-headers
- :type 'function)
+ :type '(choice (const nil) function))
(defcustom rmail-automatic-folder-directives nil
"List of directives specifying where to put a message.
;; 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'.")
"*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))
(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
;;;###autoload
(defvar rmail-mime-charset-pattern
- "^content-type:[ ]*text/plain;[ \t\n]*charset=\"?\\([^ \t\n\";]+\\)\"?"
+ (concat "^content-type:[ \t]*text/plain;"
+ "\\(?:[ \t\n]*\\(?:format\\|delsp\\)=\"?[-a-z0-9]+\"?;\\)*"
+ "[ \t\n]*charset=\"?\\([^ \t\n\";]+\\)\"?")
"Regexp to match MIME-charset specification in a header of message.
The first parenthesized expression should match the MIME-charset name.")
(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)))))
(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)
(define-key rmail-mode-map [menu-bar move next]
'("Next" . rmail-next-message))
+
+;; Rmail toolbar
+(defvar rmail-tool-bar-map
+ (if (display-graphic-p)
+ (let ((map (make-sparse-keymap)))
+ (tool-bar-local-item-from-menu 'rmail-get-new-mail "mail/inbox"
+ map rmail-mode-map)
+ (tool-bar-local-item-from-menu 'rmail-next-undeleted-message "right-arrow"
+ map rmail-mode-map)
+ (tool-bar-local-item-from-menu 'rmail-previous-undeleted-message "left-arrow"
+ map rmail-mode-map)
+ (tool-bar-local-item-from-menu 'rmail-search "search"
+ map rmail-mode-map)
+ (tool-bar-local-item-from-menu 'rmail-input "open"
+ map rmail-mode-map)
+ (tool-bar-local-item-from-menu 'rmail-mail "mail/compose"
+ map rmail-mode-map)
+ (tool-bar-local-item-from-menu 'rmail-reply "mail/reply-all"
+ map rmail-mode-map)
+ (tool-bar-local-item-from-menu 'rmail-forward "mail/forward"
+ map rmail-mode-map)
+ (tool-bar-local-item-from-menu 'rmail-delete-forward "close"
+ map rmail-mode-map)
+ (tool-bar-local-item-from-menu 'rmail-output "mail/move"
+ map rmail-mode-map)
+ (tool-bar-local-item-from-menu 'rmail-output-body-to-file "mail/save"
+ map rmail-mode-map)
+ (tool-bar-local-item-from-menu 'rmail-expunge "delete"
+ map rmail-mode-map)
+ map)))
+
+
\f
;; Rmail mode is suitable only for specially formatted data.
(put 'rmail-mode 'mode-class 'special)
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.
(concat rmail-spool-directory
(user-login-name)))))))
(make-local-variable 'rmail-keywords)
+ (set (make-local-variable 'tool-bar-map) rmail-tool-bar-map)
;; this gets generated as needed
(setq rmail-keywords nil))
(if (and (featurep 'rmail-spam-filter)
rmail-use-spam-filter
(> rsf-number-of-spam 0))
- (if (= 1 new-messages)
- ", and found to be a spam message"
- (if (> rsf-number-of-spam 1)
- (format ", %d of which found to be spam messages"
- rsf-number-of-spam)
- ", one of which found to be a spam message"))
+ (cond ((= 1 new-messages)
+ ", and appears to be spam")
+ ((= rsf-number-of-spam new-messages)
+ ", and all appear to be spam")
+ ((> rsf-number-of-spam 1)
+ (format ", and %d appear to be spam"
+ rsf-number-of-spam))
+ (t
+ ", and 1 appears to be spam"))
""))
(if (and (featurep 'rmail-spam-filter)
rmail-use-spam-filter
(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)))
(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))))
(defun rmail-convert-to-babyl-format ()
(let ((count 0) start
(case-fold-search nil)
+ (buffer-undo-list t)
(invalid-input-resync
(function (lambda ()
(message "Invalid Babyl format in inbox!")
;; may still be in use. -- rms, 7 May 1993.
((eolp) (delete-char 1))
(t (error "Cannot convert to babyl format")))))
+ (setq buffer-undo-list nil)
count))
;; Delete the "From ..." line, creating various other headers with
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)
(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)
(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.
(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)
(if blurb
(message blurb))))))
-(defun rmail-redecode-body (coding)
+(defun rmail-redecode-body (coding &optional raw)
"Decode the body of the current message using coding system CODING.
This is useful with mail messages that have malformed or missing
charset= headers.
decode it was incorrect. It then encodes the message back to its
original form, and decodes it again, using the coding system CODING.
+Optional argument RAW, if non-nil, means don't encode the message
+before decoding it with the new CODING. This is useful if the current
+message text was produced by some function which invokes `insert',
+since `insert' leaves unibyte character codes 128 through 255 unconverted
+to multibyte. One example of such a situation is when the text was
+produced by `base64-decode-region'.
+
+Interactively, invoke the function with a prefix argument to set RAW
+non-nil.
+
Note that if Emacs erroneously auto-detected one of the iso-2022
encodings in the message, this function might fail because the escape
sequences that switch between character sets and also single-shift and
(or (eq major-mode 'rmail-mode)
(switch-to-buffer rmail-buffer))
(save-excursion
- (let ((pruned (rmail-msg-is-pruned)))
+ (let ((pruned (rmail-msg-is-pruned))
+ (raw (or raw current-prefix-arg)))
(unwind-protect
(let ((msgbeg (rmail-msgbeg rmail-current-message))
(msgend (rmail-msgend rmail-current-message))
(coding-system-change-eol-conversion
coding
(coding-system-eol-type old-coding)))
+ ;; If old-coding is `undecided', encode-coding-region
+ ;; will not encode the text at all. Find a proper
+ ;; non-trivial encoding to use.
+ (if (memq (coding-system-base old-coding) '(nil undecided))
+ (setq old-coding
+ (car (find-coding-systems-region msgbeg msgend))))
(setq x-coding-header (point-marker))
(narrow-to-region msgbeg msgend)
- (encode-coding-region (point) msgend old-coding)
+ (and (null raw)
+ ;; If old and new encoding are the same, it
+ ;; clearly doesn't make sense to encode.
+ (not (coding-system-equal
+ (coding-system-base old-coding)
+ (coding-system-base coding)))
+ ;; If the body includes only eight-bit-*
+ ;; characters, encoding might fail, e.g. with
+ ;; UTF-8, and isn't needed anyway.
+ (> (length (delq 'ascii
+ (delq 'eight-bit-graphic
+ (delq 'eight-bit-control
+ (find-charset-region
+ msgbeg msgend)))))
+ 0)
+ (encode-coding-region (point) msgend old-coding))
(decode-coding-region (point) msgend coding)
(setq last-coding-system-used coding)
;; Rewrite the coding-system header according
(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))
(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))
;; (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)
(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)
;;; 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 ""))
;;;; Desktop support
-;;;###autoload
(defun rmail-restore-desktop-buffer (desktop-buffer-file-name
desktop-buffer-name
desktop-buffer-misc)
(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
HCoop / bpt / emacs.git / blobdiff