X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fgnus-art.el;h=3e2d86bc7ea72865d128cfe3a0cd7a01b6cbb241;hb=41fb7027bd9100cf7a76b88761ed42317e11cfa8;hp=7ea23272da742e154633f396c55ad3355f83558f;hpb=0d1720aee995af053638966ad6bcf16698575735;p=elisp%2Fgnus.git- diff --git a/lisp/gnus-art.el b/lisp/gnus-art.el index 7ea2327..3e2d86b 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") @@ -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 @@ -538,8 +567,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,14 +587,13 @@ displayed by the first non-nil matching CONTENT face." ("\205" "...") ("\213" "<") ("\214" "OE") - ("\205" "...") ("\221" "`") ("\222" "'") ("\223" "``") ("\224" "''") ("\225" "*") ("\226" "-") - ("\227" "-") + ("\227" "-") ("\231" "(TM)") ("\233" ">") ("\234" "oe") @@ -583,26 +610,194 @@ 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) +;;; +;;; The treatment variables +;;; + +(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-types '("text/plain") + "Parts to treat.") + +(defvar gnus-inhibit-treatment nil + "Whether to inhibit treatment.") + +(defcustom gnus-treat-highlight-signature 'last + "Highlight the signature." + :group 'gnus-article-treat + :type gnus-article-treat-custom) + +(defcustom gnus-treat-buttonize t + "Add buttons." + :group 'gnus-article-treat + :type gnus-article-treat-custom) + +(defcustom gnus-treat-buttonize-head 'head + "Add buttons to the head." + :group 'gnus-article-treat + :type gnus-article-treat-custom) + +(defcustom gnus-treat-emphasize t + "Emphasize text." + :group 'gnus-article-treat + :type gnus-article-treat-custom) + +(defcustom gnus-treat-strip-cr nil + "Remove carriage returns." + :group 'gnus-article-treat + :type gnus-article-treat-custom) + +(defcustom gnus-treat-hide-headers 'head + "Hide headers." + :group 'gnus-article-treat + :type gnus-article-treat-custom) + +(defcustom gnus-treat-hide-boring-headers nil + "Hide boring headers." + :group 'gnus-article-treat + :type gnus-article-treat-custom) + +(defcustom gnus-treat-hide-signature nil + "Hide the signature." + :group 'gnus-article-treat + :type gnus-article-treat-custom) + +(defcustom gnus-treat-fill-article nil + "Fill the article." + :group 'gnus-article-treat + :type gnus-article-treat-custom) + +(defcustom gnus-treat-hide-citation nil + "Hide cited text." + :group 'gnus-article-treat + :type gnus-article-treat-custom) + +(defcustom gnus-treat-strip-pgp t + "Strip PGP signatures." + :group 'gnus-article-treat + :type gnus-article-treat-custom) + +(defcustom gnus-treat-strip-pem nil + "Strip PEM signatures." + :group 'gnus-article-treat + :type gnus-article-treat-custom) + +(defcustom gnus-treat-highlight-headers 'head + "Highlight the headers." + :group 'gnus-article-treat + :type gnus-article-treat-custom) + +(defcustom gnus-treat-highlight-citation t + "Highlight cited text." + :group 'gnus-article-treat + :type gnus-article-treat-custom) + +(defcustom gnus-treat-date-ut nil + "Display the Date in UT (GMT)." + :group 'gnus-article-treat + :type gnus-article-treat-custom) + +(defcustom gnus-treat-date-local nil + "Display the Date in the local timezone." + :group 'gnus-article-treat + :type gnus-article-treat-custom) + +(defcustom gnus-treat-date-lapsed nil + "Display the Date header in a way that says how much time has elapsed." + :group 'gnus-article-treat + :type gnus-article-treat-custom) + +(defcustom gnus-treat-date-original nil + "Display the date in the original timezone." + :group 'gnus-article-treat + :type gnus-article-treat-custom) + +(defcustom gnus-treat-strip-trailing-blank-lines nil + "Strip trailing blank lines." + :group 'gnus-article-treat + :type gnus-article-treat-custom) + +(defcustom gnus-treat-strip-leading-blank-lines nil + "Strip leading blank lines." + :group 'gnus-article-treat + :type gnus-article-treat-custom) + +(defcustom gnus-treat-strip-multiple-blank-lines nil + "Strip multiple blank lines." + :group 'gnus-article-treat + :type gnus-article-treat-custom) + +(defcustom gnus-treat-strip-blank-lines nil + "Strip all blank lines." + :group 'gnus-article-treat + :type gnus-article-treat-custom) + +(defcustom gnus-treat-overstrike t + "Treat overstrike highlighting." + :group 'gnus-article-treat + :type gnus-article-treat-custom) + +(defcustom gnus-treat-display-xface (if gnus-xemacs 'head nil) + "Display X-Face headers." + :group 'gnus-article-treat + :type gnus-article-treat-custom) + +(defcustom gnus-treat-display-smileys (if gnus-xemacs t nil) + "Display smileys." + :group 'gnus-article-treat + :type gnus-article-treat-custom) + +(defcustom gnus-treat-display-picons (if gnus-xemacs 'head nil) + "Display picons." + :group 'gnus-article + :type gnus-article-treat-custom) + ;;; Internal variables (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-highlight-signature gnus-article-highlight-signature) + (gnus-treat-buttonize gnus-article-add-buttons) + (gnus-treat-buttonize-head gnus-article-add-buttons-to-head) + (gnus-treat-emphasize gnus-article-emphasize) + (gnus-treat-fill-article gnus-article-fill-cited-article) + (gnus-treat-strip-cr gnus-article-remove-cr) + (gnus-treat-hide-headers gnus-article-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-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-display-xface gnus-article-display-x-face) + (gnus-treat-display-smileys gnus-smiley-display))) (defvar gnus-article-mime-handle-alist nil) (defvar article-lapsed-timer nil) @@ -636,6 +831,33 @@ Initialized from `text-mode-syntax-table.") (max (1- b) (point-min)) b 'intangible (cddr (memq 'intangible props))))) +(defmacro gnus-with-article (article &rest forms) + "Select ARTICLE and perform FORMS in the original article buffer. +Then replace the article with the result." + `(progn + ;; We don't want the article to be marked as read. + (let (gnus-mark-article-hook) + (gnus-summary-select-article t t nil ,article)) + (set-buffer gnus-original-article-buffer) + ,@forms + (if (not (gnus-check-backend-function + 'request-replace-article (car gnus-article-current))) + (gnus-message 5 "Read-only group; not replacing") + (unless (gnus-request-replace-article + ,article (car gnus-article-current) + (current-buffer) t) + (error "Couldn't replace article"))) + ;; The cache and backlog have to be flushed somewhat. + (when gnus-keep-backlog + (gnus-backlog-remove-article + (car gnus-article-current) (cdr gnus-article-current))) + (when gnus-use-cache + (gnus-cache-update-article + (car gnus-article-current) (cdr gnus-article-current))))) + +(put 'gnus-with-article 'lisp-indent-function 1) +(put 'gnus-with-article 'edebug-form-spec '(form body)) + (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) @@ -821,8 +1043,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 +1084,41 @@ always hide." (point-max))) 'boring-headers)))) +(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 + (message-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)) @@ -1025,8 +1280,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) @@ -1048,8 +1302,7 @@ If PROMPT (the prefix), prompt for a coding system to use." (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) (goto-char (point-max)) (widen) @@ -1065,13 +1318,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 +1333,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) @@ -1392,7 +1642,9 @@ If TYPE is `local', convert to local time; if it is `lapsed', output how much time has lapsed since DATE." (interactive (list 'ut t)) (let* ((header (or header - (mail-header-date gnus-current-headers) + (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) @@ -1545,7 +1797,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. @@ -1948,6 +2201,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,8 +2210,6 @@ 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 @@ -1967,6 +2219,10 @@ If variable `gnus-use-long-file-name' is non-nil, it is "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 +2235,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) @@ -2002,8 +2278,7 @@ If variable `gnus-use-long-file-name' is non-nil, it is ["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 +2310,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) @@ -2048,7 +2325,6 @@ commands: (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 +2348,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 +2380,70 @@ 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) + (mime-display-message mime-message-structure + gnus-article-buffer nil gnus-article-mode-map) + (when all-headers + (gnus-article-hide-headers nil -1)) + (make-local-variable 'default-mime-charset) + (setq default-mime-charset charset) + ) + ;; `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 +2461,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) @@ -2215,20 +2554,21 @@ If ALL-HEADERS is non-nil, no headers are hidden." (set-window-point (get-buffer-window (current-buffer)) (point)) 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)) - buffer-read-only) - (unless (eq major-mode 'gnus-article-mode) - (gnus-article-mode)) - (setq buffer-read-only nil) + (let ((method + (if gnus-show-mime + (progn + (setq mime-message-structure gnus-current-headers) + gnus-article-display-method-for-mime) + gnus-article-display-method-for-traditional))) (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))) + ;; Display message. + (funcall method) + ;; Associate this article with the current summary buffer. + (setq gnus-article-current-summary gnus-summary-buffer) ;; Perform the article display hooks. (gnus-run-hooks 'gnus-article-display-hook))) @@ -2236,17 +2576,19 @@ If ALL-HEADERS is non-nil, no headers are hidden." ;;; 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 +2597,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 +2615,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 +2623,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 +2665,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,17 +2673,22 @@ 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) @@ -2350,12 +2696,12 @@ If ALL-HEADERS is non-nil, no headers are hidden." (interactive "P") ; For compatibility reasons we are not using "z". (gnus-article-check-buffer) (let* ((data (get-text-property (point) 'gnus-data)) - (contents (mm-get-part data)) - ;(url-standalone-mode (not gnus-plugged)) + contents (b (point)) buffer-read-only) (if (mm-handle-undisplayer data) (mm-remove-part data) + (setq contents (mm-get-part data)) (forward-line 2) (when charset (unless (symbolp charset) @@ -2365,14 +2711,25 @@ If ALL-HEADERS is non-nil, no headers are hidden." (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)))) @@ -2434,16 +2791,24 @@ If ALL-HEADERS is non-nil, no headers are hidden." handle id (list (not (mm-handle-displayed-p handle)))) (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) + (mm-display-part handle) + (save-restriction + (narrow-to-region (point) (1+ (point))) + (mm-display-part handle) + (gnus-treat-article + nil id + (1- (length gnus-article-mime-handles)) + (car (mm-handle-type handle)))))) (select-window window)))) (goto-char point)))) @@ -2454,25 +2819,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,21 +2855,37 @@ 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)) (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 @@ -2510,14 +2896,27 @@ 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 + (unless ihandles + ;; Clean up for mime parts. + (article-goto-body) + (delete-region (point) (point-max))) + (gnus-mime-display-part handles)) + (save-restriction + (article-goto-body) + (narrow-to-region (point) (point-max)) + (gnus-treat-article nil 1 1))) + ;; Highlight the headers. + (save-excursion + (save-restriction (article-goto-body) - (delete-region (point) (point-max))) - (gnus-mime-display-part handles)))))) + (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 @@ -2525,12 +2924,14 @@ If ALL-HEADERS is non-nil, no headers are hidden." ((not (stringp (car handle))) (gnus-mime-display-single 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 +2945,26 @@ 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-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 +2975,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 +3065,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 +3092,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))))) @@ -2702,13 +3110,15 @@ If ALL-HEADERS is non-nil, no headers are hidden." (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" + (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 +3126,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 +3271,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 +3296,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) @@ -3050,15 +3461,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 +3540,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) @@ -3197,6 +3605,8 @@ groups." (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 +3636,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 +3688,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 +3883,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', @@ -3569,9 +4097,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 +4233,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 +4338,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 +4375,87 @@ 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) + val elem) + (when (or (not type) + (catch 'found + (let ((list gnus-article-treat-types)) + (while list + (when (string-match (pop list) type) + (throw 'found t)))))) + (while (setq elem (pop alist)) + (setq val (symbol-value (car elem))) + (when (cond + (condition + (eq condition val)) + ((null val) + nil) + ((eq val t) + t) + ((eq val 'head) + nil) + ((eq val 'last) + (eq part-number total-parts)) + ((numberp val) + (< length val)) + (t + (eval val))) + (funcall (cadr elem))))))) + + +;;; @ 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)