;;; gnus-art.el --- article mode commands for 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>
;; Keywords: news
(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")
"^Originator:" "^X-Problems-To:" "^X-Auth-User:" "^X-Post-Time:"
"^X-Admin:" "^X-UID:" "^Resent-[-A-Za-z]+:" "^X-Mailing-List:"
"^Precedence:" "^Original-[-A-Za-z]+:" "^X-filename:" "^X-Orcpt:"
- "^Old-Received:" "^X-Pgp-Fingerprint:" "^X-Pgp-Key-Id:"
- "^X-Pgp-Public-Key-Url:" "^X-Auth:" "^X-From-Line:"
+ "^Old-Received:" "^X-Pgp" "^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:")
+ "^MBOX-Line" "^Priority:" "^X-Pgp" "^X400-[-A-Za-z]+:"
+ "^Status:" "^X-Gnus-Mail-Source:" "^Cancel-Lock:"
+ "^X-FTN" "^X-EXP32-SerialNo:" "^Encoding:" "^Importance:"
+ "^Autoforwarded:" "^Original-Encoded-Information-Types:" "^X-Ya-Pop3:"
+ "^X-Face-Version:" "^X-Vms-To:" "^X-ML-NAME:" "^X-ML-COUNT:"
+ "^Mailing-List:" "^X-finfo:" "^X-md5sum:" "^X-md5sum-Origin:"
+ "^X-Sun-Charset:" "^X-Accept-Language:" "^X-Envelope-Sender:"
+ "^List-[A-Za-z]+:" "^X-Listprocessor-Version:"
+ "^X-Received:" "^X-Distribute:" "^X-Sequence:" "^X-Juno-Line-Breaks:"
+ "^X-Notes-Item:" "^X-MS-TNEF-Correlator:" "^x-uunet-gateway:")
"*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."
: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."
:group 'gnus-article-hiding)
(defcustom gnus-article-x-face-command
- "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | xv -quit -"
+ "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | display -"
"*String or function to be executed to display an X-Face header.
If it is a string, the command will be executed in a sub-shell
asynchronously. The compressed face will be piped to this command."
Esample: (_/*word*/_)."
:group 'gnus-article-emphasis)
+(defface gnus-emphasis-highlight-words
+ '((t (:background "black" :foreground "yellow")))
+ "Face used for displaying highlighted words."
+ :group 'gnus-article-emphasis)
+
(defcustom gnus-article-time-format "%a, %b %d %Y %T %Z"
"Format for display of Date headers in article bodies.
See `format-time-string' for the possible values.
:type 'regexp
:group 'gnus-article-various)
-(defcustom gnus-article-mode-line-format "Gnus: %g %S"
+(defcustom gnus-article-mode-line-format "Gnus: %g [%w] %S%m"
"*The format specification for the article mode line.
-See `gnus-summary-mode-line-format' for a closer description."
+See `gnus-summary-mode-line-format' for a closer description.
+
+The following additional specs are available:
+
+%w The article washing status.
+%m The number of MIME parts in the article."
:type 'string
:group 'gnus-article-various)
: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)
(defcustom gnus-display-mime-function 'gnus-display-mime
"Function to display MIME articles."
- :group 'gnus-article-headers
+ :group 'gnus-article-mime
:type 'function)
(defvar gnus-decode-header-function 'mail-decode-encoded-word-region
"Function used to decode headers.")
+(defvar gnus-article-dumbquotes-map
+ '(("\202" ",")
+ ("\203" "f")
+ ("\204" ",,")
+ ("\205" "...")
+ ("\213" "<")
+ ("\214" "OE")
+ ("\221" "`")
+ ("\222" "'")
+ ("\223" "``")
+ ("\224" "\"")
+ ("\225" "*")
+ ("\226" "---")
+ ("\227" "-")
+ ("\231" "(TM)")
+ ("\233" ">")
+ ("\234" "oe")
+ ("\264" "'"))
+ "Table for MS-to-Latin1 translation.")
+
+(defcustom gnus-ignored-mime-types nil
+ "List of MIME types that should be ignored by Gnus."
+ :group 'gnus-article-mime
+ :type '(repeat regexp))
+
+(defcustom gnus-unbuttonized-mime-types '(".*/.*")
+ "List of MIME types that should not be given buttons when rendered inline."
+ :group 'gnus-article-mime
+ :type '(repeat regexp))
+
+(defcustom gnus-article-mime-part-function nil
+ "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")
+ (repeat :tag "Groups" regexp)
+ (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-list-identifiers 'head
+ "Strip list identifiers from `gnus-list-identifiers`.
+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-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-translate nil
+ "Translate articles from one language to another.
+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)
+
;;; Internal variables
+(defvar article-goto-body-goes-to-point-min-p nil)
+(defvar gnus-article-wash-types nil)
+(defvar gnus-article-emphasis-alist nil)
+
+(defvar gnus-article-mime-handle-alist-1 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-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-emphasize gnus-article-emphasize)
+ (gnus-treat-display-xface gnus-article-display-x-face)
+ (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-list-identifiers gnus-article-hide-list-identifiers)
+ (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-overstrike gnus-article-treat-overstrike)
+ (gnus-treat-buttonize-head gnus-article-add-buttons-to-head)
+ (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)
(defvar gnus-article-current-summary nil)
(defvar gnus-save-article-buffer nil)
(defvar gnus-article-mode-line-format-alist
- (nconc '((?w (gnus-article-wash-status) ?s))
+ (nconc '((?w (gnus-article-wash-status) ?s)
+ (?m (gnus-article-mime-part-status) ?s))
gnus-summary-mode-line-format-alist))
(defvar gnus-number-of-articles-to-be-saved nil)
(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)
(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)
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."
- (interactive (gnus-article-hidden-arg))
- (current-buffer)
- (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 <joseph@cis.ohio-state.edu>.
- (gnus-article-hide-text-type beg (point-max) 'headers))
- ;; Work around XEmacs lossage.
- (put-text-property (point-min) beg 'invisible nil))))))))
+ "Hide unwanted headers and possibly sort them as well."
+ (interactive)
+ ;; This function might be inhibited.
+ (unless gnus-inhibit-hiding
+ (save-excursion
+ (save-restriction
+ (let ((buffer-read-only nil)
+ (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)
+ (delete-region (point-min) (point)))
+ ;; 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 the unwanted headers.
+ (add-text-properties (point-min) (+ 5 (point-min))
+ '(article-type headers dummy-invisible t))
+ (delete-region beg (point-max))))))))
(defun article-hide-boring-headers (&optional arg)
"Toggle hiding of headers that aren't very interesting.
(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))
(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
+ (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-characters "\221\222\223\224" "`'\"\""))
+ (article-translate-strings gnus-article-dumbquotes-map))
(defun article-translate-characters (from to)
"Translate all characters in the body of the article according to FROM and TO.
FROM is a string of characters to translate from; to is a string of
characters to translate to."
(save-excursion
- (goto-char (point-min))
- (when (search-forward "\n\n" nil t)
+ (when (article-goto-body)
(let ((buffer-read-only nil)
(x (make-string 225 ?x))
(i -1))
(incf i))
(translate-region (point) (point-max) x)))))
+(defun article-translate-strings (map)
+ "Translate all string in the body of the article according to MAP.
+MAP is an alist where the elements are on the form (\"from\" \"to\")."
+ (save-excursion
+ (when (article-goto-body)
+ (let ((buffer-read-only nil)
+ elem)
+ (while (setq elem (pop map))
+ (save-excursion
+ (while (search-forward (car elem) nil t)
+ (replace-match (cadr elem)))))))))
+
(defun article-treat-overstrike ()
"Translate overstrikes into bold text."
(interactive)
(save-excursion
- (goto-char (point-min))
- (when (search-forward "\n\n" nil t)
+ (when (article-goto-body)
(let ((buffer-read-only nil))
(while (search-forward "\b" nil t)
- (let ((next (following-char))
+ (let ((next (char-after))
(previous (char-after (- (point) 2))))
;; We do the boldification/underlining by hiding the
;; overstrikes and putting the proper text property
(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)
- (goto-char (point-min))
- (search-forward "\n\n" nil t)
- (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))))))
+ (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)
+ (while (not (eobp))
+ (capitalize-word 1)
+ (forward-sentence)))))
(defun article-remove-cr ()
- "Remove carriage returns from an article."
+ "Remove trailing CRs and then translate remaining CRs into LFs."
(interactive)
(save-excursion
(let ((buffer-read-only nil))
(goto-char (point-min))
+ (while (re-search-forward "\r+$" nil t)
+ (replace-match "" t t))
+ (goto-char (point-min))
(while (search-forward "\r" nil t)
- (replace-match "" t t)))))
+ (replace-match "\n" t t)))))
(defun article-remove-trailing-blank-lines ()
"Remove all trailing blank lines from the article."
(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
(save-excursion
(set-buffer gnus-article-buffer)
(let ((inhibit-point-motion-hooks t)
- buffer-read-only)
+ buffer-read-only
+ (mail-parse-charset gnus-newsgroup-charset)
+ (mail-parse-ignored-charsets
+ (save-excursion (set-buffer gnus-summary-buffer)
+ gnus-newsgroup-ignored-charsets)))
(mail-decode-encoded-word-region (point-min) (point-max)))))
(defun article-decode-charset (&optional prompt)
(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))
- (gnus-newsgroup-name
- (gnus-group-find-parameter
- gnus-newsgroup-name 'charset))))
+ (mail-content-type-get ctl 'charset))))
+ (mail-parse-charset gnus-newsgroup-charset)
+ (mail-parse-ignored-charsets
+ (save-excursion (condition-case nil
+ (set-buffer gnus-summary-buffer)
+ (error))
+ gnus-newsgroup-ignored-charsets))
buffer-read-only)
+ (if (and ctl (not (string-match "/" (car ctl))))
+ (setq ctl nil))
(goto-char (point-max))
(widen)
(forward-line 1)
(narrow-to-region (point) (point-max))
- (when (or (not ct)
- (equal (car ctl) "text/plain"))
+ (when (and (or (not ctl)
+ (equal (car ctl) "text/plain"))
+ (not (mm-uu-test)))
(mm-decode-body
charset (and cte (intern (downcase
- (gnus-strip-whitespace cte))))))))))
+ (gnus-strip-whitespace cte))))
+ (car ctl)))))))
(defun article-decode-encoded-words ()
"Remove encoded-word encoding from headers."
(let ((inhibit-point-motion-hooks t)
- (buffer-read-only nil))
+ (mail-parse-charset gnus-newsgroup-charset)
+ (mail-parse-ignored-charsets
+ (save-excursion (set-buffer gnus-summary-buffer)
+ gnus-newsgroup-ignored-charsets))
+ buffer-read-only)
(save-restriction
- (message-narrow-to-head)
+ (article-narrow-to-head)
(funcall gnus-decode-header-function (point-min) (point-max)))))
(defun article-de-quoted-unreadable (&optional force)
(interactive (list 'force))
(save-excursion
(let ((buffer-read-only nil)
- (type (gnus-fetch-field "content-transfer-encoding")))
+ (type (gnus-fetch-field "content-transfer-encoding"))
+ (charset gnus-newsgroup-charset))
(when (or force
(and type (string-match "quoted-printable" (downcase type))))
- (goto-char (point-min))
- (search-forward "\n\n" nil 'move)
- (quoted-printable-decode-region (point) (point-max))))))
+ (article-goto-body)
+ (save-restriction
+ (narrow-to-region (point) (point-max))
+ (quoted-printable-decode-region (point-min) (point-max))
+ (when charset
+ (mm-decode-body charset)))))))
-(defun article-mime-decode-quoted-printable-buffer ()
- "Decode Quoted-Printable in the current buffer."
- (quoted-printable-decode-region (point-min) (point-max)))
+(defun article-hide-list-identifiers ()
+ "Remove any list identifiers in `gnus-list-identifiers' from Subject
+header in the current article."
+ (interactive)
+ (save-excursion
+ (save-restriction
+ (let ((inhibit-point-motion-hooks t)
+ buffer-read-only)
+ (article-narrow-to-head)
+ (let ((regexp (if (stringp gnus-list-identifiers) gnus-list-identifiers
+ (mapconcat 'identity gnus-list-identifiers " *\\|"))))
+ (when regexp
+ (goto-char (point-min))
+ (when (re-search-forward
+ (concat "^Subject: +\\(Re: +\\)?\\(" regexp " *\\)")
+ nil t)
+ (delete-region (match-beginning 2) (match-end 0)))))))))
-(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))))
(setq beg (point))
;; Hide the actual signature.
(and (search-forward "\n-----BEGIN PGP SIGNATURE-----\n" nil t)
(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-babel ()
+ "Translate article using an online translation service."
+ (interactive)
+ (require 'babel)
+ (save-excursion
+ (set-buffer gnus-article-buffer)
+ (when (article-goto-body)
+ (let* ((buffer-read-only nil)
+ (start (point))
+ (end (point-max))
+ (orig (buffer-substring start end))
+ (trans (babel-as-string orig)))
+ (save-restriction
+ (narrow-to-region start end)
+ (delete-region start end)
+ (insert trans))))))
(defun article-hide-signature (&optional arg)
"Hide the signature in the current article.
(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)
(save-excursion
(let ((inhibit-point-motion-hooks t)
buffer-read-only)
- (goto-char (point-min))
- (when (search-forward "\n\n" nil t)
+ (when (article-goto-body)
(while (and (not (eobp))
(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."
+ (goto-char (point-min))
+ (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)))
+
(defun article-strip-multiple-blank-lines ()
"Replace consecutive blank lines with one empty line."
(interactive)
(let ((inhibit-point-motion-hooks t)
buffer-read-only)
;; First make all blank lines empty.
- (goto-char (point-min))
- (search-forward "\n\n" nil t)
+ (article-goto-body)
(while (re-search-forward "^[ \t]+$" nil t)
(unless (gnus-annotation-in-region-p
(match-beginning 0) (match-end 0))
(replace-match "" nil t)))
;; Then replace multiple empty lines with a single empty line.
- (goto-char (point-min))
- (search-forward "\n\n" nil t)
+ (article-goto-body)
(while (re-search-forward "\n\n\n+" nil t)
(unless (gnus-annotation-in-region-p
(match-beginning 0) (match-end 0))
(save-excursion
(let ((inhibit-point-motion-hooks t)
buffer-read-only)
- (goto-char (point-min))
- (search-forward "\n\n" nil t)
+ (article-goto-body)
(while (re-search-forward "^[ \t]+" nil t)
(replace-match "" t t)))))
+(defun article-strip-trailing-space ()
+ "Remove all white space from the end of the lines in the article."
+ (interactive)
+ (save-excursion
+ (let ((inhibit-point-motion-hooks t)
+ buffer-read-only)
+ (article-goto-body)
+ (while (re-search-forward "[ \t]+$" nil t)
+ (replace-match "" t t)))))
+
(defun article-strip-blank-lines ()
"Strip leading, trailing and multiple blank lines."
(interactive)
(save-excursion
(let ((inhibit-point-motion-hooks t)
buffer-read-only)
- (goto-char (point-min))
- (search-forward "\n\n" nil t)
+ (article-goto-body)
(while (re-search-forward "^[ \t]*\n" nil t)
(replace-match "" t t)))))
-(defvar mime::preview/content-list)
-(defvar mime::preview-content-info/point-min)
(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 (and (boundp 'mime::preview/content-list)
- mime::preview/content-list)
- ;; We have a MIMEish article, so we use the MIME data to narrow.
- (let ((pcinfo (car (last mime::preview/content-list))))
- (ignore-errors
- (narrow-to-region
- (funcall (intern "mime::preview-content-info/point-min") pcinfo)
- (point-max)))))
-
(when (gnus-article-search-signature)
(forward-line 1)
;; Check whether we have some limits to what we consider
(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
means show, 0 means toggle."
(save-excursion
(save-restriction
- (widen)
(let ((hide (gnus-article-hidden-text-p type)))
(cond
((or (null arg)
"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
'hidden
- 'shown)))
+ nil)))
(defun gnus-article-show-hidden-text (type &optional hide)
"Show all hidden text of type TYPE.
(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)
(message-fetch-field "date")
""))
+ (tdate-regexp "^Date:[ \t]\\|^X-Sent:[ \t]")
+ (date-regexp
+ (cond
+ ((not gnus-article-date-lapsed-new-header)
+ tdate-regexp)
+ ((eq type 'lapsed)
+ "^X-Sent:[ \t]")
+ (t
+ "^Date:[ \t]")))
(date (if (vectorp header) (mail-header-date header)
header))
- (date-regexp "^Date:[ \t]\\|^X-Sent:[ \t]")
(inhibit-point-motion-hooks t)
- bface eface newline)
+ (newline t)
+ bface eface)
(when (and date (not (string= date "")))
(save-excursion
(save-restriction
- (nnheader-narrow-to-headers)
+ (article-narrow-to-head)
+ (when (re-search-forward tdate-regexp nil t)
+ (setq bface (get-text-property (gnus-point-at-bol) 'face)
+ date (or (get-text-property (gnus-point-at-bol)
+ 'original-date)
+ date)
+ eface (get-text-property (1- (gnus-point-at-eol))
+ 'face))
+ (forward-line 1))
+ (goto-char (point-min))
(let ((buffer-read-only nil))
- ;; Delete any old Date headers.
- (if (re-search-forward date-regexp nil t)
- (progn
- (setq bface (get-text-property (gnus-point-at-bol) 'face)
- eface (get-text-property (1- (gnus-point-at-eol))
- 'face))
+ ;; Delete any old Date headers.
+ (while (re-search-forward date-regexp nil t)
+ (if newline
(delete-region (progn (beginning-of-line) (point))
(progn (end-of-line) (point)))
- (beginning-of-line))
- (goto-char (point-max))
- (setq newline t))
- (insert (article-make-date-line date type))
+ (delete-region (progn (beginning-of-line) (point))
+ (progn (forward-line 1) (point))))
+ (setq newline nil))
+ (when (re-search-forward tdate-regexp nil t)
+ (forward-line 1))
+ (insert (article-make-date-line date (or type 'ut)))
+ (when newline
+ (insert "\n")
+ (forward-line -1))
;; Do highlighting.
(beginning-of-line)
(when (looking-at "\\([^:]+\\): *\\(.*\\)$")
(put-text-property (match-beginning 1) (1+ (match-end 1))
+ 'original-date date)
+ (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."
;; functions since they aren't particularly resistant to
;; buggy dates.
((eq type 'local)
- (let ((tz (car (current-time-zone))))
- (format "Date: %s %s%04d" (current-time-string time)
- (if (> tz 0) "+" "-") (abs (/ tz 36)))))
+ (let ((tz (car (current-time-zone time))))
+ (format "Date: %s %s%02d%02d" (current-time-string time)
+ (if (> tz 0) "+" "-") (/ (abs tz) 3600)
+ (/ (% (abs tz) 3600) 60))))
;; Convert to Universal Time.
((eq type 'ut)
(concat "Date: "
(let* ((e (parse-time-string date))
(tm (apply 'encode-time e))
(ms (car tm))
- (ls (- (cadr tm) (car (current-time-zone)))))
+ (ls (- (cadr tm) (car (current-time-zone time)))))
(cond ((< ls 0) (list (1- ms) (+ ls 65536)))
((> ls 65535) (list (1+ ms) (- ls 65536)))
(t (list ms ls)))))
((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.
(interactive (gnus-article-hidden-arg))
(unless (gnus-article-check-hidden-text 'emphasis arg)
(save-excursion
- (let ((alist gnus-emphasis-alist)
+ (let ((alist (or (with-current-buffer gnus-summary-buffer
+ gnus-article-emphasis-alist)
+ gnus-emphasis-alist))
(buffer-read-only nil)
(props (append '(article-type emphasis)
gnus-hidden-properties))
regexp elem beg invisible visible face)
- (goto-char (point-min))
- (search-forward "\n\n" nil t)
+ (article-goto-body)
(setq beg (point))
(while (setq elem (pop alist))
(goto-char beg)
(match-beginning visible) (match-end visible) 'face face)
(goto-char (match-end invisible)))))))))
+(defun gnus-article-setup-highlight-words (&optional highlight-words)
+ "Setup newsgroup emphasis alist."
+ (unless gnus-article-emphasis-alist
+ (let ((name (and gnus-newsgroup-name
+ (gnus-group-real-name gnus-newsgroup-name))))
+ (make-local-variable 'gnus-article-emphasis-alist)
+ (setq gnus-article-emphasis-alist
+ (nconc
+ (let ((alist gnus-group-highlight-words-alist) elem highlight)
+ (while (setq elem (pop alist))
+ (when (and name (string-match (car elem) name))
+ (setq alist nil
+ highlight (copy-list (cdr elem)))))
+ highlight)
+ (copy-list highlight-words)
+ (if gnus-newsgroup-name
+ (copy-list (gnus-group-find-parameter
+ gnus-newsgroup-name 'highlight-words t)))
+ gnus-emphasis-alist)))))
+
(defvar gnus-summary-article-menu)
(defvar gnus-summary-post-menu)
(save-excursion
(save-restriction
(widen)
- (rmail-output-to-rmail-file filename))))
+ (gnus-output-to-rmail filename))))
filename)
(defun gnus-summary-save-in-mail (&optional filename)
(save-excursion
(save-restriction
(widen)
- (goto-char (point-min))
- (when (search-forward "\n\n" nil t)
+ (when (article-goto-body)
(narrow-to-region (point) (point-max)))
(gnus-output-to-file filename))))
filename)
(defun gnus-summary-save-in-pipe (&optional command)
"Pipe this article to subprocess."
(setq command
- (cond ((eq command 'default)
+ (cond ((and (eq command 'default)
+ gnus-last-shell-command)
gnus-last-shell-command)
(command command)
(t (read-string
'(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-list-identifiers
article-hide-pgp
+ article-strip-banner
+ article-babel
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
article-strip-leading-space
+ article-strip-trailing-space
article-strip-blank-lines
article-strip-all-blank-lines
article-date-local
article-date-lapsed
article-emphasize
article-treat-dumbquotes
+ article-normalize-headers
(article-show-all . gnus-article-show-all-headers))))
\f
;;;
" " 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
(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)
(setq gnus-article-buffer name)
(setq gnus-original-article-buffer original)
(gnus-set-global-variables)))
+ (gnus-article-setup-highlight-words)
;; Init original article buffer.
(save-excursion
(set-buffer (gnus-get-buffer-create gnus-original-article-buffer))
(if (get-buffer name)
(save-excursion
(set-buffer name)
+ (kill-all-local-variables)
(buffer-disable-undo)
(setq buffer-read-only t)
(unless (eq major-mode 'gnus-article-mode)
(set-buffer (gnus-get-buffer-create name))
(gnus-article-mode)
(make-local-variable 'gnus-summary-buffer)
+ (gnus-summary-set-local-parameters gnus-newsgroup-name)
(current-buffer)))))
;; Set article window start at LINE, where LINE is the number of lines
(gnus-configure-windows 'summary)
(gnus-configure-windows 'article))
(gnus-set-global-variables))
- (gnus-set-mode-line 'article))
+ (let ((gnus-article-mime-handle-alist-1
+ gnus-article-mime-handle-alist))
+ (gnus-set-mode-line 'article)))
;; The result from the `request' was an actual article -
;; or at least some text that is now displayed in the
;; article buffer.
(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
- ;; <sisolak@trans4.neep.wisc.edu>.
(gnus-set-global-variables)
(setq gnus-have-all-headers
(or all-headers gnus-show-all-headers))))
(when gnus-break-pages
(gnus-narrow-to-page)
t)))
- (gnus-set-mode-line 'article)
- (gnus-configure-windows 'article)
- (goto-char (point-min))
- (search-forward "\n\n" nil t)
+ (let ((gnus-article-mime-handle-alist-1
+ gnus-article-mime-handle-alist))
+ (gnus-set-mode-line 'article))
+ (article-goto-body)
(set-window-point (get-buffer-window (current-buffer)) (point))
+ (gnus-configure-windows 'article)
t))))))
+;;;###autoload
(defun gnus-article-prepare-display ()
"Make the current buffer look like a nice article."
;; Hooks for getting information from the article.
buffer-read-only)
(unless (eq major-mode 'gnus-article-mode)
(gnus-article-mode))
+ (setq buffer-read-only nil
+ gnus-article-wash-types 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)))
+ (funcall gnus-display-mime-function))))
;;;
;;; Gnus MIME viewing functions
;;;
-(defvar gnus-mime-button-line-format "%{%([%p. %t%d%n]%)%}\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)
- (?l gnus-tmp-length ?d)))
+ (?l gnus-tmp-length ?d)
+ (?e gnus-tmp-dots ?s)))
+
+(defvar gnus-mime-button-commands
+ '((gnus-article-press-button "\r" "Toggle Display")
+ (gnus-mime-view-part "v" "View Interactively...")
+ (gnus-mime-view-part-as-type "t" "View As Type...")
+ (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...")))
+
+(defun gnus-article-mime-part-status ()
+ (if gnus-article-mime-handle-alist-1
+ (format " (%d parts)" (length gnus-article-mime-handle-alist-1))
+ ""))
(defvar gnus-mime-button-map nil)
(unless gnus-mime-button-map
- (setq gnus-mime-button-map (copy-keymap gnus-article-mode-map))
+ (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 "\r" 'gnus-article-press-button)
- (define-key gnus-mime-button-map "\M-\r" 'gnus-mime-view-part)
- (define-key gnus-mime-button-map "v" 'gnus-mime-view-part)
- (define-key gnus-mime-button-map "o" 'gnus-mime-save-part)
- (define-key gnus-mime-button-map "c" 'gnus-mime-copy-part)
- (define-key gnus-mime-button-map "i" 'gnus-mime-inline-part)
- (define-key gnus-mime-button-map "|" 'gnus-mime-pipe-part))
-
-(defun gnus-mime-view-all-parts ()
+ (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")
+ (save-excursion
+ (let ((pos (event-start event)))
+ (set-buffer (window-buffer (posn-window pos)))
+ (goto-char (posn-point pos))
+ (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)
- (let ((handles gnus-article-mime-handles))
- (while handles
- (mm-display-part (pop handles)))))
+ (save-current-buffer
+ (set-buffer gnus-article-buffer)
+ (let ((handles (or handles gnus-article-mime-handles))
+ (mail-parse-charset gnus-newsgroup-charset)
+ (mail-parse-ignored-charsets
+ (save-excursion (set-buffer gnus-summary-buffer)
+ gnus-newsgroup-ignored-charsets)))
+ (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."
(interactive)
+ (gnus-article-check-buffer)
(let ((data (get-text-property (point) 'gnus-data)))
(mm-save-part data)))
(defun gnus-mime-pipe-part ()
"Pipe the MIME part under point to a process."
(interactive)
+ (gnus-article-check-buffer)
(let ((data (get-text-property (point) 'gnus-data)))
(mm-pipe-part data)))
(defun gnus-mime-view-part ()
- "Interactively choose a view method for the MIME part under point."
+ "Interactively choose a viewing method for the MIME part under point."
(interactive)
- (let ((data (get-text-property (point) 'gnus-data))
- (url-standalone-mode (not gnus-plugged)))
+ (gnus-article-check-buffer)
+ (let ((data (get-text-property (point) 'gnus-data)))
(mm-interactively-view-part data)))
-(defun gnus-mime-copy-part ()
+(defun gnus-mime-view-part-as-type ()
+ "Choose a MIME media type, and view the part as such."
+ (interactive
+ (list (completing-read "View as MIME type: " mailcap-mime-types)))
+ (gnus-article-check-buffer)
+ (let ((handle (get-text-property (point) 'gnus-data)))
+ (gnus-mm-display-part handle)))
+
+(defun gnus-mime-copy-part (&optional handle)
"Put the the MIME part under point into a new buffer."
(interactive)
- (let* ((data (get-text-property (point) 'gnus-data))
- (contents (mm-get-part data)))
- (switch-to-buffer (generate-new-buffer "*decoded*"))
+ (gnus-article-check-buffer)
+ (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
+ (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)
+ ;; 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 ()
+(defun gnus-mime-inline-part (&optional handle)
"Insert the MIME part under point into the current buffer."
(interactive)
- (let* ((data (get-text-property (point) 'gnus-data))
- (contents (mm-get-part data))
- (url-standalone-mode (not gnus-plugged))
+ (gnus-article-check-buffer)
+ (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)
- (mm-insert-inline data contents)
+ (mm-insert-inline handle contents)
(goto-char b))))
+(defun gnus-mime-externalize-part (&optional handle)
+ "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)))
+ (mm-user-display-methods nil)
+ (mm-inline-large-images nil)
+ (mail-parse-charset gnus-newsgroup-charset)
+ (mail-parse-ignored-charsets
+ (save-excursion (set-buffer gnus-summary-buffer)
+ gnus-newsgroup-ignored-charsets)))
+ (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-inline-large-images t)
+ (mail-parse-charset gnus-newsgroup-charset)
+ (mail-parse-ignored-charsets
+ (save-excursion (set-buffer gnus-summary-buffer)
+ gnus-newsgroup-ignored-charsets)))
+ (if (mm-handle-undisplayer handle)
+ (mm-remove-part handle)
+ (mm-display-part handle))))
+
+(defun gnus-article-part-wrapper (n function)
+ (save-current-buffer
+ (set-buffer gnus-article-buffer)
+ (when (> n (length gnus-article-mime-handle-alist))
+ (error "No such part"))
+ (gnus-article-goto-part n)
+ (let ((handle (cdr (assq n gnus-article-mime-handle-alist))))
+ (funcall function handle))))
+
+(defun gnus-article-pipe-part (n)
+ "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)
+ "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)
+ "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)
+ "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")
(when (> n (length gnus-article-mime-handle-alist))
(error "No such part"))
(let ((handle (cdr (assq n gnus-article-mime-handle-alist))))
- (gnus-article-goto-part n)
- (mm-display-part handle))))
+ (when (gnus-article-goto-part n)
+ (if (equal (car handle) "multipart/alternative")
+ (gnus-article-press-button)
+ (when (eq (gnus-mm-display-part handle) 'internal)
+ (gnus-set-window-start)))))))
+
+(defun gnus-mm-display-part (handle)
+ "Display HANDLE and fix MIME button."
+ (let ((id (get-text-property (point) 'gnus-part))
+ (point (point))
+ buffer-read-only)
+ (forward-line 1)
+ (prog1
+ (let ((window (selected-window))
+ (mail-parse-charset gnus-newsgroup-charset)
+ (mail-parse-ignored-charsets
+ (save-excursion (set-buffer gnus-summary-buffer)
+ gnus-newsgroup-ignored-charsets)))
+ (save-excursion
+ (unwind-protect
+ (let ((win (get-buffer-window (current-buffer) t))
+ (beg (point)))
+ (when win
+ (select-window win))
+ (goto-char point)
+ (forward-line)
+ (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))
+ (mm-handle-media-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)
"Go to MIME part N."
- (goto-char (text-property-any (point-min) (point-max) 'gnus-part n)))
-
-(defun gnus-insert-mime-button (handle)
- (let ((gnus-tmp-name (mail-content-type-get (mm-handle-type handle) 'name))
- (gnus-tmp-type (car (mm-handle-type handle)))
- (gnus-tmp-description (mm-handle-description handle))
- (gnus-tmp-length (save-excursion
- (set-buffer (mm-handle-buffer handle))
+ (let ((point (text-property-any (point-min) (point-max) 'gnus-part n)))
+ (when point
+ (goto-char point))))
+
+(defun gnus-insert-mime-button (handle gnus-tmp-id &optional displayed)
+ (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 (mm-handle-media-type 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 (with-current-buffer (mm-handle-buffer handle)
(buffer-size)))
- (gnus-tmp-id (1+ (length gnus-article-mime-handle-alist)))
- b e)
- (push (cons gnus-tmp-id handle) gnus-article-mime-handle-alist)
- (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))
(gnus-eval-format
gnus-mime-button-line-format gnus-mime-button-line-format-alist
`(local-map ,gnus-mime-button-map
keymap ,gnus-mime-button-map
- gnus-callback mm-display-part
+ gnus-callback gnus-mm-display-part
gnus-part ,gnus-tmp-id
- gnus-type annotation
+ article-type annotation
gnus-data ,handle))
(setq e (point))
- (widget-convert-button 'link b e :action 'gnus-widget-press-button
- :button-keymap gnus-widget-button-keymap)))
+ (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 ()
- "Insert MIME buttons in the buffer."
- (let (ct ctl)
- (save-restriction
- (mail-narrow-to-head)
- (when (setq ct (mail-fetch-field "content-type"))
- (setq ctl (condition-case ()
- (mail-header-parse-content-type ct) (error nil)))))
- (let* ((handles (mm-dissect-buffer))
- handle name type b e)
- (mapcar 'mm-destroy-part gnus-article-mime-handles)
- (setq gnus-article-mime-handles handles
- gnus-article-mime-handle-alist nil)
- (when handles
- (goto-char (point-min))
- (search-forward "\n\n" nil t)
- (delete-region (point) (point-max))
- (if (not (equal (car ctl) "multipart/alternative"))
- (while (setq handle (pop handles))
- (gnus-insert-mime-button handle)
- (insert "\n\n")
- (when (and (mm-automatic-display-p
- (car (mm-handle-type handle)))
- (mm-inlinable-part-p (car (mm-handle-type handle)))
- (or (not (mm-handle-disposition handle))
- (equal (car (mm-handle-disposition handle))
- "inline")))
- (forward-line -2)
- (mm-display-part handle t)
- (goto-char (point-max))))
- ;; Here we have multipart/alternative
- (gnus-mime-display-alternative handles))))))
-
-(defun gnus-mime-display-alternative (handles &optional preferred)
- (let* ((preferred (mm-preferred-alternative handles preferred))
+(defvar gnus-displaying-mime nil)
+
+(defun gnus-display-mime (&optional ihandles)
+ "Display the MIME parts."
+ (save-excursion
+ (save-selected-window
+ (let ((window (get-buffer-window gnus-article-buffer))
+ (point (point)))
+ (when 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)))
+ buffer-read-only handle name type b e display)
+ (when (and (not ihandles)
+ (not gnus-displaying-mime))
+ ;; Top-level call; we clean up.
+ (when gnus-article-mime-handles
+ (mm-destroy-parts gnus-article-mime-handles)
+ (setq gnus-article-mime-handle-alist nil)) ;; A trick.
+ (setq gnus-article-mime-handles handles)
+ ;; We allow users to glean info from the handles.
+ (when gnus-article-mime-part-function
+ (gnus-mime-part-function handles)))
+ (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)
+ (narrow-to-region (point) (point-max))
+ (gnus-treat-article nil 1 1)
+ (widen)))
+ (if (not ihandles)
+ ;; 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
+ ((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
+ ((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)))
+ ;; Other multiparts are handled like multipart/mixed.
+ (t
+ (gnus-mime-display-mixed (cdr handle)))))
+
+(defun gnus-mime-part-function (handles)
+ (if (stringp (car handles))
+ (mapcar 'gnus-mime-part-function (cdr handles))
+ (funcall gnus-article-mime-part-function handles)))
+
+(defun gnus-mime-display-mixed (handles)
+ (mapcar 'gnus-mime-display-part handles))
+
+(defun gnus-mime-display-single (handle)
+ (let ((type (mm-handle-media-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 (setq not-attachment
+ (or (not (mm-handle-disposition handle))
+ (equal (car (mm-handle-disposition handle))
+ "inline")
+ (mm-attachment-override-p handle)))
+ (mm-automatic-display-p handle)
+ (or (mm-inlined-p handle)
+ (mm-automatic-external-display-p type)))
+ (setq display t)
+ (when (equal (mm-handle-media-supertype handle) "text")
+ (setq text t)))
+ (let ((id (1+ (length gnus-article-mime-handle-alist))))
+ (push (cons id handle) gnus-article-mime-handle-alist)
+ (when (or (not display)
+ (not (gnus-unbuttonized-mime-type-p type)))
+ (gnus-article-insert-newline)
+ (gnus-insert-mime-button
+ 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)
+ (setq beg (point)))
+ (let ((mail-parse-charset gnus-newsgroup-charset)
+ (mail-parse-ignored-charsets
+ (save-excursion (set-buffer gnus-summary-buffer)
+ gnus-newsgroup-ignored-charsets)))
+ (mm-display-part handle t))
+ (goto-char (point-max)))
+ ((and text not-attachment)
+ (when move
+ (forward-line -2)
+ (setq beg (point)))
+ (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))
+ (mm-handle-media-type handle)))))))))
+
+(defun gnus-unbuttonized-mime-type-p (type)
+ "Say whether TYPE is to be unbuttonized."
+ (unless gnus-inhibit-mime-unbuttonizing
+ (catch 'found
+ (let ((types gnus-unbuttonized-mime-types))
+ (while types
+ (when (string-match (pop types) type)
+ (throw 'found t)))))))
+
+(defun gnus-article-insert-newline ()
+ "Insert a newline, but mark it as undeletable."
+ (gnus-put-text-property
+ (point) (progn (insert "\n") (point)) 'gnus-undeletable t))
+
+(defun gnus-mime-display-alternative (handles &optional preferred ibegend id)
+ (let* ((preferred (or preferred (mm-preferred-alternative handles)))
(ihandles handles)
- handle buffer-read-only)
- (goto-char (point-min))
- (search-forward "\n\n" nil t)
- (delete-region (point) (point-max))
- (mapcar 'mm-remove-part gnus-article-mime-handles)
- (setq gnus-article-mime-handles handles)
- (while (setq handle (pop handles))
- (gnus-add-text-properties
- (point)
- (progn
- (insert (format "[%c] %-18s"
- (if (equal handle preferred) ?* ? )
- (car (mm-handle-type handle))))
- (point))
- `(local-map ,gnus-mime-button-map
- ,gnus-mouse-face-prop ,gnus-article-mouse-face
- face ,gnus-article-button-face
- keymap ,gnus-mime-button-map
- gnus-callback
- (lambda (handles)
- (gnus-mime-display-alternative
- ',ihandles ,(car (mm-handle-type handle))))
- gnus-data ,handle))
- (insert " "))
- (insert "\n\n")
- (when preferred
- (mm-display-part preferred))))
+ (point (point))
+ handle buffer-read-only from props begend not-pref)
+ (save-window-excursion
+ (save-restriction
+ (when ibegend
+ (narrow-to-region (car ibegend)
+ (or (cdr ibegend)
+ (progn
+ (goto-char (car ibegend))
+ (forward-line 2)
+ (point))))
+ (delete-region (point-min) (point-max))
+ (mm-remove-parts handles))
+ (setq begend (list (point-marker)))
+ ;; Do the toggle.
+ (unless (setq not-pref (cadr (member preferred ihandles)))
+ (setq not-pref (car ihandles)))
+ (when (or ibegend
+ (not (gnus-unbuttonized-mime-type-p
+ "multipart/alternative")))
+ (gnus-add-text-properties
+ (setq from (point))
+ (progn
+ (insert (format "%d. " id))
+ (point))
+ `(gnus-callback
+ (lambda (handles)
+ (unless ,(not ibegend)
+ (setq gnus-article-mime-handle-alist
+ ',gnus-article-mime-handle-alist))
+ (gnus-mime-display-alternative
+ ',ihandles ',not-pref ',begend ,id))
+ local-map ,gnus-mime-button-map
+ ,gnus-mouse-face-prop ,gnus-article-mouse-face
+ face ,gnus-article-button-face
+ keymap ,gnus-mime-button-map
+ gnus-part ,id
+ gnus-data ,handle))
+ (widget-convert-button 'link from (point)
+ :action 'gnus-widget-press-button
+ :button-keymap gnus-widget-button-keymap)
+ ;; Do the handles
+ (while (setq handle (pop handles))
+ (gnus-add-text-properties
+ (setq from (point))
+ (progn
+ (insert (format "(%c) %-18s"
+ (if (equal handle preferred) ?* ? )
+ (mm-handle-media-type handle)))
+ (point))
+ `(gnus-callback
+ (lambda (handles)
+ (unless ,(not ibegend)
+ (setq gnus-article-mime-handle-alist
+ ',gnus-article-mime-handle-alist))
+ (gnus-mime-display-alternative
+ ',ihandles ',handle ',begend ,id))
+ local-map ,gnus-mime-button-map
+ ,gnus-mouse-face-prop ,gnus-article-mouse-face
+ face ,gnus-article-button-face
+ keymap ,gnus-mime-button-map
+ gnus-part ,id
+ gnus-data ,handle))
+ (widget-convert-button 'link from (point)
+ :action 'gnus-widget-press-button
+ :button-keymap gnus-widget-button-keymap)
+ (insert " "))
+ (insert "\n\n"))
+ (when preferred
+ (if (stringp (car preferred))
+ (gnus-display-mime preferred)
+ (let ((mail-parse-charset gnus-newsgroup-charset)
+ (mail-parse-ignored-charsets
+ (save-excursion (set-buffer gnus-summary-buffer)
+ gnus-newsgroup-ignored-charsets)))
+ (mm-display-part preferred)
+ ;; Do highlighting.
+ (save-excursion
+ (save-restriction
+ (narrow-to-region (car begend) (point-max))
+ (gnus-treat-article
+ nil (length gnus-article-mime-handle-alist)
+ (1- (length gnus-article-mime-handles))
+ (mm-handle-media-type handle))))))
+ (goto-char (point-max))
+ (setcdr begend (point-marker)))))
+ (when ibegend
+ (goto-char point))))
(defun gnus-article-wash-status ()
"Return a string which display status of article washing."
(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%c"
+ (let ((cite (memq 'cite gnus-article-wash-types))
+ (headers (memq 'headers gnus-article-wash-types))
+ (boring (memq 'boring-headers gnus-article-wash-types))
+ (pgp (memq 'pgp gnus-article-wash-types))
+ (pem (memq 'pem gnus-article-wash-types))
+ (signature (memq 'signature gnus-article-wash-types))
+ (overstrike (memq 'overstrike gnus-article-wash-types))
+ (emphasis (memq 'emphasis gnus-article-wash-types)))
+ (format "%c%c%c%c%c%c"
(if cite ?c ? )
(if (or headers boring) ?h ? )
(if (or pgp pem) ?p ? )
(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.
;; save it to file.
(goto-char (point-max))
(insert "\n")
- (append-to-file (point-min) (point-max) file-name)
+ (mm-append-to-file (point-min) (point-max) file-name)
t)))
(defun gnus-narrow-to-page (&optional arg)
(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."
(setq func (lookup-key (current-local-map) (this-command-keys)))
(call-interactively func)))
+(defun gnus-article-check-buffer ()
+ "Beep if not in an article buffer."
+ (unless (equal major-mode 'gnus-article-mode)
+ (error "Command invoked outside of a Gnus article buffer")))
+
(defun gnus-article-read-summary-keys (&optional arg key not-restore-window)
"Read a summary buffer key sequence and execute it from the article buffer."
(interactive "P")
+ (gnus-article-check-buffer)
(let ((nosaves
'("q" "Q" "c" "r" "R" "\C-c\C-f" "m" "a" "f" "F"
"Zc" "ZC" "ZE" "ZQ" "ZZ" "Zn" "ZR" "ZG" "ZN" "ZP"
(set-buffer gnus-article-current-summary)
(let (gnus-pick-mode)
(push (or key last-command-event) unread-command-events)
- (setq keys (read-key-sequence nil))))
+ (setq keys (if gnus-xemacs
+ (events-to-keys (read-key-sequence nil))
+ (read-key-sequence nil)))))
+
(message "")
(if (or (member keys nosaves)
(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))))))))
If given a prefix, show the hidden text instead."
(interactive (append (gnus-article-hidden-arg) (list 'force)))
(gnus-article-hide-headers arg)
+ (gnus-article-hide-list-identifiers arg)
(gnus-article-hide-pgp arg)
(gnus-article-hide-citation-maybe arg force)
(gnus-article-hide-signature arg))
(defvar gnus-article-edit-mode-map nil)
+;; Should we be using derived.el for this?
(unless gnus-article-edit-mode-map
- (setq gnus-article-edit-mode-map (copy-keymap text-mode-map))
+ (setq gnus-article-edit-mode-map (make-sparse-keymap))
+ (set-keymap-parent gnus-article-edit-mode-map text-mode-map)
(gnus-define-keys gnus-article-edit-mode-map
"\C-c\C-c" gnus-article-edit-done
(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-configure-windows 'edit-article)
(setq gnus-article-edit-done-function exit-func)
(setq gnus-prev-winconf winconf)
(save-excursion
(save-restriction
(widen)
- (goto-char (point-min))
- (when (search-forward "\n\n" nil 1)
+ (when (article-goto-body)
(let ((lines (count-lines (point) (point-max)))
(length (- (point-max) (point)))
(case-fold-search t)
(save-excursion
(set-buffer buf)
(let ((buffer-read-only nil))
- (funcall func arg)))
+ (funcall func arg))
+ ;; 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)))
+ ;; Flush original article as well.
+ (save-excursion
+ (when (get-buffer gnus-original-article-buffer)
+ (set-buffer gnus-original-article-buffer)
+ (setq gnus-original-article nil)))
+ (when gnus-use-cache
+ (gnus-cache-update-article
+ (car gnus-article-current) (cdr gnus-article-current))))
(set-buffer buf)
(set-window-start (get-buffer-window buf) start)
(set-window-point (get-buffer-window buf) (point))))
(insert buf)
(let ((winconf gnus-prev-winconf))
(gnus-article-mode)
- ;; The cache and backlog have to be flushed somewhat.
- (when gnus-use-cache
- (gnus-cache-update-article
- (car gnus-article-current) (cdr gnus-article-current)))
- (when gnus-keep-backlog
- (gnus-backlog-remove-article
- (car gnus-article-current) (cdr gnus-article-current)))
- ;; Flush original article as well.
- (save-excursion
- (when (get-buffer gnus-original-article-buffer)
- (set-buffer gnus-original-article-buffer)
- (setq gnus-original-article nil)))
(set-window-configuration winconf)
;; Tippy-toe some to make sure that point remains where it was.
(save-current-buffer
:type 'regexp)
(defcustom gnus-button-alist
- `(("<\\(url:[>\n\t ]*?\\)?news:[>\n\t ]*\\([^>\n\t ]*@[^>\n\t ]*\\)>" 0 t
- gnus-button-message-id 2)
- ("\\bnews:\\([^>\n\t ]*@[^>\n\t ]*\\)" 0 t gnus-button-message-id 1)
+ `(("<\\(url:[>\n\t ]*?\\)?news:[>\n\t ]*\\([^>\n\t ]*@[^>\n\t ]*\\)>"
+ 0 t gnus-button-message-id 2)
+ ("\\bnews:\\([^>\n\t ]*@[^>)!;:,\n\t ]*\\)" 0 t gnus-button-message-id 1)
("\\(\\b<\\(url:[>\n\t ]*\\)?news:[>\n\t ]*\\(//\\)?\\([^>\n\t ]*\\)>\\)"
1 t
gnus-button-fetch-group 4)
(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 "^\\("
(alist gnus-button-alist)
beg entry regexp)
;; Remove all old markers.
- (let (marker entry)
+ (let (marker entry new-list)
(while (setq marker (pop gnus-button-marker-list))
- (goto-char marker)
- (when (setq entry (gnus-button-entry))
- (put-text-property (match-beginning (nth 1 entry))
- (match-end (nth 1 entry))
- 'gnus-callback nil))
- (set-marker marker nil)))
+ (if (or (< marker (point-min)) (>= marker (point-max)))
+ (push marker new-list)
+ (goto-char marker)
+ (when (setq entry (gnus-button-entry))
+ (put-text-property (match-beginning (nth 1 entry))
+ (match-end (nth 1 entry))
+ 'gnus-callback nil))
+ (set-marker marker nil)))
+ (setq gnus-button-marker-list new-list))
;; We skip the headers.
- (goto-char (point-min))
- (unless (search-forward "\n\n" nil t)
- (goto-char (point-max)))
+ (article-goto-body)
(setq beg (point))
(while (setq entry (pop alist))
(setq regexp (car entry))
(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:
(defun gnus-button-push (marker)
;; Push button starting at MARKER.
(save-excursion
- (set-buffer gnus-article-buffer)
(goto-char marker)
(let* ((entry (gnus-button-entry))
(inhibit-point-motion-hooks t)
gnus-prev-page-line-format nil
`(gnus-prev t local-map ,gnus-prev-page-map
gnus-callback gnus-article-button-prev-page
- gnus-type annotation))))
+ article-type annotation))))
(defvar gnus-next-page-map nil)
(unless gnus-next-page-map
`(gnus-next
t local-map ,gnus-next-page-map
gnus-callback gnus-article-button-next-page
- gnus-type annotation))))
+ article-type annotation))))
(defun gnus-article-button-next-page (arg)
"Go to the next page."
(gnus-article-prev-page)
(select-window win)))
+(defvar gnus-decode-header-methods
+ '(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:
+((\"chinese\" . gnus-decode-encoded-word-region-by-guess)
+ mail-decode-encoded-word-region
+ (\"chinese\" . rfc1843-decode-region))
+")
+
+(defvar gnus-decode-header-methods-cache nil)
+
+(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
+ (car gnus-decode-header-methods-cache)))
+ (setq gnus-decode-header-methods-cache (list gnus-newsgroup-name))
+ (mapc '(lambda (x)
+ (if (symbolp x)
+ (nconc gnus-decode-header-methods-cache (list x))
+ (if (and gnus-newsgroup-name
+ (string-match (car x) gnus-newsgroup-name))
+ (nconc gnus-decode-header-methods-cache
+ (list (cdr x))))))
+ gnus-decode-header-methods))
+ (let ((xlist gnus-decode-header-methods-cache))
+ (pop xlist)
+ (save-restriction
+ (narrow-to-region start end)
+ (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
+ (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))
+ ((and (listp val)
+ (stringp (car val)))
+ (apply 'gnus-or (mapcar `(lambda (s)
+ (string-match s ,(or gnus-newsgroup-name "")))
+ 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-treat-predicate val)))
+ ((eq pred 'not)
+ (not (gnus-treat-predicate (car 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))))
+
(gnus-ems-redefine)
(provide 'gnus-art)
projects / elisp / gnus.git- / blobdiff