;;; gnus-art.el --- article mode commands for Semi-gnus
-;; Copyright (C) 1996,97,98 Free Software Foundation, Inc.
+;; Copyright (C) 1996,97,98,99 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; MORIOKA Tomohiko <morioka@jaist.ac.jp>
: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")
:group 'gnus-article-hiding)
(defcustom gnus-visible-headers
- "From:\\|^Newsgroups:\\|^Subject:\\|^Date:\\|^\\(Mail-\\)?Followup-To:\\|^\\(Mail-\\)?Reply-To:\\|^Mail-Copies-To:\\|^Organization:\\|^Summary:\\|^Keywords:\\|^To:\\|^Cc:\\|^Posted-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."
: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)
("\205" "...")
("\213" "<")
("\214" "OE")
- ("\205" "...")
("\221" "`")
("\222" "'")
("\223" "``")
: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-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-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."
+ :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-strip-banner t
+ "Strip banners from articles.
+The banner to be stripped is specified in the `banner' group parameter."
+ :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-date-iso8601 nil
+ "Display the date in the ISO8601 format."
+ :group 'gnus-article-treat
+ :type gnus-article-treat-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."
+ :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 (and gnus-xemacs (featurep 'xface))
+ 'head nil)
+ "Display X-Face headers."
+ :group 'gnus-article-treat
+ :type gnus-article-treat-custom)
+
+(defcustom gnus-treat-display-smileys (if (and gnus-xemacs
+ (featurep 'xpm))
+ 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-treat
+ :type gnus-article-treat-custom)
+
+(defcustom gnus-treat-capitalize-sentences nil
+ "Capitalize sentence-starting words."
+ :group 'gnus-article-treat
+ :type gnus-article-treat-custom)
+
+(defcustom gnus-treat-fill-long-lines nil
+ "Fill long lines."
+ :group 'gnus-article-treat
+ :type gnus-article-treat-custom)
+
+(defcustom gnus-treat-play-sounds nil
+ "Fill long lines."
+ :group 'gnus-article-treat
+ :type gnus-article-treat-custom)
+
;;; 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)
- ))
+ '((gnus-treat-strip-banner gnus-article-strip-banner)
+ (gnus-treat-highlight-signature gnus-article-highlight-signature)
+ (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-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-emphasize gnus-article-emphasize)
+ (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)))
(defvar gnus-article-mime-handle-alist nil)
(defvar article-lapsed-timer nil)
(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)
(current-buffer)
(if (gnus-article-check-hidden-text 'headers arg)
;; Show boring headers as well.
- (gnus-article-show-hidden-text 'boring-headers)
+ (progn
+ (gnus-article-show-hidden-text 'boring-headers)
+ (when (eq 1 (point-min))
+ (set-window-start (get-buffer-window (current-buffer)) 1)))
;; This function might be inhibited.
(unless gnus-inhibit-hiding
(save-excursion
(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
+ (widen)
+ (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.."
(case-fold-search t)
from last)
(save-restriction
- (nnheader-narrow-to-headers)
+ (message-narrow-to-head)
+ (goto-char (point-min))
(setq from (message-fetch-field "from"))
(goto-char (point-min))
(while (and gnus-article-x-face-command
(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)
(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)
(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)
(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
- (let ((inhibit-point-motion-hooks t)
- buffer-read-only beg end)
- (widen)
- (goto-char (point-min))
- ;; Hide the "header".
- (when (search-forward "\n-----BEGIN PGP SIGNED MESSAGE-----\n" nil t)
- (delete-region (1+ (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))))
- (setq beg (point))
- ;; Hide the actual signature.
- (and (search-forward "\n-----BEGIN PGP SIGNATURE-----\n" nil t)
- (setq end (1+ (match-beginning 0)))
- (delete-region
- end
- (if (search-forward "\n-----END PGP SIGNATURE-----\n" nil t)
- (match-end 0)
- ;; Perhaps we shouldn't hide to the end of the buffer
- ;; if there is no end to the signature?
- (point-max))))
- ;; Hide "- " PGP quotation markers.
- (when (and beg end)
- (narrow-to-region beg end)
- (goto-char (point-min))
- (while (re-search-forward "^- " nil t)
- (delete-region
- (match-beginning 0) (match-end 0)))
- (widen))
- (gnus-run-hooks 'gnus-article-hide-pgp-hook))))))
+(defun article-hide-pgp ()
+ "Remove any PGP headers and signatures in the current article."
+ (interactive)
+ (save-excursion
+ (let ((inhibit-point-motion-hooks t)
+ buffer-read-only beg end)
+ (widen)
+ (goto-char (point-min))
+ ;; Hide the "header".
+ (when (search-forward "\n-----BEGIN PGP SIGNED MESSAGE-----\n" nil t)
+ (push 'pgp gnus-article-wash-types)
+ (delete-region (1+ (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))))
+ (setq beg (point))
+ ;; Hide the actual signature.
+ (and (search-forward "\n-----BEGIN PGP SIGNATURE-----\n" nil t)
+ (setq end (1+ (match-beginning 0)))
+ (delete-region
+ end
+ (if (search-forward "\n-----END PGP SIGNATURE-----\n" nil t)
+ (match-end 0)
+ ;; Perhaps we shouldn't hide to the end of the buffer
+ ;; if there is no end to the signature?
+ (point-max))))
+ ;; Hide "- " PGP quotation markers.
+ (when (and beg end)
+ (narrow-to-region beg end)
+ (goto-char (point-min))
+ (while (re-search-forward "^- " nil t)
+ (delete-region
+ (match-beginning 0) (match-end 0)))
+ (widen))
+ (gnus-run-hooks 'gnus-article-hide-pgp-hook)))))
(defun article-hide-pem (&optional arg)
"Toggle hiding of any PEM headers and signatures in the current article.
(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.
(gnus-delete-line))))))
(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."
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)
((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
(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.
'(article-hide-headers
article-hide-boring-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-remove-trailing-blank-lines
" " 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
"\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)
(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)
(defun gnus-article-display-mime-message ()
"Article display method for MIME message."
;; called from `gnus-original-article-buffer'.
- (let ((charset (with-current-buffer gnus-summary-buffer
- default-mime-charset)))
+ (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)
)
(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))))))
;;;###autoload
(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))
(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))))
+ (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."
(save-current-buffer
(set-buffer gnus-article-buffer)
(let ((handles (or handles gnus-article-mime-handles))
- (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))
(if (stringp (car handles))
(gnus-mime-view-all-parts (cdr handles))
(mapcar 'mm-display-part handles)))))
(mm-remove-part data)
(setq contents (mm-get-part data))
(forward-line 2)
- (when charset
+ (when charset
(unless (symbolp charset)
(setq charset (mm-read-coding-system "Charset: ")))
(setq contents (mm-decode-coding-string contents charset)))
(let* ((handle (or handle (get-text-property (point) 'gnus-data)))
(mm-user-display-methods nil)
(mm-all-images-fit t)
- (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))
(if (mm-handle-undisplayer handle)
(mm-remove-part handle)
(mm-display-part handle))))
(let* ((handle (or handle (get-text-property (point) 'gnus-data)))
(mm-user-display-methods '((".*" . inline)))
(mm-all-images-fit t)
- (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))
(if (mm-handle-undisplayer handle)
(mm-remove-part handle)
(mm-display-part handle))))
"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")
(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)
+ (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)
(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))
;; 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)
+ buffer-read-only handle name type b e display)
(unless ihandles
;; Top-level call; we clean up.
(mm-destroy-parts gnus-article-mime-handles)
;; 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)
(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)))
(not (gnus-unbuttonized-mime-type-p type)))
(gnus-article-insert-newline)
(gnus-insert-mime-button
- handle id (list (or display
- (and not-attachment text))))
+ handle id (list (or display (and not-attachment text))))
(gnus-article-insert-newline)
(gnus-article-insert-newline)
(setq move t)))
- (cond
- (display
- (when move
- (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)
- (when move
- (forward-line -2))
- (gnus-article-insert-newline)
- (mm-insert-inline handle (mm-get-part handle))
- (goto-char (point-max))))))))
+ (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."
(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)))))
(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))
+ (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 ? )
(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.
(defun gnus-article-describe-briefly ()
"Describe article mode commands briefly."
(interactive)
- (gnus-message 6
- (substitute-command-keys "\\<gnus-article-mode-map>\\[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-mode-map>\\[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."
(defun gnus-article-check-buffer ()
"Beep if not in an article buffer."
- (unless (or (equal major-mode 'gnus-article-mode)
- (equal (save-current-buffer
- (set-buffer gnus-original-article-buffer)
- major-mode)
- 'gnus-original-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)
(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))))))))
(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)
(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)))))))
+ val elem)
+ (when (gnus-visual-p 'article-highlight 'highlight)
+ (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))
+ (funcall (cadr elem)))))))
+
+;; Dynamic variables.
+(defvar part-number)
+(defvar total-parts)
+(defvar type)
+(defvar condition)
+(defvar length)
+(defun gnus-treat-predicate (val)
+ (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))
+ ((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-tread-predicate val)))
+ ((eq pred 'not)
+ (not (gnus-treat-predicate val)))
+ ((eq pred 'typep)
+ (equal (cadr val) type))
+ (t
+ (error "%S is not a valid predicate" pred)))))
+ (t
+ (error "%S is not a valid value" val))))
+
;;; @ for mime-view
;;;
#'gnus-article-header-presentation-method)
(defun gnus-mime-preview-quitting-method ()
- (if gnus-show-mime
- (gnus-article-show-summary)
- (mime-preview-kill-buffer)
- (delete-other-windows)
- (gnus-article-show-summary)
- (gnus-summary-select-article nil t)
- ))
+ (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)
(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
;;;