X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fgnus-art.el;h=4e00ea7fd4d5bf5b29bb9e2ebe0686da2480337a;hb=e42093da43ac9af894c2c28f5b62c7256252769e;hp=7ea23272da742e154633f396c55ad3355f83558f;hpb=0d1720aee995af053638966ad6bcf16698575735;p=elisp%2Fgnus.git- diff --git a/lisp/gnus-art.el b/lisp/gnus-art.el index 7ea2327..4e00ea7 100644 --- a/lisp/gnus-art.el +++ b/lisp/gnus-art.el @@ -1,8 +1,10 @@ -;;; gnus-art.el --- article mode commands for Gnus -;; Copyright (C) 1996,97,98 Free Software Foundation, Inc. +;;; gnus-art.el --- article mode commands for Semi-gnus +;; Copyright (C) 1996,97,98,99 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen -;; Keywords: news +;; MORIOKA Tomohiko +;; Katsumi Yamaoka +;; Keywords: mail, news, MIME ;; This file is part of GNU Emacs. @@ -33,18 +35,31 @@ (require 'gnus-spec) (require 'gnus-int) (require 'browse-url) -(require 'mm-bodies) -(require 'mail-parse) -(require 'mm-decode) -(require 'mm-view) -(require 'wid-edit) -(require 'mm-uu) +(require 'alist) +(require 'mime-view) + +;; Avoid byte-compile warnings. +(eval-when-compile + (defvar gnus-article-decoded-p) + (defvar gnus-article-mime-handles) + (require 'mm-bodies) + (require 'mail-parse) + (require 'mm-decode) + (require 'mm-view) + (require 'wid-edit) + (require 'mm-uu) + ) (defgroup gnus-article nil "Article display." :link '(custom-manual "(gnus)The Article Buffer") :group 'gnus) +(defgroup gnus-article-treat nil + "Treating article parts." + :link '(custom-manual "(gnus)Article Hiding") + :group 'gnus-article) + (defgroup gnus-article-hiding nil "Hiding article parts." :link '(custom-manual "(gnus)Article Hiding") @@ -115,7 +130,7 @@ "^X-Pgp-Public-Key-Url:" "^X-Auth:" "^X-From-Line:" "^X-Gnus-Article-Number:" "^X-Majordomo:" "^X-Url:" "^X-Sender:" "^X-Mailing-List:" "^MBOX-Line" "^Priority:" "^X-Pgp" "^X400-[-A-Za-z]+:" - "^Status:") + "^Status:" "^X-Gnus-Mail-Source:" "^Cancel-Lock:") "*All headers that start with this regexp will be hidden. This variable can also be a list of regexps of headers to be ignored. If `gnus-visible-headers' is non-nil, this variable will be ignored." @@ -125,7 +140,7 @@ If `gnus-visible-headers' is non-nil, this variable will be ignored." :group 'gnus-article-hiding) (defcustom gnus-visible-headers - "From:\\|^Newsgroups:\\|^Subject:\\|^Date:\\|^Followup-To:\\|^Reply-To:\\|^Organization:\\|^Summary:\\|^Keywords:\\|^To:\\|^Cc:\\|^Posted-To:\\|^Mail-Copies-To:\\|^Apparently-To:\\|^Gnus-Warning:\\|^Resent-From:\\|X-Sent:" + "^From:\\|^Newsgroups:\\|^Subject:\\|^Date:\\|^Followup-To:\\|^Reply-To:\\|^Organization:\\|^Summary:\\|^Keywords:\\|^To:\\|^[BGF]?Cc:\\|^Posted-To:\\|^Mail-Copies-To:\\|^Apparently-To:\\|^Gnus-Warning:\\|^Resent-From:\\|^X-Sent:" "*All headers that do not match this regexp will be hidden. This variable can also be a list of regexp of headers to remain visible. If this variable is non-nil, `gnus-ignored-headers' will be ignored." @@ -379,6 +394,20 @@ be used as possible file names." (cons :value ("" "") regexp (repeat string)) (sexp :value nil)))) +(defcustom gnus-article-display-method-for-mime + 'gnus-article-display-mime-message + "Function to display a MIME message. +The function is called from the article buffer." + :group 'gnus-article-mime + :type 'function) + +(defcustom gnus-article-display-method-for-traditional + 'gnus-article-display-traditional-message + "*Function to display a traditional message. +The function is called from the article buffer." + :group 'gnus-article-mime + :type 'function) + (defcustom gnus-page-delimiter "^\^L" "*Regexp describing what to use as article page delimiters. The default value is \"^\^L\", which is a form linefeed at the @@ -408,8 +437,7 @@ The following additional specs are available: :group 'gnus-article-various) (defcustom gnus-article-prepare-hook nil - "*A hook called after an article has been prepared in the article buffer. -If you want to run a special decoding program like nkf, use this hook." + "*A hook called after an article has been prepared in the article buffer." :type 'hook :group 'gnus-article-various) @@ -538,8 +566,7 @@ displayed by the first non-nil matching CONTENT face." (item :tag "skip" nil) (face :value default))))) -(defcustom gnus-article-decode-hook - '(article-decode-charset article-decode-encoded-words) +(defcustom gnus-article-decode-hook nil "*Hook run to decode charsets in articles." :group 'gnus-article-headers :type 'hook) @@ -559,7 +586,6 @@ displayed by the first non-nil matching CONTENT face." ("\205" "...") ("\213" "<") ("\214" "OE") - ("\205" "...") ("\221" "`") ("\222" "'") ("\223" "``") @@ -583,26 +609,349 @@ displayed by the first non-nil matching CONTENT face." :group 'gnus-article-mime :type '(repeat regexp)) -(defcustom gnus-treat-body-highlight-signature t - "Highlight the signature." - :group 'gnus-article - :type '(choice (const :tag "Off" nil) - (const :tag "On" t) - (const :tag "Last" last) - (integer :tag "Less") - (sexp :tag "Predicate"))) - (defcustom gnus-article-mime-part-function nil - "Function called with a MIME handle as the argument." + "Function called with a MIME handle as the argument. +This is meant for people who want to do something automatic based +on parts -- for instance, adding Vcard info to a database." :group 'gnus-article-mime :type 'function) +(defcustom gnus-mime-multipart-functions nil + "An alist of MIME types to functions to display them.") + +(defcustom gnus-article-date-lapsed-new-header nil + "Whether the X-Sent and Date headers can coexist. +When using `gnus-treat-date-lapsed', the \"X-Sent:\" header will +either replace the old \"Date:\" header (if this variable is nil), or +be added below it (otherwise)." + :group 'gnus-article-headers + :type 'boolean) + +;;; +;;; The treatment variables +;;; + +(defvar gnus-part-display-hook nil + "Hook called on parts that are to receive treatment.") + +(defvar gnus-article-treat-custom + '(choice (const :tag "Off" nil) + (const :tag "On" t) + (const :tag "Header" head) + (const :tag "Last" last) + (integer :tag "Less") + (sexp :tag "Predicate"))) + +(defvar gnus-article-treat-head-custom + '(choice (const :tag "Off" nil) + (const :tag "Header" head))) + +(defvar gnus-article-treat-types '("text/plain") + "Parts to treat.") + +(defvar gnus-inhibit-treatment nil + "Whether to inhibit treatment.") + +(defcustom gnus-treat-highlight-signature '(or last (typep "text/x-vcard")) + "Highlight the signature. +Valid values are nil, t, `head', `last', an integer or a predicate. +See the manual for details." + :group 'gnus-article-treat + :type gnus-article-treat-custom) +(put 'gnus-treat-highlight-signature 'highlight t) + +(defcustom gnus-treat-buttonize t + "Add buttons. +Valid values are nil, t, `head', `last', an integer or a predicate. +See the manual for details." + :group 'gnus-article-treat + :type gnus-article-treat-custom) +(put 'gnus-treat-buttonize 'highlight t) + +(defcustom gnus-treat-buttonize-head 'head + "Add buttons to the head. +Valid values are nil, t, `head', `last', an integer or a predicate. +See the manual for details." + :group 'gnus-article-treat + :type gnus-article-treat-head-custom) +(put 'gnus-treat-buttonize-head 'highlight t) + +(defcustom gnus-treat-emphasize t + "Emphasize text. +Valid values are nil, t, `head', `last', an integer or a predicate. +See the manual for details." + :group 'gnus-article-treat + :type gnus-article-treat-custom) +(put 'gnus-treat-emphasize 'highlight t) + +(defcustom gnus-treat-strip-cr nil + "Remove carriage returns. +Valid values are nil, t, `head', `last', an integer or a predicate. +See the manual for details." + :group 'gnus-article-treat + :type gnus-article-treat-custom) + +(defcustom gnus-treat-hide-headers 'head + "Hide headers. +Valid values are nil, t, `head', `last', an integer or a predicate. +See the manual for details." + :group 'gnus-article-treat + :type gnus-article-treat-head-custom) + +(defcustom gnus-treat-hide-boring-headers nil + "Hide boring headers. +Valid values are nil, t, `head', `last', an integer or a predicate. +See the manual for details." + :group 'gnus-article-treat + :type gnus-article-treat-head-custom) + +(defcustom gnus-treat-hide-signature nil + "Hide the signature. +Valid values are nil, t, `head', `last', an integer or a predicate. +See the manual for details." + :group 'gnus-article-treat + :type gnus-article-treat-custom) + +(defcustom gnus-treat-fill-article nil + "Fill the article. +Valid values are nil, t, `head', `last', an integer or a predicate. +See the manual for details." + :group 'gnus-article-treat + :type gnus-article-treat-custom) + +(defcustom gnus-treat-hide-citation nil + "Hide cited text. +Valid values are nil, t, `head', `last', an integer or a predicate. +See the manual for details." + :group 'gnus-article-treat + :type gnus-article-treat-custom) + +(defcustom gnus-treat-strip-pgp t + "Strip PGP signatures. +Valid values are nil, t, `head', `last', an integer or a predicate. +See the manual for details." + :group 'gnus-article-treat + :type gnus-article-treat-custom) + +(defcustom gnus-treat-strip-pem nil + "Strip PEM signatures. +Valid values are nil, t, `head', `last', an integer or a predicate. +See the manual for details." + :group 'gnus-article-treat + :type gnus-article-treat-custom) + +(defcustom gnus-treat-strip-banner t + "Strip banners from articles. +The banner to be stripped is specified in the `banner' group parameter. +Valid values are nil, t, `head', `last', an integer or a predicate. +See the manual for details." + :group 'gnus-article-treat + :type gnus-article-treat-custom) + +(defcustom gnus-treat-highlight-headers 'head + "Highlight the headers. +Valid values are nil, t, `head', `last', an integer or a predicate. +See the manual for details." + :group 'gnus-article-treat + :type gnus-article-treat-head-custom) +(put 'gnus-treat-highlight-headers 'highlight t) + +(defcustom gnus-treat-highlight-citation t + "Highlight cited text. +Valid values are nil, t, `head', `last', an integer or a predicate. +See the manual for details." + :group 'gnus-article-treat + :type gnus-article-treat-custom) +(put 'gnus-treat-highlight-citation 'highlight t) + +(defcustom gnus-treat-date-ut nil + "Display the Date in UT (GMT). +Valid values are nil, t, `head', `last', an integer or a predicate. +See the manual for details." + :group 'gnus-article-treat + :type gnus-article-treat-head-custom) + +(defcustom gnus-treat-date-local nil + "Display the Date in the local timezone. +Valid values are nil, t, `head', `last', an integer or a predicate. +See the manual for details." + :group 'gnus-article-treat + :type gnus-article-treat-head-custom) + +(defcustom gnus-treat-date-lapsed nil + "Display the Date header in a way that says how much time has elapsed. +Valid values are nil, t, `head', `last', an integer or a predicate. +See the manual for details." + :group 'gnus-article-treat + :type gnus-article-treat-head-custom) + +(defcustom gnus-treat-date-original nil + "Display the date in the original timezone. +Valid values are nil, t, `head', `last', an integer or a predicate. +See the manual for details." + :group 'gnus-article-treat + :type gnus-article-treat-head-custom) + +(defcustom gnus-treat-date-iso8601 nil + "Display the date in the ISO8601 format. +Valid values are nil, t, `head', `last', an integer or a predicate. +See the manual for details." + :group 'gnus-article-treat + :type gnus-article-treat-head-custom) + +(defcustom gnus-treat-date-user-defined nil + "Display the date in a user-defined format. +The format is defined by the `gnus-article-time-format' variable. +Valid values are nil, t, `head', `last', an integer or a predicate. +See the manual for details." + :group 'gnus-article-treat + :type gnus-article-treat-head-custom) + +(defcustom gnus-treat-strip-headers-in-body t + "Strip the X-No-Archive header line from the beginning of the body. +Valid values are nil, t, `head', `last', an integer or a predicate. +See the manual for details." + :group 'gnus-article-treat + :type gnus-article-treat-custom) + +(defcustom gnus-treat-strip-trailing-blank-lines nil + "Strip trailing blank lines. +Valid values are nil, t, `head', `last', an integer or a predicate. +See the manual for details." + :group 'gnus-article-treat + :type gnus-article-treat-custom) + +(defcustom gnus-treat-strip-leading-blank-lines nil + "Strip leading blank lines. +Valid values are nil, t, `head', `last', an integer or a predicate. +See the manual for details." + :group 'gnus-article-treat + :type gnus-article-treat-custom) + +(defcustom gnus-treat-strip-multiple-blank-lines nil + "Strip multiple blank lines. +Valid values are nil, t, `head', `last', an integer or a predicate. +See the manual for details." + :group 'gnus-article-treat + :type gnus-article-treat-custom) + +(defcustom gnus-treat-strip-blank-lines nil + "Strip all blank lines. +Valid values are nil, t, `head', `last', an integer or a predicate. +See the manual for details." + :group 'gnus-article-treat + :type gnus-article-treat-custom) + +(defcustom gnus-treat-overstrike t + "Treat overstrike highlighting. +Valid values are nil, t, `head', `last', an integer or a predicate. +See the manual for details." + :group 'gnus-article-treat + :type gnus-article-treat-custom) +(put 'gnus-treat-overstrike 'highlight t) + +(defcustom gnus-treat-display-xface (if (and gnus-xemacs (featurep 'xface)) + 'head nil) + "Display X-Face headers. +Valid values are nil, t, `head', `last', an integer or a predicate. +See the manual for details." + :group 'gnus-article-treat + :type gnus-article-treat-head-custom) +(put 'gnus-treat-display-xface 'highlight t) + +(defcustom gnus-treat-display-smileys (if (and gnus-xemacs + (featurep 'xpm)) + t nil) + "Display smileys. +Valid values are nil, t, `head', `last', an integer or a predicate. +See the manual for details." + :group 'gnus-article-treat + :type gnus-article-treat-custom) +(put 'gnus-treat-display-smileys 'highlight t) + +(defcustom gnus-treat-display-picons (if gnus-xemacs 'head nil) + "Display picons. +Valid values are nil, t, `head', `last', an integer or a predicate. +See the manual for details." + :group 'gnus-article-treat + :type gnus-article-treat-head-custom) +(put 'gnus-treat-display-picons 'highlight t) + +(defcustom gnus-treat-capitalize-sentences nil + "Capitalize sentence-starting words. +Valid values are nil, t, `head', `last', an integer or a predicate. +See the manual for details." + :group 'gnus-article-treat + :type gnus-article-treat-custom) + +(defcustom gnus-treat-fill-long-lines nil + "Fill long lines. +Valid values are nil, t, `head', `last', an integer or a predicate. +See the manual for details." + :group 'gnus-article-treat + :type gnus-article-treat-custom) + +(defcustom gnus-treat-play-sounds nil + "Play sounds. +Valid values are nil, t, `head', `last', an integer or a predicate. +See the manual for details." + :group 'gnus-article-treat + :type gnus-article-treat-custom) + +(defcustom gnus-treat-decode-article-as-default-mime-charset nil + "Decode an article as `default-mime-charset'. For instance, if you want to +attempt to decode an article even if the value of `gnus-show-mime' is nil, +you could set this variable to something like: nil for don't decode, t for +decode the body, '(or header t) for the whole article, etc." + :group 'gnus-article-treat + :type '(radio (const :tag "Off" nil) + (const :tag "Decode body" t) + (const :tag "Decode all" (or head t)))) + ;;; Internal variables +(defvar article-goto-body-goes-to-point-min-p nil) +(defvar gnus-article-wash-types nil) + (defvar gnus-article-mime-handle-alist-1 nil) -(defvar gnus-treatment-function-alist - '((gnus-treat-body-highlight-signature gnus-article-highlight-signature nil) - )) +(defvar gnus-treatment-function-alist + '((gnus-treat-strip-banner gnus-article-strip-banner) + (gnus-treat-strip-headers-in-body gnus-article-strip-headers-in-body) + (gnus-treat-buttonize gnus-article-add-buttons) + (gnus-treat-fill-article gnus-article-fill-cited-article) + (gnus-treat-fill-long-lines gnus-article-fill-long-lines) + (gnus-treat-strip-cr gnus-article-remove-cr) + (gnus-treat-emphasize gnus-article-emphasize) + (gnus-treat-hide-headers gnus-article-maybe-hide-headers) + (gnus-treat-hide-boring-headers gnus-article-hide-boring-headers) + (gnus-treat-hide-signature gnus-article-hide-signature) + (gnus-treat-hide-citation gnus-article-hide-citation) + (gnus-treat-strip-pgp gnus-article-hide-pgp) + (gnus-treat-strip-pem gnus-article-hide-pem) + (gnus-treat-highlight-headers gnus-article-highlight-headers) + (gnus-treat-highlight-citation gnus-article-highlight-citation) + (gnus-treat-highlight-signature gnus-article-highlight-signature) + (gnus-treat-date-ut gnus-article-date-ut) + (gnus-treat-date-local gnus-article-date-local) + (gnus-treat-date-lapsed gnus-article-date-lapsed) + (gnus-treat-date-original gnus-article-date-original) + (gnus-treat-date-user-defined gnus-article-date-user) + (gnus-treat-date-iso8601 gnus-article-date-iso8601) + (gnus-treat-strip-trailing-blank-lines + gnus-article-remove-trailing-blank-lines) + (gnus-treat-strip-leading-blank-lines + gnus-article-strip-leading-blank-lines) + (gnus-treat-strip-multiple-blank-lines + gnus-article-strip-multiple-blank-lines) + (gnus-treat-strip-blank-lines gnus-article-strip-blank-lines) + (gnus-treat-overstrike gnus-article-treat-overstrike) + (gnus-treat-buttonize-head gnus-article-add-buttons-to-head) + (gnus-treat-display-xface gnus-article-display-x-face) + (gnus-treat-display-smileys gnus-smiley-display) + (gnus-treat-display-picons gnus-article-display-picons) + (gnus-treat-play-sounds gnus-earcon-display) + (gnus-treat-decode-article-as-default-mime-charset + gnus-article-decode-article-as-default-mime-charset))) (defvar gnus-article-mime-handle-alist nil) (defvar article-lapsed-timer nil) @@ -635,7 +984,6 @@ Initialized from `text-mode-syntax-table.") (put-text-property (max (1- b) (point-min)) b 'intangible (cddr (memq 'intangible props))))) - (defsubst gnus-article-unhide-text (b e) "Remove hidden text properties from region between B and E." (remove-text-properties b e gnus-hidden-properties) @@ -645,11 +993,14 @@ Initialized from `text-mode-syntax-table.") (defun gnus-article-hide-text-type (b e type) "Hide text of TYPE between B and E." + (push type gnus-article-wash-types) (gnus-article-hide-text b e (cons 'article-type (cons type gnus-hidden-properties)))) (defun gnus-article-unhide-text-type (b e type) "Unhide text of TYPE between B and E." + (setq gnus-article-wash-types + (delq type gnus-article-wash-types)) (remove-text-properties b e (cons 'article-type (cons type gnus-hidden-properties))) (when (memq 'intangible gnus-hidden-properties) @@ -698,79 +1049,75 @@ Initialized from `text-mode-syntax-table.") i)) (defun article-hide-headers (&optional arg delete) - "Toggle whether to hide unwanted headers and possibly sort them as well. -If given a negative prefix, always show; if given a positive prefix, -always hide." + "Hide unwanted headers and possibly sort them as well." (interactive (gnus-article-hidden-arg)) - (current-buffer) + ;; Lars said that this function might be inhibited. (if (gnus-article-check-hidden-text 'headers arg) - ;; Show boring headers as well. - (gnus-article-show-hidden-text 'boring-headers) - ;; This function might be inhibited. - (unless gnus-inhibit-hiding - (save-excursion - (save-restriction - (let ((buffer-read-only nil) - (case-fold-search t) - (props (nconc (list 'article-type 'headers) - gnus-hidden-properties)) - (max (1+ (length gnus-sorted-header-list))) - (ignored (when (not gnus-visible-headers) - (cond ((stringp gnus-ignored-headers) - gnus-ignored-headers) - ((listp gnus-ignored-headers) - (mapconcat 'identity gnus-ignored-headers - "\\|"))))) - (visible - (cond ((stringp gnus-visible-headers) - gnus-visible-headers) - ((and gnus-visible-headers - (listp gnus-visible-headers)) - (mapconcat 'identity gnus-visible-headers "\\|")))) - (inhibit-point-motion-hooks t) - beg) - ;; First we narrow to just the headers. - (widen) - (goto-char (point-min)) - ;; Hide any "From " lines at the beginning of (mail) articles. - (while (looking-at "From ") - (forward-line 1)) - (unless (bobp) - (if delete - (delete-region (point-min) (point)) - (gnus-article-hide-text (point-min) (point) props))) - ;; Then treat the rest of the header lines. - (narrow-to-region - (point) - (if (search-forward "\n\n" nil t) ; if there's a body - (progn (forward-line -1) (point)) - (point-max))) - ;; Then we use the two regular expressions - ;; `gnus-ignored-headers' and `gnus-visible-headers' to - ;; select which header lines is to remain visible in the - ;; article buffer. - (goto-char (point-min)) - (while (re-search-forward "^[^ \t]*:" nil t) - (beginning-of-line) - ;; Mark the rank of the header. - (put-text-property - (point) (1+ (point)) 'message-rank - (if (or (and visible (looking-at visible)) - (and ignored - (not (looking-at ignored)))) - (gnus-article-header-rank) - (+ 2 max))) - (forward-line 1)) - (message-sort-headers-1) - (when (setq beg (text-property-any - (point-min) (point-max) 'message-rank (+ 2 max))) - ;; We make the unwanted headers invisible. - (if delete - (delete-region beg (point-max)) - ;; Suggested by Sudish Joseph . - (gnus-article-hide-text-type beg (point-max) 'headers)) - ;; Work around XEmacs lossage. - (put-text-property (point-min) beg 'invisible nil)))))))) + (progn + ;; Show boring headers as well. + (gnus-article-show-hidden-text 'boring-headers) + (when (eq 1 (point-min)) + (set-window-start (get-buffer-window (current-buffer)) 1))) + (unless gnus-inhibit-hiding + (save-excursion + (save-restriction + (let ((buffer-read-only nil) + (inhibit-read-only t) + (case-fold-search t) + (max (1+ (length gnus-sorted-header-list))) + (ignored (when (not gnus-visible-headers) + (cond ((stringp gnus-ignored-headers) + gnus-ignored-headers) + ((listp gnus-ignored-headers) + (mapconcat 'identity gnus-ignored-headers + "\\|"))))) + (visible + (cond ((stringp gnus-visible-headers) + gnus-visible-headers) + ((and gnus-visible-headers + (listp gnus-visible-headers)) + (mapconcat 'identity gnus-visible-headers "\\|")))) + (inhibit-point-motion-hooks t) + beg) + ;; First we narrow to just the headers. + (article-narrow-to-head) + ;; Hide any "From " lines at the beginning of (mail) articles. + (while (looking-at "From ") + (forward-line 1)) + (unless (bobp) + (if delete + (delete-region (point-min) (point)) + (gnus-article-hide-text (point-min) (point) + (nconc (list 'article-type 'headers) + gnus-hidden-properties)))) + ;; Then treat the rest of the header lines. + ;; Then we use the two regular expressions + ;; `gnus-ignored-headers' and `gnus-visible-headers' to + ;; select which header lines is to remain visible in the + ;; article buffer. + (while (re-search-forward "^[^ \t]*:" nil t) + (beginning-of-line) + ;; Mark the rank of the header. + (put-text-property + (point) (1+ (point)) 'message-rank + (if (or (and visible (looking-at visible)) + (and ignored + (not (looking-at ignored)))) + (gnus-article-header-rank) + (+ 2 max))) + (forward-line 1)) + (message-sort-headers-1) + (when (setq beg (text-property-any + (point-min) (point-max) 'message-rank (+ 2 max))) + ;; We delete or make invisible the unwanted headers. + (if delete + (progn + (add-text-properties + (point-min) (+ 5 (point-min)) + '(article-type headers dummy-invisible t)) + (delete-region beg (point-max))) + (gnus-article-hide-text-type beg (point-max) 'headers)))))))) + ) (defun article-hide-boring-headers (&optional arg) "Toggle hiding of headers that aren't very interesting. @@ -785,14 +1132,14 @@ always hide." (list gnus-boring-article-headers) (inhibit-point-motion-hooks t) elem) - (nnheader-narrow-to-headers) + (article-narrow-to-head) (while list (setq elem (pop list)) (goto-char (point-min)) (cond ;; Hide empty headers. ((eq elem 'empty) - (while (re-search-forward "^[^:]+:[ \t]*\n[^ \t]" nil t) + (while (re-search-forward "^[^: \t]+:[ \t]*\n[^ \t]" nil t) (forward-line -1) (gnus-article-hide-text-type (progn (beginning-of-line) (point)) @@ -821,8 +1168,8 @@ always hide." from reply-to (ignore-errors (equal - (nth 1 (mail-extract-address-components from)) - (nth 1 (mail-extract-address-components reply-to))))) + (nth 1 (funcall gnus-extract-address-components from)) + (nth 1 (funcall gnus-extract-address-components reply-to))))) (gnus-article-hide-header "reply-to")))) ((eq elem 'date) (let ((date (message-fetch-field "date"))) @@ -862,8 +1209,121 @@ always hide." (point-max))) 'boring-headers)))) +(defun article-toggle-headers (&optional arg) + "Toggle hiding of headers. If given a negative prefix, always show; +if given a positive prefix, always hide." + (interactive (gnus-article-hidden-arg)) + (let ((force (when (numberp arg) + (cond ((> arg 0) 'always-hide) + ((< arg 0) 'always-show)))) + (window (get-buffer-window gnus-article-buffer)) + (header-end (point-min)) + header-start field-end field-start + (inhibit-point-motion-hooks t) + (inhibit-read-only t) + buffer-read-only) + (save-restriction + (widen) + (while (and (setq header-start + (text-property-any header-end (point-max) + 'article-treated-header t)) + (setq header-end + (text-property-not-all header-start (point-max) + 'article-treated-header t))) + (setq field-end header-start) + (cond + (;; Hide exposed invisible fields. + (and (not (eq 'always-show force)) + (setq field-start + (text-property-any field-end header-end + 'exposed-invisible-field t))) + (while (and field-start + (setq field-end (text-property-not-all + field-start header-end + 'exposed-invisible-field t))) + (add-text-properties field-start field-end gnus-hidden-properties) + (setq field-start (text-property-any field-end header-end + 'exposed-invisible-field t))) + (put-text-property header-start header-end + 'exposed-invisible-field nil)) + (;; Expose invisible fields. + (and (not (eq 'always-hide force)) + (setq field-start + (text-property-any field-end header-end 'invisible t))) + (while (and field-start + (setq field-end (text-property-not-all + field-start header-end + 'invisible t))) + ;; If the invisible text is not terminated with newline, we + ;; won't expose it. Because it may be created by x-face-mule. + ;; BTW, XEmacs sometimes fail in putting a invisible text + ;; property with `gnus-article-hide-text' (really?). In that + ;; case, the invisible text might be started from the middle of + ;; a line so we will expose the sort of thing. + (when (or (not (or (eq header-start field-start) + (eq ?\n (char-before field-start)))) + (eq ?\n (char-before field-end))) + (remove-text-properties field-start field-end + gnus-hidden-properties) + (put-text-property field-start field-end + 'exposed-invisible-field t)) + (setq field-start (text-property-any field-end header-end + 'invisible t)))) + (;; Hide fields. + (not (eq 'always-show force)) + (narrow-to-region header-start header-end) + (article-hide-headers) + ;; Re-display X-Face image under XEmacs. + (when (and (featurep 'xemacs) + (gnus-functionp gnus-article-x-face-command)) + (let ((func (cadr (assq 'gnus-treat-display-xface + gnus-treatment-function-alist))) + (condition 'head)) + (when (and func + (gnus-treat-predicate gnus-treat-display-xface)) + (funcall func) + (put-text-property header-start header-end 'read-only nil)))) + (widen)) + )) + (goto-char (point-min)) + (when window + (set-window-start window (point-min)))))) + +(defvar gnus-article-normalized-header-length 40 + "Length of normalized headers.") + +(defun article-normalize-headers () + "Make all header lines 40 characters long." + (interactive) + (let ((buffer-read-only nil) + column) + (save-excursion + (save-restriction + (article-narrow-to-head) + (while (not (eobp)) + (cond + ((< (setq column (- (gnus-point-at-eol) (point))) + gnus-article-normalized-header-length) + (end-of-line) + (insert (make-string + (- gnus-article-normalized-header-length column) + ? ))) + ((> column gnus-article-normalized-header-length) + (gnus-put-text-property + (progn + (forward-char gnus-article-normalized-header-length) + (point)) + (gnus-point-at-eol) + 'invisible t)) + (t + ;; Do nothing. + )) + (forward-line 1)))))) + (defun article-treat-dumbquotes () - "Translate M******** sm*rtq**t*s into proper text." + "Translate M******** sm*rtq**t*s into proper text. +Note that this function guesses whether a character is a sm*rtq**t* or +not, so it should only be used interactively." (interactive) (article-translate-strings gnus-article-dumbquotes-map)) @@ -922,30 +1382,42 @@ MAP is an alist where the elements are on the form (\"from\" \"to\")." (put-text-property (point) (1+ (point)) 'face 'underline))))))))) -(defun article-fill () - "Format too long lines." +(defun article-fill-long-lines () + "Fill lines that are wider than the window width." (interactive) (save-excursion - (let ((buffer-read-only nil)) - (widen) + (let ((buffer-read-only nil) + (width (window-width (get-buffer-window (current-buffer))))) + (save-restriction + (article-goto-body) + (let ((adaptive-fill-mode nil)) + (while (not (eobp)) + (end-of-line) + (when (>= (current-column) (min fill-column width)) + (narrow-to-region (point) (gnus-point-at-bol)) + (fill-paragraph nil) + (goto-char (point-max)) + (widen)) + (forward-line 1))))))) + +(defun article-capitalize-sentences () + "Capitalize the first word in each sentence." + (interactive) + (save-excursion + (let ((buffer-read-only nil) + (paragraph-start "^[\n\^L]")) (article-goto-body) - (end-of-line 1) - (let ((paragraph-start "^[>|#:<;* ]*[ \t]*$") - (adaptive-fill-regexp "[ \t]*\\([|#:<;>*]+ *\\)?") - (adaptive-fill-mode t)) - (while (not (eobp)) - (and (>= (current-column) (min fill-column (window-width))) - (/= (preceding-char) ?:) - (fill-paragraph nil)) - (end-of-line 2)))))) + (while (not (eobp)) + (capitalize-word 1) + (forward-sentence))))) (defun article-remove-cr () - "Translate CRLF pairs into LF, and then CR into LF.." + "Remove trailing CRs and then translate remaining CRs into LFs." (interactive) (save-excursion (let ((buffer-read-only nil)) (goto-char (point-min)) - (while (search-forward "\r$" nil t) + (while (re-search-forward "\r+$" nil t) (replace-match "" t t)) (goto-char (point-min)) (while (search-forward "\r" nil t) @@ -979,7 +1451,8 @@ MAP is an alist where the elements are on the form (\"from\" \"to\")." (case-fold-search t) from last) (save-restriction - (nnheader-narrow-to-headers) + (article-narrow-to-head) + (goto-char (point-min)) (setq from (message-fetch-field "from")) (goto-char (point-min)) (while (and gnus-article-x-face-command @@ -1025,8 +1498,7 @@ MAP is an alist where the elements are on the form (\"from\" \"to\")." (set-buffer gnus-article-buffer) (let ((inhibit-point-motion-hooks t) buffer-read-only - (rfc2047-default-charset gnus-newsgroup-default-charset) - (mm-charset-iso-8859-1-forced gnus-newsgroup-iso-8859-1-forced)) + (mail-parse-charset gnus-newsgroup-charset)) (mail-decode-encoded-word-region (point-min) (point-max))))) (defun article-decode-charset (&optional prompt) @@ -1035,22 +1507,22 @@ If PROMPT (the prefix), prompt for a coding system to use." (interactive "P") (save-excursion (save-restriction - (message-narrow-to-head) + (article-narrow-to-head) (let* ((inhibit-point-motion-hooks t) (case-fold-search t) (ct (message-fetch-field "Content-Type" t)) (cte (message-fetch-field "Content-Transfer-Encoding" t)) - (ctl (and ct (condition-case () - (mail-header-parse-content-type ct) - (error nil)))) + (ctl (and ct (ignore-errors + (mail-header-parse-content-type ct)))) (charset (cond (prompt (mm-read-coding-system "Charset to decode: ")) (ctl (mail-content-type-get ctl 'charset)))) - (rfc2047-default-charset gnus-newsgroup-default-charset) - (mm-charset-iso-8859-1-forced gnus-newsgroup-iso-8859-1-forced) + (mail-parse-charset gnus-newsgroup-charset) buffer-read-only) + (when (memq charset gnus-newsgroup-ignored-charsets) + (setq charset nil)) (goto-char (point-max)) (widen) (forward-line 1) @@ -1065,13 +1537,12 @@ If PROMPT (the prefix), prompt for a coding system to use." (defun article-decode-encoded-words () "Remove encoded-word encoding from headers." - (let ((inhibit-point-motion-hooks t) - buffer-read-only - (rfc2047-default-charset gnus-newsgroup-default-charset) - (mm-charset-iso-8859-1-forced gnus-newsgroup-iso-8859-1-forced)) - (save-restriction - (message-narrow-to-head) - (funcall gnus-decode-header-function (point-min) (point-max))))) + (let (buffer-read-only) + (let ((charset (save-excursion + (set-buffer gnus-summary-buffer) + default-mime-charset))) + (mime-decode-header-in-buffer charset) + ))) (defun article-de-quoted-unreadable (&optional force) "Translate a quoted-printable-encoded article. @@ -1081,9 +1552,7 @@ or not." (save-excursion (let ((buffer-read-only nil) (type (gnus-fetch-field "content-transfer-encoding")) - (charset - (or gnus-newsgroup-default-charset mm-default-coding-system)) - (mm-charset-iso-8859-1-forced gnus-newsgroup-iso-8859-1-forced)) + (charset gnus-newsgroup-charset)) (when (or force (and type (string-match "quoted-printable" (downcase type)))) (article-goto-body) @@ -1093,20 +1562,18 @@ or not." (when charset (mm-decode-body charset))))))) -(defun article-hide-pgp (&optional arg) - "Toggle hiding of any PGP headers and signatures in the current article. -If given a negative prefix, always show; if given a positive prefix, -always hide." - (interactive (gnus-article-hidden-arg)) - (unless (gnus-article-check-hidden-text 'pgp arg) - (save-excursion +(defun article-hide-pgp () + "Remove any PGP headers and signatures in the current article." + (interactive) + (save-excursion + (save-restriction (let ((inhibit-point-motion-hooks t) buffer-read-only beg end) - (widen) - (goto-char (point-min)) + (article-goto-body) ;; Hide the "header". - (when (search-forward "\n-----BEGIN PGP SIGNED MESSAGE-----\n" nil t) - (delete-region (1+ (match-beginning 0)) (match-end 0)) + (when (re-search-forward "^-----BEGIN PGP SIGNED MESSAGE-----\n" nil t) + (push 'pgp gnus-article-wash-types) + (delete-region (match-beginning 0) (match-end 0)) ;; PGP 5 and GNU PG add a `Hash: <>' comment, hide that too (when (looking-at "Hash:.*$") (delete-region (point) (1+ (gnus-point-at-eol)))) @@ -1139,25 +1606,45 @@ always hide." (unless (gnus-article-check-hidden-text 'pem arg) (save-excursion (let (buffer-read-only end) - (widen) (goto-char (point-min)) - ;; hide the horrendously ugly "header". - (and (search-forward "\n-----BEGIN PRIVACY-ENHANCED MESSAGE-----\n" - nil - t) - (setq end (1+ (match-beginning 0))) - (gnus-article-hide-text-type - end - (if (search-forward "\n\n" nil t) - (match-end 0) - (point-max)) - 'pem)) - ;; hide the trailer as well - (and (search-forward "\n-----END PRIVACY-ENHANCED MESSAGE-----\n" - nil - t) - (gnus-article-hide-text-type - (match-beginning 0) (match-end 0) 'pem)))))) + ;; Hide the horrendously ugly "header". + (when (and (search-forward + "\n-----BEGIN PRIVACY-ENHANCED MESSAGE-----\n" + nil t) + (setq end (1+ (match-beginning 0)))) + (push 'pem gnus-article-wash-types) + (gnus-article-hide-text-type + end + (if (search-forward "\n\n" nil t) + (match-end 0) + (point-max)) + 'pem) + ;; Hide the trailer as well + (when (search-forward "\n-----END PRIVACY-ENHANCED MESSAGE-----\n" + nil t) + (gnus-article-hide-text-type + (match-beginning 0) (match-end 0) 'pem))))))) + +(defun article-strip-banner () + "Strip the banner specified by the `banner' group parameter." + (interactive) + (save-excursion + (save-restriction + (let ((inhibit-point-motion-hooks t) + (banner (gnus-group-get-parameter gnus-newsgroup-name 'banner)) + (gnus-signature-limit nil) + buffer-read-only beg end) + (when banner + (article-goto-body) + (cond + ((eq banner 'signature) + (when (gnus-article-narrow-to-signature) + (widen) + (forward-line -1) + (delete-region (point) (point-max)))) + ((stringp banner) + (while (re-search-forward banner nil t) + (delete-region (match-beginning 0) (match-end 0)))))))))) (defun article-hide-signature (&optional arg) "Hide the signature in the current article. @@ -1172,6 +1659,15 @@ always hide." (gnus-article-hide-text-type (point-min) (point-max) 'signature))))))) +(defun article-strip-headers-in-body () + "Strip offensive headers from bodies." + (interactive) + (save-excursion + (article-goto-body) + (let ((case-fold-search t)) + (when (looking-at "x-no-archive:") + (gnus-delete-line))))) + (defun article-strip-leading-blank-lines () "Remove all blank lines from the beginning of the article." (interactive) @@ -1183,13 +1679,29 @@ always hide." (looking-at "[ \t]*$")) (gnus-delete-line)))))) +(defun article-narrow-to-head () + "Narrow the buffer to the head of the message. +Point is left at the beginning of the narrowed-to region." + (narrow-to-region + (goto-char (point-min)) + (if (search-forward "\n\n" nil 1) + (1- (point)) + (point-max))) + (goto-char (point-min))) + (defun article-goto-body () - "Place point at the start of the body." + "Place point at the start of the body." (goto-char (point-min)) - (if (search-forward "\n\n" nil t) - t + (cond + ;; This variable is only bound when dealing with separate + ;; MIME body parts. + (article-goto-body-goes-to-point-min-p + t) + ((search-forward "\n\n" nil t) + t) + (t (goto-char (point-max)) - nil)) + nil))) (defun article-strip-multiple-blank-lines () "Replace consecutive blank lines with one empty line." @@ -1249,7 +1761,6 @@ always hide." (defun gnus-article-narrow-to-signature () "Narrow to the signature; return t if a signature is found, else nil." - (widen) (let ((inhibit-point-motion-hooks t)) (when (gnus-article-search-signature) (forward-line 1) @@ -1290,38 +1801,6 @@ Put point at the beginning of the signature separator." (goto-char cur) nil))) -(eval-and-compile - (autoload 'w3-display "w3-parse") - (autoload 'w3-do-setup "w3" "" t) - (autoload 'w3-region "w3-display" "" t)) - -(defun gnus-article-treat-html () - "Render HTML." - (interactive) - (let ((cbuf (current-buffer))) - (set-buffer gnus-article-buffer) - (let (buf buffer-read-only b e) - (w3-do-setup) - (goto-char (point-min)) - (narrow-to-region - (if (search-forward "\n\n" nil t) - (setq b (point)) - (point-max)) - (setq e (point-max))) - (with-temp-buffer - (insert-buffer-substring gnus-article-buffer b e) - (require 'url) - (save-window-excursion - (w3-region (point-min) (point-max)) - (setq buf (buffer-substring-no-properties (point-min) (point-max))))) - (when buf - (delete-region (point-min) (point-max)) - (insert buf)) - (widen) - (goto-char (point-min)) - (set-window-start (get-buffer-window (current-buffer)) (point-min)) - (set-buffer cbuf)))) - (defun gnus-article-hidden-arg () "Return the current prefix arg as a number, or 0 if no prefix." (list (if current-prefix-arg @@ -1334,7 +1813,6 @@ Arg can be nil or a number. Nil and positive means hide, negative means show, 0 means toggle." (save-excursion (save-restriction - (widen) (let ((hide (gnus-article-hidden-text-p type))) (cond ((or (null arg) @@ -1351,7 +1829,8 @@ means show, 0 means toggle." "Say whether the current buffer contains hidden text of type TYPE." (let ((pos (text-property-any (point-min) (point-max) 'article-type type))) (while (and pos - (not (get-text-property pos 'invisible))) + (not (get-text-property pos 'invisible)) + (not (get-text-property pos 'dummy-invisible))) (setq pos (text-property-any (1+ pos) (point-max) 'article-type type))) (if pos @@ -1389,44 +1868,75 @@ If HIDE, hide the text instead." (defun article-date-ut (&optional type highlight header) "Convert DATE date to universal time in the current article. If TYPE is `local', convert to local time; if it is `lapsed', output -how much time has lapsed since DATE." +how much time has lapsed since DATE. For `lapsed', the value of +`gnus-article-date-lapsed-new-header' says whether the \"X-Sent:\" header +should replace the \"Date:\" one, or should be added below it." (interactive (list 'ut t)) (let* ((header (or header - (mail-header-date gnus-current-headers) + (and (eq 1 (point-min)) + (mail-header-date (save-excursion + (set-buffer gnus-summary-buffer) + gnus-current-headers))) (message-fetch-field "date") "")) (date (if (vectorp header) (mail-header-date header) header)) - (date-regexp "^Date:[ \t]\\|^X-Sent:[ \t]") (inhibit-point-motion-hooks t) - bface eface newline) + bface eface date-pos) (when (and date (not (string= date ""))) (save-excursion (save-restriction - (nnheader-narrow-to-headers) + (article-narrow-to-head) + (when (or (and (eq type 'lapsed) + gnus-article-date-lapsed-new-header + ;; Attempt to get the face of X-Sent first. + (re-search-forward "^X-Sent:[ \t]" nil t)) + (re-search-forward "^Date:[ \t]" nil t) + ;; If Date is missing, try again for X-Sent. + (re-search-forward "^X-Sent:[ \t]" nil t)) + (setq bface (get-text-property (gnus-point-at-bol) 'face) + eface (get-text-property (1- (gnus-point-at-eol)) + 'face))) (let ((buffer-read-only nil)) + ;; Delete any old X-Sent headers. + (when (setq date-pos + (text-property-any (point-min) (point-max) + 'article-date-lapsed t)) + (goto-char (setq date-pos (set-marker (make-marker) date-pos))) + (delete-region (match-beginning 0) + (progn (forward-line 1) (point)))) + (goto-char (point-min)) ;; Delete any old Date headers. - (if (re-search-forward date-regexp nil t) + (while (re-search-forward "^Date:[ \t]" nil t) + (unless date-pos + (setq date-pos (match-beginning 0))) + (unless (and (eq type 'lapsed) + gnus-article-date-lapsed-new-header) + (delete-region (match-beginning 0) + (progn (message-next-header) (point))))) + (if date-pos (progn - (setq bface (get-text-property (gnus-point-at-bol) 'face) - eface (get-text-property (1- (gnus-point-at-eol)) - 'face)) - (delete-region (progn (beginning-of-line) (point)) - (progn (end-of-line) (point))) - (beginning-of-line)) - (goto-char (point-max)) - (setq newline t)) + (goto-char date-pos) + (unless (bolp) + ;; Possibly, Date has been deleted. + (insert "\n")) + (when (and (eq type 'lapsed) + gnus-article-date-lapsed-new-header + (looking-at "Date:")) + (forward-line 1))) + (goto-char (point-min))) (insert (article-make-date-line date type)) + (when (eq type 'lapsed) + (put-text-property (gnus-point-at-bol) (point) + 'article-date-lapsed t)) + (insert "\n") + (forward-line -1) ;; Do highlighting. - (beginning-of-line) (when (looking-at "\\([^:]+\\): *\\(.*\\)$") (put-text-property (match-beginning 1) (1+ (match-end 1)) 'face bface) (put-text-property (match-beginning 2) (match-end 2) - 'face eface)) - (when newline - (end-of-line) - (insert "\n")))))))) + 'face eface)))))))) (defun article-make-date-line (date type) "Return a DATE line of TYPE." @@ -1470,7 +1980,7 @@ how much time has lapsed since DATE." ((eq type 'iso8601) (concat "Date: " - (format-time-string "%Y%M%DT%h%m%s" time))) + (format-time-string "%Y%m%dT%H%M%S" time))) ;; Do an X-Sent lapsed format. ((eq type 'lapsed) ;; If the date is seriously mangled, the timezone functions are @@ -1545,7 +2055,8 @@ function and want to see what the date was before converting." (when (eq major-mode 'gnus-article-mode) (goto-char (point-min)) (when (re-search-forward "^X-Sent:" nil t) - (article-date-lapsed t))))))))) + (article-date-lapsed t)))) + nil 'visible))))) (defun gnus-start-date-timer (&optional n) "Start a timer to update the X-Sent header in the article buffers. @@ -1921,15 +2432,18 @@ If variable `gnus-use-long-file-name' is non-nil, it is (apply ',afunc args)))))))) '(article-hide-headers article-hide-boring-headers + article-toggle-headers article-treat-overstrike - (article-fill . gnus-article-word-wrap) + article-fill-long-lines + article-capitalize-sentences article-remove-cr article-display-x-face article-de-quoted-unreadable - article-mime-decode-quoted-printable article-hide-pgp + article-strip-banner article-hide-pem article-hide-signature + article-strip-headers-in-body article-remove-trailing-blank-lines article-strip-leading-blank-lines article-strip-multiple-blank-lines @@ -1948,6 +2462,7 @@ If variable `gnus-use-long-file-name' is non-nil, it is article-date-lapsed article-emphasize article-treat-dumbquotes + article-normalize-headers (article-show-all . gnus-article-show-all-headers)))) ;;; @@ -1956,17 +2471,20 @@ If variable `gnus-use-long-file-name' is non-nil, it is (put 'gnus-article-mode 'mode-class 'special) -(set-keymap-parent gnus-article-mode-map widget-keymap) - (gnus-define-keys gnus-article-mode-map " " gnus-article-goto-next-page "\177" gnus-article-goto-prev-page [delete] gnus-article-goto-prev-page + [backspace] gnus-article-goto-prev-page "\C-c^" gnus-article-refer-article "h" gnus-article-show-summary "s" gnus-article-show-summary "\C-c\C-m" gnus-article-mail "?" gnus-article-describe-briefly + gnus-mouse-2 gnus-article-push-button + "\r" gnus-article-press-button + "\t" gnus-article-next-button + "\M-\t" gnus-article-prev-button "e" gnus-article-edit "<" beginning-of-buffer ">" end-of-buffer @@ -1979,8 +2497,28 @@ If variable `gnus-use-long-file-name' is non-nil, it is "\M-^" gnus-article-read-summary-keys "\M-g" gnus-article-read-summary-keys) -(substitute-key-definition - 'undefined 'gnus-article-read-summary-keys gnus-article-mode-map) +;; Define almost undefined keys to `gnus-article-read-summary-keys'. +(mapcar + (lambda (key) + (unless (lookup-key gnus-article-mode-map key) + (define-key gnus-article-mode-map key + 'gnus-article-read-summary-keys))) + (delq nil + (append + (mapcar + (lambda (elt) + (let ((key (car elt))) + (and (> (length key) 0) + (not (eq 'menu-bar (aref key 0))) + (symbolp (lookup-key gnus-summary-mode-map key)) + key))) + (accessible-keymaps gnus-summary-mode-map)) + (let ((c 127) + keys) + (while (>= c 32) + (push (char-to-string c) keys) + (decf c)) + keys)))) (defun gnus-article-make-menu-bar () (gnus-turn-off-edit-menu 'article) @@ -1998,12 +2536,11 @@ If variable `gnus-use-long-file-name' is non-nil, it is (easy-menu-define gnus-article-treatment-menu gnus-article-mode-map "" '("Treatment" - ["Hide headers" gnus-article-hide-headers t] + ["Hide headers" gnus-article-toggle-headers t] ["Hide signature" gnus-article-hide-signature t] ["Hide citation" gnus-article-hide-citation t] ["Treat overstrike" gnus-article-treat-overstrike t] - ["Remove carriage return" gnus-article-remove-cr t] - ["Remove quoted-unreadable" gnus-article-de-quoted-unreadable t])) + ["Remove carriage return" gnus-article-remove-cr t])) ;; Note "Commands" menu is defined in gnus-sum.el for consistency @@ -2035,6 +2572,8 @@ commands: (setq mode-name "Article") (setq major-mode 'gnus-article-mode) (make-local-variable 'minor-mode-alist) + (unless (assq 'gnus-show-mime minor-mode-alist) + (push (list 'gnus-show-mime " MIME") minor-mode-alist)) (use-local-map gnus-article-mode-map) (gnus-update-format-specifications nil 'article-mode) (set (make-local-variable 'page-delimiter) gnus-page-delimiter) @@ -2044,11 +2583,11 @@ commands: (make-local-variable 'gnus-article-mime-handles) (make-local-variable 'gnus-article-decoded-p) (make-local-variable 'gnus-article-mime-handle-alist) + (make-local-variable 'gnus-article-washed-types) (gnus-set-default-directory) (buffer-disable-undo) (setq buffer-read-only t) (set-syntax-table gnus-article-mode-syntax-table) - (mm-enable-multibyte) (gnus-run-hooks 'gnus-article-mode-hook)) (defun gnus-article-setup-buffer () @@ -2072,7 +2611,6 @@ commands: ;; Init original article buffer. (save-excursion (set-buffer (gnus-get-buffer-create gnus-original-article-buffer)) - (mm-enable-multibyte) (setq major-mode 'gnus-original-article-mode) (make-local-variable 'gnus-original-article)) (if (get-buffer name) @@ -2105,6 +2643,71 @@ commands: (forward-line line) (point))))) +;;; @@ article filters +;;; + +(defun gnus-article-display-mime-message () + "Article display method for MIME message." + ;; called from `gnus-original-article-buffer'. + (let (charset all-headers) + (with-current-buffer gnus-summary-buffer + (setq charset default-mime-charset + all-headers gnus-have-all-headers)) + (make-local-variable 'default-mime-charset) + (setq default-mime-charset charset) + (with-current-buffer (get-buffer-create gnus-article-buffer) + (make-local-variable 'default-mime-charset) + (setq default-mime-charset charset)) + (mime-display-message mime-message-structure + gnus-article-buffer nil gnus-article-mode-map) + (when all-headers + (gnus-article-hide-headers nil -1)) + ) + ;; `mime-display-message' changes current buffer to `gnus-article-buffer'. + (make-local-variable 'mime-button-mother-dispatcher) + (setq mime-button-mother-dispatcher + (function gnus-article-push-button)) + (run-hooks 'gnus-mime-article-prepare-hook)) + +(defun gnus-article-display-traditional-message () + "Article display method for traditional message." + (set-buffer gnus-article-buffer) + (let (buffer-read-only) + (erase-buffer) + (insert-buffer-substring gnus-original-article-buffer))) + +(defun gnus-article-make-full-mail-header (&optional number charset) + "Create a new mail header structure in a raw article buffer." + (unless (and number charset) + (save-current-buffer + (set-buffer gnus-summary-buffer) + (unless number + (setq number (or (cdr gnus-article-current) 0))) + (unless charset + (setq charset (or default-mime-charset 'x-ctext))))) + (goto-char (point-min)) + (let ((header-end (if (search-forward "\n\n" nil t) + (1- (point)) + (goto-char (point-max)))) + (chars (- (point-max) (point))) + (lines (count-lines (point) (point-max))) + (default-mime-charset charset) + xref) + (narrow-to-region (point-min) header-end) + (setq xref (std11-fetch-field "xref")) + (prog1 + (make-full-mail-header + number + (std11-fetch-field "subject") + (std11-fetch-field "from") + (std11-fetch-field "date") + (std11-fetch-field "message-id") + (std11-fetch-field "references") + chars + lines + (when xref (concat "Xref: " xref))) + (widen)))) + (defun gnus-article-prepare (article &optional all-headers header) "Prepare ARTICLE in article mode buffer. ARTICLE should either be an article number or a Message-ID. @@ -2122,7 +2725,7 @@ If ALL-HEADERS is non-nil, no headers are hidden." result) (save-excursion (gnus-article-setup-buffer) - (set-buffer gnus-article-buffer) + (set-buffer gnus-original-article-buffer) ;; Deactivate active regions. (when (and (boundp 'transient-mark-mode) transient-mark-mode) @@ -2193,8 +2796,6 @@ If ALL-HEADERS is non-nil, no headers are hidden." (when (gnus-visual-p 'article-highlight 'highlight) (gnus-run-hooks 'gnus-visual-mark-article-hook)) ;; Set the global newsgroup variables here. - ;; Suggested by Jim Sisolak - ;; . (gnus-set-global-variables) (setq gnus-have-all-headers (or all-headers gnus-show-all-headers)))) @@ -2210,43 +2811,152 @@ If ALL-HEADERS is non-nil, no headers are hidden." (let ((gnus-article-mime-handle-alist-1 gnus-article-mime-handle-alist)) (gnus-set-mode-line 'article)) - (gnus-configure-windows 'article) (article-goto-body) (set-window-point (get-buffer-window (current-buffer)) (point)) + (gnus-configure-windows 'article) t)))))) +(defun gnus-article-prepare-mime-display (&optional number) + (goto-char (point-min)) + (when (re-search-forward "^[^\t ]+:" nil t) + (goto-char (match-beginning 0))) + (let* ((entity (if (eq 1 (point-min)) + (get-text-property 1 'mime-view-entity) + (get-text-property (point) 'mime-view-entity))) + (number (or number 0)) + next type ids) + (save-restriction + (narrow-to-region (point) + (if (search-forward "\n\n" nil t) + (point) + (point-max))) + (gnus-treat-article 'head) + (put-text-property (point-min) (point-max) 'article-treated-header t) + (goto-char (point-max))) + (while (and (not (eobp)) + entity + (setq next (next-single-property-change (point) + 'mime-view-entity))) + (setq type (mime-entity-content-type entity) + type (format "%s/%s" + (mime-content-type-primary-type type) + (mime-content-type-subtype type))) + (if (string-equal type "message/rfc822") + (save-restriction + (narrow-to-region (point) (point-max)) + (gnus-article-prepare-mime-display number) + (goto-char (point-max))) + (setq ids (length (mime-entity-node-id entity)) + entity (get-text-property next 'mime-view-entity) + number (1+ number)) + (save-restriction + (narrow-to-region (point) next) + (if (or (null entity) + (< (length (mime-entity-node-id entity)) ids)) + (gnus-treat-article 'last number number type) + (gnus-treat-article t number nil type)) + (goto-char (point-max))))) + (unless (eobp) + (save-restriction + (narrow-to-region (point) (point-max)) + (if entity + (progn + (setq type (mime-entity-content-type entity) + type (format "%s/%s" + (mime-content-type-primary-type type) + (mime-content-type-subtype type))) + (if (string-equal type "message/rfc822") + (gnus-article-prepare-mime-display number) + (incf number) + (gnus-treat-article 'last number number type))) + (gnus-treat-article t)))))) + +;;;###autoload (defun gnus-article-prepare-display () "Make the current buffer look like a nice article." - ;; Hooks for getting information from the article. - ;; This hook must be called before being narrowed. - (let ((gnus-article-buffer (current-buffer)) + (gnus-run-hooks 'gnus-tmp-internal-hook) + (gnus-run-hooks 'gnus-article-prepare-hook) + ;; Display message. + (let (mime-display-header-hook) + (funcall (if gnus-show-mime + (progn + (setq mime-message-structure gnus-current-headers) + (mime-buffer-entity-set-buffer-internal + mime-message-structure + gnus-original-article-buffer) + (mime-entity-set-representation-type-internal + mime-message-structure 'mime-buffer-entity) + (luna-send mime-message-structure + 'initialize-instance + mime-message-structure) + gnus-article-display-method-for-mime) + gnus-article-display-method-for-traditional))) + ;; Associate this article with the current summary buffer. + (setq gnus-article-current-summary gnus-summary-buffer) + ;; Call the treatment functions. + (let ((inhibit-read-only t) buffer-read-only) - (unless (eq major-mode 'gnus-article-mode) - (gnus-article-mode)) - (setq buffer-read-only nil) - (gnus-run-hooks 'gnus-tmp-internal-hook) - (gnus-run-hooks 'gnus-article-prepare-hook) - (when gnus-display-mime-function - (let ((url-standalone-mode (not gnus-plugged))) - (funcall gnus-display-mime-function))) - ;; Perform the article display hooks. - (gnus-run-hooks 'gnus-article-display-hook))) + (save-restriction + (widen) + (if gnus-show-mime + (gnus-article-prepare-mime-display) + (narrow-to-region (goto-char (point-min)) + (if (search-forward "\n\n" nil t) + (point) + (point-max))) + (gnus-treat-article 'head) + (put-text-property (point-min) (point-max) 'article-treated-header t) + (goto-char (point-max)) + (widen) + (narrow-to-region (point) (point-max)) + (gnus-treat-article t)) + (put-text-property (point-min) (point-max) 'read-only nil))) + ;; Perform the article display hooks. Incidentally, this hook is + ;; an obsolete variable by now. + (gnus-run-hooks 'gnus-article-display-hook)) + +(defun gnus-article-decode-article-as-default-mime-charset () + "Decode an article as `default-mime-charset'. It won't work if the +value of the variable `gnus-show-mime' is non-nil." + (unless gnus-show-mime + (decode-mime-charset-region (point-min) (point-max) + (with-current-buffer gnus-summary-buffer + default-mime-charset)))) + +(autoload 'x-face-mule-x-face-decode-message-header "x-face-mule") + +(defun gnus-article-display-x-face-with-x-face-mule (&rest args) + "Decode and show X-Face with the function +`x-face-mule-x-face-decode-message-header'. The buffer is expected to be +narrowed to just the headers of the article." + (when (featurep 'xemacs) + (error "`%s' won't work under XEmacs." + 'gnus-article-display-x-face-with-x-face-mule)) + (when window-system + (condition-case err + (x-face-mule-x-face-decode-message-header) + (error (error "%s" + (if (featurep 'x-face-mule) + "Please install x-face-mule 0.24 or later." + err)))))) ;;; ;;; Gnus MIME viewing functions ;;; -(defvar gnus-mime-button-line-format "%{%([%p. %t%d%n]%)%}%e\n" +(defvar gnus-mime-button-line-format "%{%([%p. %d%T]%)%}%e\n" "The following specs can be used: %t The MIME type +%T MIME type, along with additional info %n The `name' parameter %d The description, if any %l The length of the encoded part -%p The part identifier +%p The part identifier number %e Dots if the part isn't displayed") (defvar gnus-mime-button-line-format-alist '((?t gnus-tmp-type ?s) + (?T gnus-tmp-type-long ?s) (?n gnus-tmp-name ?s) (?d gnus-tmp-description ?s) (?p gnus-tmp-id ?s) @@ -2255,11 +2965,11 @@ If ALL-HEADERS is non-nil, no headers are hidden." (defvar gnus-mime-button-commands '((gnus-article-press-button "\r" "Toggle Display") - ;(gnus-mime-view-part "\M-\r" "View Interactively...") (gnus-mime-view-part "v" "View Interactively...") (gnus-mime-save-part "o" "Save...") (gnus-mime-copy-part "c" "View As Text, In Other Buffer") (gnus-mime-inline-part "i" "View As Text, In This Buffer") + (gnus-mime-internalize-part "E" "View Internally") (gnus-mime-externalize-part "e" "View Externally") (gnus-mime-pipe-part "|" "Pipe To Command..."))) @@ -2273,7 +2983,7 @@ If ALL-HEADERS is non-nil, no headers are hidden." (setq gnus-mime-button-map (make-sparse-keymap)) (set-keymap-parent gnus-mime-button-map gnus-article-mode-map) (define-key gnus-mime-button-map gnus-mouse-2 'gnus-article-push-button) - (define-key gnus-mime-button-map gnus-mouse-3 'gnus-mime-button-menu) + (define-key gnus-mime-button-map gnus-down-mouse-3 'gnus-mime-button-menu) (mapcar (lambda (c) (define-key gnus-mime-button-map (cadr c) (car c))) gnus-mime-button-commands)) @@ -2281,28 +2991,29 @@ If ALL-HEADERS is non-nil, no headers are hidden." (defun gnus-mime-button-menu (event) "Construct a context-sensitive menu of MIME commands." (interactive "e") - (gnus-article-check-buffer) - (let ((response (x-popup-menu - t `("MIME Part" - ("" ,@(mapcar (lambda (c) - (cons (caddr c) (car c))) - gnus-mime-button-commands))))) - (pos (event-start event))) - (when response + (save-excursion + (let ((pos (event-start event))) (set-buffer (window-buffer (posn-window pos))) (goto-char (posn-point pos)) - (funcall response)))) - -(defun gnus-mime-view-all-parts () + (gnus-article-check-buffer) + (let ((response (x-popup-menu + t `("MIME Part" + ("" ,@(mapcar (lambda (c) + (cons (caddr c) (car c))) + gnus-mime-button-commands)))))) + (if response + (funcall response)))))) + +(defun gnus-mime-view-all-parts (&optional handles) "View all the MIME parts." (interactive) (save-current-buffer (set-buffer gnus-article-buffer) - (let ((handles gnus-article-mime-handles) - (rfc2047-default-charset gnus-newsgroup-default-charset) - (mm-charset-iso-8859-1-forced gnus-newsgroup-iso-8859-1-forced)) - (while handles - (mm-display-part (pop handles)))))) + (let ((handles (or handles gnus-article-mime-handles)) + (mail-parse-charset gnus-newsgroup-charset)) + (if (stringp (car handles)) + (gnus-mime-view-all-parts (cdr handles)) + (mapcar 'mm-display-part handles))))) (defun gnus-mime-save-part () "Save the MIME part under point." @@ -2322,9 +3033,7 @@ If ALL-HEADERS is non-nil, no headers are hidden." "Interactively choose a view method for the MIME part under point." (interactive) (gnus-article-check-buffer) - (let ((data (get-text-property (point) 'gnus-data)) - ;(url-standalone-mode (not gnus-plugged)) - ) + (let ((data (get-text-property (point) 'gnus-data))) (mm-interactively-view-part data))) (defun gnus-mime-copy-part (&optional handle) @@ -2332,47 +3041,59 @@ If ALL-HEADERS is non-nil, no headers are hidden." (interactive) (gnus-article-check-buffer) (let* ((handle (or handle (get-text-property (point) 'gnus-data))) - (contents (mm-get-part handle)) - (buffer (generate-new-buffer - (file-name-nondirectory - (or - (mail-content-type-get (mm-handle-type handle) 'name) - (mail-content-type-get (mm-handle-type handle) - 'filename) - "*decoded*"))))) + (contents (mm-get-part handle))| + (base (file-name-nondirectory + (or + (mail-content-type-get (mm-handle-type handle) 'name) + (mail-content-type-get (mm-handle-type handle) + 'filename) + "*decoded*"))) + (buffer (generate-new-buffer base))) (switch-to-buffer buffer) (insert contents) - (normal-mode) + ;; We do it this way to make `normal-mode' set the appropriate mode. + (unwind-protect + (progn + (setq buffer-file-name (expand-file-name base)) + (normal-mode)) + (setq buffer-file-name nil)) (goto-char (point-min)))) -(defun gnus-mime-inline-part (&optional charset) +(defun gnus-mime-inline-part (&optional handle) "Insert the MIME part under point into the current buffer." - (interactive "P") ; For compatibility reasons we are not using "z". + (interactive) (gnus-article-check-buffer) - (let* ((data (get-text-property (point) 'gnus-data)) - (contents (mm-get-part data)) - ;(url-standalone-mode (not gnus-plugged)) + (let* ((handle (or handle (get-text-property (point) 'gnus-data))) + contents (b (point)) buffer-read-only) - (if (mm-handle-undisplayer data) - (mm-remove-part data) + (if (mm-handle-undisplayer handle) + (mm-remove-part handle) + (setq contents (mm-get-part handle)) (forward-line 2) - (when charset - (unless (symbolp charset) - (setq charset (mm-read-coding-system "Charset: "))) - (setq contents (mm-decode-coding-string contents charset))) - (mm-insert-inline data contents) + (mm-insert-inline handle contents) (goto-char b)))) (defun gnus-mime-externalize-part (&optional handle) - "Insert the MIME part under point into the current buffer." + "View the MIME part under point with an external viewer." (interactive) (gnus-article-check-buffer) (let* ((handle (or handle (get-text-property (point) 'gnus-data))) - ;(url-standalone-mode (not gnus-plugged)) (mm-user-display-methods nil) - (rfc2047-default-charset gnus-newsgroup-default-charset) - (mm-charset-iso-8859-1-forced gnus-newsgroup-iso-8859-1-forced)) + (mm-all-images-fit t) + (mail-parse-charset gnus-newsgroup-charset)) + (if (mm-handle-undisplayer handle) + (mm-remove-part handle) + (mm-display-part handle)))) + +(defun gnus-mime-internalize-part (&optional handle) + "View the MIME part under point with an internal viewer." + (interactive) + (gnus-article-check-buffer) + (let* ((handle (or handle (get-text-property (point) 'gnus-data))) + (mm-user-display-methods '((".*" . inline))) + (mm-all-images-fit t) + (mail-parse-charset gnus-newsgroup-charset)) (if (mm-handle-undisplayer handle) (mm-remove-part handle) (mm-display-part handle)))) @@ -2389,27 +3110,32 @@ If ALL-HEADERS is non-nil, no headers are hidden." "Pipe MIME part N, which is the numerical prefix." (interactive "p") (gnus-article-part-wrapper n 'mm-pipe-part)) - + (defun gnus-article-save-part (n) "Save MIME part N, which is the numerical prefix." (interactive "p") (gnus-article-part-wrapper n 'mm-save-part)) - + (defun gnus-article-interactively-view-part (n) - "Pipe MIME part N, which is the numerical prefix." + "View MIME part N interactively, which is the numerical prefix." (interactive "p") (gnus-article-part-wrapper n 'mm-interactively-view-part)) - + (defun gnus-article-copy-part (n) - "Pipe MIME part N, which is the numerical prefix." + "Copy MIME part N, which is the numerical prefix." (interactive "p") (gnus-article-part-wrapper n 'gnus-mime-copy-part)) (defun gnus-article-externalize-part (n) - "Pipe MIME part N, which is the numerical prefix." + "View MIME part N externally, which is the numerical prefix." (interactive "p") (gnus-article-part-wrapper n 'gnus-mime-externalize-part)) - + +(defun gnus-article-inline-part (n) + "Inline MIME part N, which is the numerical prefix." + (interactive "p") + (gnus-article-part-wrapper n 'gnus-mime-inline-part)) + (defun gnus-article-view-part (n) "View MIME part N, which is the numerical prefix." (interactive "p") @@ -2429,22 +3155,38 @@ If ALL-HEADERS is non-nil, no headers are hidden." (let ((id (get-text-property (point) 'gnus-part)) (point (point)) buffer-read-only) - (delete-region (gnus-point-at-bol) (progn (forward-line 1) (point))) - (gnus-insert-mime-button - handle id (list (not (mm-handle-displayed-p handle)))) + (forward-line 1) (prog1 (let ((window (selected-window)) - (rfc2047-default-charset gnus-newsgroup-default-charset) - (mm-charset-iso-8859-1-forced gnus-newsgroup-iso-8859-1-forced)) + (mail-parse-charset gnus-newsgroup-charset)) (save-excursion (unwind-protect - (let ((win (get-buffer-window (current-buffer) t))) - (if win - (select-window win)) + (let ((win (get-buffer-window (current-buffer) t)) + (beg (point))) + (when win + (select-window win)) (goto-char point) (forward-line) - (mm-display-part handle)) + (if (mm-handle-displayed-p handle) + ;; This will remove the part. + (mm-display-part handle) + (save-restriction + (narrow-to-region (point) (1+ (point))) + (mm-display-part handle) + ;; We narrow to the part itself and + ;; then call the treatment functions. + (goto-char (point-min)) + (forward-line 1) + (narrow-to-region (point) (point-max)) + (gnus-treat-article + nil id + (1- (length gnus-article-mime-handles)) + (car (mm-handle-type handle)))))) (select-window window)))) + (goto-char point) + (delete-region (gnus-point-at-bol) (progn (forward-line 1) (point))) + (gnus-insert-mime-button + handle id (list (mm-handle-displayed-p handle))) (goto-char point)))) (defun gnus-article-goto-part (n) @@ -2454,25 +3196,30 @@ If ALL-HEADERS is non-nil, no headers are hidden." (goto-char point)))) (defun gnus-insert-mime-button (handle gnus-tmp-id &optional displayed) - (let ((gnus-tmp-name (mail-content-type-get (mm-handle-type handle) 'name)) + (let ((gnus-tmp-name + (or (mail-content-type-get (mm-handle-type handle) + 'name) + (mail-content-type-get (mm-handle-disposition handle) + 'filename) + "")) (gnus-tmp-type (car (mm-handle-type handle))) - (gnus-tmp-description (mm-handle-description handle)) + (gnus-tmp-description + (mail-decode-encoded-word-string (or (mm-handle-description handle) + ""))) (gnus-tmp-dots (if (if displayed (car displayed) (mm-handle-displayed-p handle)) "" "...")) - (gnus-tmp-length (save-excursion - (set-buffer (mm-handle-buffer handle)) + (gnus-tmp-length (with-current-buffer (mm-handle-buffer handle) (buffer-size))) - b e) - (setq gnus-tmp-name - (if gnus-tmp-name - (concat " (" gnus-tmp-name ")") - "")) - (setq gnus-tmp-description - (if gnus-tmp-description - (concat " (" gnus-tmp-description ")") - "")) + gnus-tmp-type-long b e) + (when (string-match ".*/" gnus-tmp-name) + (setq gnus-tmp-name (replace-match "" t t gnus-tmp-name))) + (setq gnus-tmp-type-long (concat gnus-tmp-type + (and (not (equal gnus-tmp-name "")) + (concat "; " gnus-tmp-name)))) + (or (equal gnus-tmp-description "") + (setq gnus-tmp-type-long (concat " --- " gnus-tmp-type-long))) (unless (bolp) (insert "\n")) (setq b (point)) @@ -2485,24 +3232,43 @@ If ALL-HEADERS is non-nil, no headers are hidden." article-type annotation gnus-data ,handle)) (setq e (point)) - (widget-convert-button 'link b e :action 'gnus-widget-press-button - :button-keymap gnus-mime-button-map))) + (widget-convert-button 'link b e + :mime-handle handle + :action 'gnus-widget-press-button + :button-keymap gnus-mime-button-map + :help-echo + (lambda (widget) + ;; Needed to properly clear the message + ;; due to a bug in wid-edit + (setq help-echo-owns-message t) + (format + "Click to %s the MIME part; %s for more options" + (if (mm-handle-displayed-p + (widget-get widget :mime-handle)) + "hide" "show") + (if gnus-xemacs "button3" "mouse-3")))))) (defun gnus-widget-press-button (elems el) (goto-char (widget-get elems :from)) - (let ((url-standalone-mode (not gnus-plugged))) - (gnus-article-press-button))) + (gnus-article-press-button)) + +(defvar gnus-displaying-mime nil) (defun gnus-display-mime (&optional ihandles) - "Insert MIME buttons in the buffer." + "Display the MIME parts." (save-excursion (save-selected-window - (let ((window (get-buffer-window gnus-article-buffer))) + (let ((window (get-buffer-window gnus-article-buffer)) + (point (point))) (when window - (select-window window))) + (select-window window) + ;; We have to do this since selecting the window + ;; may change the point. So we set the window point. + (set-window-point window point))) (let* ((handles (or ihandles (mm-dissect-buffer) (mm-uu-dissect))) - handle name type b e display) - (unless ihandles + buffer-read-only handle name type b e display) + (when (and (not ihandles) + (not gnus-displaying-mime)) ;; Top-level call; we clean up. (mm-destroy-parts gnus-article-mime-handles) (setq gnus-article-mime-handles handles @@ -2510,27 +3276,49 @@ If ALL-HEADERS is non-nil, no headers are hidden." ;; We allow users to glean info from the handles. (when gnus-article-mime-part-function (gnus-mime-part-function handles))) - (when (and handles - (or (not (stringp (car handles))) - (cdr handles))) - (unless ihandles - ;; Clean up for mime parts. + (if (and handles + (or (not (stringp (car handles))) + (cdr handles))) + (progn + (when (and (not ihandles) + (not gnus-displaying-mime)) + ;; Clean up for mime parts. + (article-goto-body) + (delete-region (point) (point-max))) + (let ((gnus-displaying-mime t)) + (gnus-mime-display-part handles))) + (save-restriction (article-goto-body) - (delete-region (point) (point-max))) - (gnus-mime-display-part handles)))))) + (narrow-to-region (point) (point-max)) + (gnus-treat-article nil 1 1) + (widen))) + ;; Highlight the headers. + (save-excursion + (save-restriction + (article-goto-body) + (narrow-to-region (point-min) (point)) + (gnus-treat-article 'head))))))) + +(defvar gnus-mime-display-multipart-as-mixed nil) (defun gnus-mime-display-part (handle) (cond ;; Single part. ((not (stringp (car handle))) (gnus-mime-display-single handle)) + ;; User-defined multipart + ((cdr (assoc (car handle) gnus-mime-multipart-functions)) + (funcall (cdr (assoc (car handle) gnus-mime-multipart-functions)) + handle)) ;; multipart/alternative - ((equal (car handle) "multipart/alternative") + ((and (equal (car handle) "multipart/alternative") + (not gnus-mime-display-multipart-as-mixed)) (let ((id (1+ (length gnus-article-mime-handle-alist)))) (push (cons id handle) gnus-article-mime-handle-alist) (gnus-mime-display-alternative (cdr handle) nil nil id))) ;; multipart/related - ((equal (car handle) "multipart/related") + ((and (equal (car handle) "multipart/related") + (not gnus-mime-display-multipart-as-mixed)) ;;;!!!We should find the start part, but we just default ;;;!!!to the first part. (gnus-mime-display-part (cadr handle))) @@ -2544,26 +3332,27 @@ If ALL-HEADERS is non-nil, no headers are hidden." (funcall gnus-article-mime-part-function handles))) (defun gnus-mime-display-mixed (handles) - (let (handle) - (while (setq handle (pop handles)) - (gnus-mime-display-part handle)))) + (mapcar 'gnus-mime-display-part handles)) (defun gnus-mime-display-single (handle) (let ((type (car (mm-handle-type handle))) (ignored gnus-ignored-mime-types) (not-attachment t) + (move nil) display text) (catch 'ignored (progn (while ignored (when (string-match (pop ignored) type) (throw 'ignored nil))) - (if (and (mm-automatic-display-p type) - (mm-inlinable-part-p type) - (setq not-attachment + (if (and (setq not-attachment (or (not (mm-handle-disposition handle)) (equal (car (mm-handle-disposition handle)) - "inline")))) + "inline") + (mm-attachment-override-p type))) + (mm-automatic-display-p type) + (or (mm-inlinable-part-p type) + (mm-automatic-external-display-p type))) (setq display t) (when (equal (car (split-string type "/")) "text") @@ -2574,23 +3363,32 @@ If ALL-HEADERS is non-nil, no headers are hidden." (not (gnus-unbuttonized-mime-type-p type))) (gnus-article-insert-newline) (gnus-insert-mime-button - handle id (list (or display - (and (not not-attachment) text)))) - (gnus-article-insert-newline))) - (gnus-article-insert-newline) - (cond - (display - (forward-line -2) - (let ((rfc2047-default-charset gnus-newsgroup-default-charset) - (mm-charset-iso-8859-1-forced - gnus-newsgroup-iso-8859-1-forced)) - (mm-display-part handle t)) - (goto-char (point-max))) - ((and text not-attachment) - (forward-line -2) - (gnus-article-insert-newline) - (mm-insert-inline handle (mm-get-part handle)) - (goto-char (point-max)))))))) + handle id (list (or display (and not-attachment text)))) + (gnus-article-insert-newline) + (gnus-article-insert-newline) + (setq move t))) + (let ((beg (point))) + (cond + (display + (when move + (forward-line -2)) + (let ((mail-parse-charset gnus-newsgroup-charset)) + (mm-display-part handle t)) + (goto-char (point-max))) + ((and text not-attachment) + (when move + (forward-line -2)) + (gnus-article-insert-newline) + (mm-insert-inline handle (mm-get-part handle)) + (goto-char (point-max)))) + ;; Do highlighting. + (save-excursion + (save-restriction + (narrow-to-region beg (point)) + (gnus-treat-article + nil (length gnus-article-mime-handle-alist) + (1- (length gnus-article-mime-handles)) + (car (mm-handle-type handle)))))))))) (defun gnus-unbuttonized-mime-type-p (type) "Say whether TYPE is to be unbuttonized." @@ -2655,7 +3453,7 @@ If ALL-HEADERS is non-nil, no headers are hidden." (gnus-add-text-properties (setq from (point)) (progn - (insert (format "[%c] %-18s" + (insert (format "(%c) %-18s" (if (equal handle preferred) ?* ? ) (if (stringp (car handle)) (car handle) @@ -2682,9 +3480,7 @@ If ALL-HEADERS is non-nil, no headers are hidden." (when preferred (if (stringp (car preferred)) (gnus-display-mime preferred) - (let ((rfc2047-default-charset gnus-newsgroup-default-charset) - (mm-charset-iso-8859-1-forced - gnus-newsgroup-iso-8859-1-forced)) + (let ((mail-parse-charset gnus-newsgroup-charset)) (mm-display-part preferred))) (goto-char (point-max)) (setcdr begend (point-marker))))) @@ -2696,19 +3492,21 @@ If ALL-HEADERS is non-nil, no headers are hidden." (save-excursion (set-buffer gnus-article-buffer) (let ((cite (gnus-article-hidden-text-p 'cite)) - (headers (gnus-article-hidden-text-p 'headers)) - (boring (gnus-article-hidden-text-p 'boring-headers)) - (pgp (gnus-article-hidden-text-p 'pgp)) - (pem (gnus-article-hidden-text-p 'pem)) - (signature (gnus-article-hidden-text-p 'signature)) - (overstrike (gnus-article-hidden-text-p 'overstrike)) - (emphasis (gnus-article-hidden-text-p 'emphasis))) - (format "%c%c%c%c%c%c" + (headers (gnus-article-hidden-text-p 'headers)) + (boring (gnus-article-hidden-text-p 'boring-headers)) + (pgp (gnus-article-hidden-text-p 'pgp)) + (pem (gnus-article-hidden-text-p 'pem)) + (signature (gnus-article-hidden-text-p 'signature)) + (overstrike (gnus-article-hidden-text-p 'overstrike)) + (emphasis (gnus-article-hidden-text-p 'emphasis)) + (mime gnus-show-mime)) + (format "%c%c%c%c%c%c%c" (if cite ?c ? ) (if (or headers boring) ?h ? ) (if (or pgp pem) ?p ? ) (if signature ?s ? ) (if overstrike ?o ? ) + (if mime ?m ? ) (if emphasis ?e ? ))))) (fset 'gnus-article-hide-headers-if-wanted 'gnus-article-maybe-hide-headers) @@ -2716,9 +3514,11 @@ If ALL-HEADERS is non-nil, no headers are hidden." (defun gnus-article-maybe-hide-headers () "Hide unwanted headers if `gnus-have-all-headers' is nil. Provided for backwards compatibility." - (or (save-excursion (set-buffer gnus-summary-buffer) gnus-have-all-headers) - gnus-inhibit-hiding - (gnus-article-hide-headers))) + (when (and (or (not (gnus-buffer-live-p gnus-summary-buffer)) + (not (save-excursion (set-buffer gnus-summary-buffer) + gnus-have-all-headers))) + (not gnus-inhibit-hiding)) + (gnus-article-hide-headers))) ;;; Article savers. @@ -2859,8 +3659,7 @@ Argument LINES specifies lines to be scrolled down." (defun gnus-article-describe-briefly () "Describe article mode commands briefly." (interactive) - (gnus-message 6 - (substitute-command-keys "\\\\[gnus-article-goto-next-page]:Next page \\[gnus-article-goto-prev-page]:Prev page \\[gnus-article-show-summary]:Show summary \\[gnus-info-find-node]:Run Info \\[gnus-article-describe-briefly]:This help"))) + (gnus-message 6 (substitute-command-keys "\\\\[gnus-article-goto-next-page]:Next page \\[gnus-article-goto-prev-page]:Prev page \\[gnus-article-show-summary]:Show summary \\[gnus-info-find-node]:Run Info \\[gnus-article-describe-briefly]:This help"))) (defun gnus-article-summary-command () "Execute the last keystroke in the summary buffer." @@ -2885,7 +3684,7 @@ Argument LINES specifies lines to be scrolled down." (defun gnus-article-check-buffer () "Beep if not in an article buffer." - (unless (equal major-mode 'gnus-article-mode) + (unless (eq (get-buffer gnus-article-buffer) (current-buffer)) (error "Command invoked outside of a Gnus article buffer"))) (defun gnus-article-read-summary-keys (&optional arg key not-restore-window) @@ -2949,9 +3748,12 @@ Argument LINES specifies lines to be scrolled down." (set-buffer obuf) (unless not-restore-window (set-window-configuration owin)) - (unless (or (not (eq selected 'old)) (member keys up-to-top)) + (when (eq selected 'old) + (article-goto-body) + (set-window-start (get-buffer-window (current-buffer)) + 1) (set-window-point (get-buffer-window (current-buffer)) - opoint)) + (point))) (let ((win (get-buffer-window gnus-article-current-summary))) (when win (set-window-point win new-sum-point)))))))) @@ -3050,15 +3852,6 @@ If given a prefix, show the hidden text instead." (assq article gnus-newsgroup-reads))) gnus-canceled-mark)) nil) - ;; We first check `gnus-original-article-buffer'. - ((and (get-buffer gnus-original-article-buffer) - (numberp article) - (save-excursion - (set-buffer gnus-original-article-buffer) - (and (equal (car gnus-original-article) group) - (eq (cdr gnus-original-article) article)))) - (insert-buffer-substring gnus-original-article-buffer) - 'article) ;; Check the backlog. ((and gnus-keep-backlog (gnus-backlog-request-article group article (current-buffer))) @@ -3138,6 +3931,12 @@ If given a prefix, show the hidden text instead." :group 'gnus-article-various :type 'hook) +(defcustom gnus-article-edit-article-setup-function + 'gnus-article-mime-edit-article-setup + "Function called to setup an editing article buffer." + :group 'gnus-article-various + :type 'function) + (defvar gnus-article-edit-done-function nil) (defvar gnus-article-edit-mode-map nil) @@ -3182,21 +3981,26 @@ groups." (error "The current newsgroup does not support article editing")) (gnus-article-date-original) (gnus-article-edit-article + 'ignore `(lambda (no-highlight) + 'ignore (gnus-summary-edit-article-done ,(or (mail-header-references gnus-current-headers) "") ,(gnus-group-read-only-p) ,gnus-summary-buffer no-highlight)))) -(defun gnus-article-edit-article (exit-func) +(defun gnus-article-edit-article (start-func exit-func) "Start editing the contents of the current article buffer." (let ((winconf (current-window-configuration))) (set-buffer gnus-article-buffer) (gnus-article-edit-mode) - (gnus-article-delete-text-of-type 'annotation) - (gnus-set-text-properties (point-min) (point-max) nil) + (funcall start-func) + ;;(gnus-article-delete-text-of-type 'annotation) + ;;(gnus-set-text-properties (point-min) (point-max) nil) (gnus-configure-windows 'edit-article) (setq gnus-article-edit-done-function exit-func) (setq gnus-prev-winconf winconf) + (when gnus-article-edit-article-setup-function + (funcall gnus-article-edit-article-setup-function)) (gnus-message 6 "C-c C-c to end edits"))) (defun gnus-article-edit-done (&optional arg) @@ -3226,6 +4030,8 @@ groups." (let ((func gnus-article-edit-done-function) (buf (current-buffer)) (start (window-start))) + (remove-hook 'gnus-article-mode-hook + 'gnus-article-mime-edit-article-unwind) (gnus-article-edit-exit) (save-excursion (set-buffer buf) @@ -3276,6 +4082,88 @@ groups." (query-replace-regexp "\\([.!?][])}]* \\)\\([[({A-Z]\\)" "\\1 \\2")))) ;;; +;;; Article editing with MIME-Edit +;;; + +(defcustom gnus-article-mime-edit-article-setup-hook nil + "Hook run after setting up a MIME editing article buffer." + :group 'gnus-article-various + :type 'hook) + +(defun gnus-article-mime-edit-article-unwind () + "Unwind `gnus-article-buffer' if article editing was given up." + (remove-hook 'gnus-article-mode-hook 'gnus-article-mime-edit-article-unwind) + (when mime-edit-mode-flag + (mime-edit-exit 'nomime 'no-error) + (message "")) + (when (featurep 'font-lock) + (setq font-lock-defaults nil) + (font-lock-mode 0))) + +(defun gnus-article-mime-edit-article-setup () + "Convert current buffer to MIME-Edit buffer and turn on MIME-Edit mode +after replacing with the original article." + (setq gnus-show-mime t) + (setq gnus-article-edit-done-function + `(lambda (&rest args) + (when mime-edit-mode-flag + (mime-edit-exit) + (message "")) + (goto-char (point-min)) + (let (case-fold-search) + (when (re-search-forward + (format "^%s$" (regexp-quote mail-header-separator)) + nil t) + (replace-match ""))) + (when (featurep 'font-lock) + (setq font-lock-defaults nil) + (font-lock-mode 0)) + (apply ,gnus-article-edit-done-function args) + (set-buffer gnus-original-article-buffer) + (erase-buffer) + (insert-buffer gnus-article-buffer) + (setq gnus-current-headers (gnus-article-make-full-mail-header)) + (gnus-article-prepare-display))) + (substitute-key-definition + 'gnus-article-edit-exit 'gnus-article-mime-edit-exit + gnus-article-edit-mode-map) + (erase-buffer) + (insert-buffer gnus-original-article-buffer) + (mime-edit-again) + (when (featurep 'font-lock) + (set (make-local-variable 'font-lock-defaults) + '(message-font-lock-keywords t)) + (font-lock-set-defaults) + (turn-on-font-lock)) + (add-hook 'gnus-article-mode-hook 'gnus-article-mime-edit-article-unwind) + (gnus-run-hooks 'gnus-article-mime-edit-article-setup-hook)) + +(defun gnus-article-mime-edit-exit () + "Exit the article MIME editing without updating." + (interactive) + (let ((winconf gnus-prev-winconf) + buf) + (when mime-edit-mode-flag + (mime-edit-exit) + (message "")) + (goto-char (point-min)) + (let (case-fold-search) + (when (re-search-forward + (format "^%s$" (regexp-quote mail-header-separator)) nil t) + (replace-match ""))) + (when (featurep 'font-lock) + (setq font-lock-defaults nil) + (font-lock-mode 0)) + ;; We remove all text props from the article buffer. + (setq buf (format "%s" (buffer-string))) + (set-buffer (get-buffer-create gnus-original-article-buffer)) + (erase-buffer) + (insert buf) + (setq gnus-current-headers (gnus-article-make-full-mail-header)) + (gnus-article-prepare-display) + (set-window-configuration winconf))) + +;;; ;;; Article highlights ;;; @@ -3389,6 +4277,40 @@ call it with the value of the `gnus-data' text property." (when fun (funcall fun data)))) +(defun gnus-article-prev-button (n) + "Move point to N buttons backward. +If N is negative, move forward instead." + (interactive "p") + (gnus-article-next-button (- n))) + +(defun gnus-article-next-button (n) + "Move point to N buttons forward. +If N is negative, move backward instead." + (interactive "p") + (let ((function (if (< n 0) 'previous-single-property-change + 'next-single-property-change)) + (inhibit-point-motion-hooks t) + (backward (< n 0)) + (limit (if (< n 0) (point-min) (point-max)))) + (setq n (abs n)) + (while (and (not (= limit (point))) + (> n 0)) + ;; Skip past the current button. + (when (get-text-property (point) 'gnus-callback) + (goto-char (funcall function (point) 'gnus-callback nil limit))) + ;; Go to the next (or previous) button. + (gnus-goto-char (funcall function (point) 'gnus-callback nil limit)) + ;; Put point at the start of the button. + (when (and backward (not (get-text-property (point) 'gnus-callback))) + (goto-char (funcall function (point) 'gnus-callback nil limit))) + ;; Skip past intangible buttons. + (when (get-text-property (point) 'intangible) + (incf n)) + (decf n)) + (unless (zerop n) + (gnus-message 5 "No more buttons")) + n)) + (defun gnus-article-highlight (&optional force) "Highlight current article. This function calls `gnus-article-highlight-headers', @@ -3423,7 +4345,7 @@ do the highlighting. See the documentation for those functions." (case-fold-search t) (inhibit-point-motion-hooks t) entry regexp header-face field-face from hpoints fpoints) - (message-narrow-to-head) + (article-narrow-to-head) (while (setq entry (pop alist)) (goto-char (point-min)) (setq regexp (concat "^\\(" @@ -3524,38 +4446,38 @@ specified by `gnus-button-alist'." (interactive) (save-excursion (set-buffer gnus-article-buffer) - (let ((buffer-read-only nil) - (inhibit-point-motion-hooks t) - (case-fold-search t) - (alist gnus-header-button-alist) - entry beg end) - (nnheader-narrow-to-headers) - (while alist - ;; Each alist entry. - (setq entry (car alist) - alist (cdr alist)) - (goto-char (point-min)) - (while (re-search-forward (car entry) nil t) - ;; Each header matching the entry. - (setq beg (match-beginning 0)) - (setq end (or (and (re-search-forward "^[^ \t]" nil t) - (match-beginning 0)) - (point-max))) - (goto-char beg) - (while (re-search-forward (nth 1 entry) end t) - ;; Each match within a header. - (let* ((entry (cdr entry)) - (start (match-beginning (nth 1 entry))) - (end (match-end (nth 1 entry))) - (form (nth 2 entry))) - (goto-char (match-end 0)) - (when (eval form) - (gnus-article-add-button - start end (nth 3 entry) - (buffer-substring (match-beginning (nth 4 entry)) - (match-end (nth 4 entry))))))) - (goto-char end)))) - (widen))) + (save-restriction + (let ((buffer-read-only nil) + (inhibit-point-motion-hooks t) + (case-fold-search t) + (alist gnus-header-button-alist) + entry beg end) + (article-narrow-to-head) + (while alist + ;; Each alist entry. + (setq entry (car alist) + alist (cdr alist)) + (goto-char (point-min)) + (while (re-search-forward (car entry) nil t) + ;; Each header matching the entry. + (setq beg (match-beginning 0)) + (setq end (or (and (re-search-forward "^[^ \t]" nil t) + (match-beginning 0)) + (point-max))) + (goto-char beg) + (while (re-search-forward (nth 1 entry) end t) + ;; Each match within a header. + (let* ((entry (cdr entry)) + (start (match-beginning (nth 1 entry))) + (end (match-end (nth 1 entry))) + (form (nth 2 entry))) + (goto-char (match-end 0)) + (when (eval form) + (gnus-article-add-button + start end (nth 3 entry) + (buffer-substring (match-beginning (nth 4 entry)) + (match-end (nth 4 entry))))))) + (goto-char end))))))) ;;; External functions: @@ -3569,9 +4491,7 @@ specified by `gnus-button-alist'." (nconc (and gnus-article-mouse-face (list gnus-mouse-face-prop gnus-article-mouse-face)) (list 'gnus-callback fun) - (and data (list 'gnus-data data)))) - (widget-convert-button 'link from to :action 'gnus-widget-press-button - :button-keymap gnus-widget-button-keymap)) + (and data (list 'gnus-data data))))) ;;; Internal functions: @@ -3707,26 +4627,29 @@ forbidden in URL encoding." (setq to (gnus-url-unhex-string url))) (setq args (cons (list "to" to) args) subject (cdr-safe (assoc "subject" args))) - (message-mail) - (while args - (setq func (intern-soft (concat "message-goto-" (downcase (caar args))))) - (if (fboundp func) - (funcall func) - (message-position-on-field (caar args))) - (insert (mapconcat 'identity (cdar args) ", ")) - (setq args (cdr args))) - (if subject - (message-goto-body) - (message-goto-subject)))) + (gnus-setup-message 'reply + (message-mail) + (while args + (setq func (intern-soft (concat "message-goto-" (downcase (caar args))))) + (if (fboundp func) + (funcall func) + (message-position-on-field (caar args))) + (insert (mapconcat 'identity (cdar args) ", ")) + (setq args (cdr args))) + (if subject + (message-goto-body) + (message-goto-subject))))) (defun gnus-button-mailto (address) ;; Mail to ADDRESS. (set-buffer (gnus-copy-article-buffer)) - (message-reply address)) + (gnus-setup-message 'reply + (message-reply address))) (defun gnus-button-reply (address) ;; Reply to ADDRESS. - (message-reply address)) + (gnus-setup-message 'reply + (message-reply address))) (defun gnus-button-url (address) "Browse ADDRESS." @@ -3809,38 +4732,34 @@ forbidden in URL encoding." (select-window win))) (defvar gnus-decode-header-methods - '(gnus-decode-with-mail-decode-encoded-word-region) - "List of methods used to decode headers + '(mail-decode-encoded-word-region) + "List of methods used to decode headers. This variable is a list of FUNCTION or (REGEXP . FUNCTION). If item is FUNCTION, FUNCTION will be apply to all newsgroups. If item is a (REGEXP . FUNCTION), FUNCTION will be only apply to thes newsgroups whose names match REGEXP. -For example: +For example: ((\"chinese\" . gnus-decode-encoded-word-region-by-guess) - mail-decode-encoded-word-region + mail-decode-encoded-word-region (\"chinese\" . rfc1843-decode-region)) ") (defvar gnus-decode-header-methods-cache nil) -(defun gnus-decode-with-mail-decode-encoded-word-region (start end) - (let ((rfc2047-default-charset gnus-default-charset)) - (mail-decode-encoded-word-region start end))) - (defun gnus-multi-decode-header (start end) "Apply the functions from `gnus-encoded-word-methods' that match." (unless (and gnus-decode-header-methods-cache - (eq gnus-newsgroup-name + (eq gnus-newsgroup-name (car gnus-decode-header-methods-cache))) (setq gnus-decode-header-methods-cache (list gnus-newsgroup-name)) - (mapc '(lambda (x) + (mapc '(lambda (x) (if (symbolp x) (nconc gnus-decode-header-methods-cache (list x)) - (if (and gnus-newsgroup-name + (if (and gnus-newsgroup-name (string-match (car x) gnus-newsgroup-name)) - (nconc gnus-decode-header-methods-cache + (nconc gnus-decode-header-methods-cache (list (cdr x)))))) gnus-decode-header-methods)) (let ((xlist gnus-decode-header-methods-cache)) @@ -3850,6 +4769,120 @@ For example: (while xlist (funcall (pop xlist) (point-min) (point-max)))))) +;;; +;;; Treatment top-level handling. +;;; + +(defun gnus-treat-article (condition &optional part-number total-parts type) + (let ((length (- (point-max) (point-min))) + (alist gnus-treatment-function-alist) + (article-goto-body-goes-to-point-min-p t) + (treated-type + (or (not type) + (catch 'found + (let ((list gnus-article-treat-types)) + (while list + (when (string-match (pop list) type) + (throw 'found t))))))) + (highlightp (gnus-visual-p 'article-highlight 'highlight)) + val elem) + (gnus-run-hooks 'gnus-part-display-hook) + (while (setq elem (pop alist)) + (setq val (symbol-value (car elem))) + (when (and (or (consp val) + treated-type) + (gnus-treat-predicate val) + (or (not (get (car elem) 'highlight)) + highlightp)) + (save-restriction + (funcall (cadr elem))))))) + +;; Dynamic variables. +(defvar part-number) +(defvar total-parts) +(defvar type) +(defvar condition) +(defvar length) +(defun gnus-treat-predicate (val) + (cond + ((eq val 'mime) + (not (not gnus-show-mime))) + ((null val) + nil) + ((listp val) + (let ((pred (pop val))) + (cond + ((eq pred 'or) + (apply 'gnus-or (mapcar 'gnus-treat-predicate val))) + ((eq pred 'and) + (apply 'gnus-and (mapcar 'gnus-treat-predicate val))) + ((eq pred 'not) + (not (gnus-treat-predicate val))) + ((eq pred 'typep) + (equal (cadr val) type)) + (t + (gnus-treat-predicate pred))))) + (condition + (eq condition val)) + ((eq val t) + t) + ((eq val 'head) + nil) + ((eq val 'last) + (eq part-number total-parts)) + ((numberp val) + (< length val)) + (t + (error "%S is not a valid value" val)))) + + +;;; @ for mime-view +;;; + +(defun gnus-article-header-presentation-method (entity situation) + (mime-insert-header entity) + ) + +(set-alist 'mime-header-presentation-method-alist + 'gnus-original-article-mode + #'gnus-article-header-presentation-method) + +(defun gnus-mime-preview-quitting-method () + (mime-preview-kill-buffer) + (delete-other-windows) + (gnus-article-show-summary) + (gnus-summary-select-article gnus-show-all-headers t)) + +(set-alist 'mime-preview-quitting-method-alist + 'gnus-original-article-mode #'gnus-mime-preview-quitting-method) + +(defun gnus-following-method (buf) + (set-buffer buf) + (message-followup) + (message-yank-original) + (kill-buffer buf) + (goto-char (point-min)) + ) + +(set-alist 'mime-preview-following-method-alist + 'gnus-original-article-mode #'gnus-following-method) + +(set-alist 'mime-preview-over-to-previous-method-alist + 'gnus-original-article-mode + (lambda () + (gnus-article-read-summary-keys + nil (gnus-character-to-event ?P)))) + +(set-alist 'mime-preview-over-to-next-method-alist + 'gnus-original-article-mode' + (lambda () + (gnus-article-read-summary-keys + nil (gnus-character-to-event ?N)))) + + +;;; @ end +;;; + (gnus-ems-redefine) (provide 'gnus-art)