Mercurial > emacs
diff lisp/gnus/gnus-art.el @ 31716:9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
| author | Gerd Moellmann <gerd@gnu.org> |
|---|---|
| date | Tue, 19 Sep 2000 13:37:09 +0000 |
| parents | 925a1c3dd62a |
| children | 51cea22fd2aa |
line wrap: on
line diff
--- a/lisp/gnus/gnus-art.el Tue Sep 19 13:28:27 2000 +0000 +++ b/lisp/gnus/gnus-art.el Tue Sep 19 13:37:09 2000 +0000 @@ -1,5 +1,5 @@ ;;; gnus-art.el --- article mode commands for Gnus -;; Copyright (C) 1996,97,98 Free Software Foundation, Inc. +;; Copyright (C) 1996, 1997, 1998, 1999, 2000 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> ;; Keywords: news @@ -27,20 +27,27 @@ (eval-when-compile (require 'cl)) -(eval-when-compile (require 'cl)) - -(require 'custom) (require 'gnus) (require 'gnus-sum) (require 'gnus-spec) (require 'gnus-int) -(require 'browse-url) +(require 'mm-bodies) +(require 'mail-parse) +(require 'mm-decode) +(require 'mm-view) +(require 'wid-edit) +(require 'mm-uu) (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") @@ -107,11 +114,19 @@ "^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:" + "^X-Received:" "^Content-length:" "X-precedence:") "*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." @@ -121,7 +136,7 @@ :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." @@ -152,8 +167,8 @@ (const :tag "Followup-to identical to newsgroups." followup-to) (const :tag "Reply-to identical to from." reply-to) (const :tag "Date less than four days old." date) - (const :tag "Very long To header." long-to) - (const :tag "Multiple To headers." many-to)) + (const :tag "Very long To and/or Cc header." long-to) + (const :tag "Multiple To and/or Cc headers." many-to)) :group 'gnus-article-hiding) (defcustom gnus-signature-separator '("^-- $" "^-- *$") @@ -165,7 +180,7 @@ :group 'gnus-article-signature) (defcustom gnus-signature-limit nil - "Provide a limit to what is considered a signature. + "Provide a limit to what is considered a signature. If it is a number, no signature may not be longer (in characters) than that number. If it is a floating point number, no signature may be longer (in lines) than that number. If it is a function, the function @@ -183,12 +198,20 @@ :type 'sexp :group 'gnus-article-hiding) +;; Fixme: This isn't the right thing for mixed graphical and and +;; non-graphical frames in a session. +;; gnus-xmas.el overrides this for XEmacs. (defcustom gnus-article-x-face-command - "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | xv -quit -" + (if (and (fboundp 'image-type-available-p) + (image-type-available-p 'xbm)) + 'gnus-article-display-xface + "{ 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." - :type 'string ;Leave function case to Lisp. + :type '(choice string + (function-item gnus-article-display-xface) + function) :group 'gnus-article-washing) (defcustom gnus-article-x-face-too-ugly nil @@ -198,7 +221,7 @@ (defcustom gnus-emphasis-alist (let ((format - "\\(\\s-\\|^\\|[-\"]\\|\\s(\\|\\s)\\)\\(%s\\(\\w+\\(\\s-+\\w+\\)*[.,]?\\)%s\\)\\(\\s-\\|[-?!.,;:\"]\\|\\s(\\|\\s)\\)") + "\\(\\s-\\|^\\|[-\"]\\|\\s(\\)\\(%s\\(\\w+\\(\\s-+\\w+\\)*[.,]?\\)%s\\)\\(\\s-\\|[-,;:\"]\\s-\\|[?!.]+\\s-\\|\\s)\\)") (types '(("_" "_" underline) ("/" "/" italic) @@ -232,6 +255,14 @@ face)) :group 'gnus-article-emphasis) +(defcustom gnus-emphasize-whitespace-regexp "^[ \t]+\\|[ \t]*\n" + "A regexp to describe whitespace which should not be emphasized. +Typical values are \"^[ \\t]+\\\\|[ \\t]*\\n\" and \"[ \\t]+\\\\|[ \\t]*\\n\". +The former avoids underlining of leading and trailing whitespace, +and the latter avoids underlining any whitespace at all." + :group 'gnus-article-emphasis + :type 'regexp) + (defface gnus-emphasis-bold '((t (:bold t))) "Face used for displaying strong emphasized text (*word*)." :group 'gnus-article-emphasis) @@ -262,6 +293,11 @@ 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. @@ -274,8 +310,6 @@ :group 'gnus-article-washing) (eval-and-compile - (autoload 'hexl-hex-string-to-integer "hexl") - (autoload 'timezone-make-date-arpa-standard "timezone") (autoload 'mail-extract-address-components "mail-extr")) (defcustom gnus-save-all-headers t @@ -377,34 +411,6 @@ (cons :value ("" "") regexp (repeat string)) (sexp :value nil)))) -(defcustom gnus-strict-mime t - "*If nil, MIME-decode even if there is no Mime-Version header." - :group 'gnus-article-mime - :type 'boolean) - -(defcustom gnus-show-mime-method 'metamail-buffer - "Function to process a MIME message. -The function is called from the article buffer." - :group 'gnus-article-mime - :type 'function) - -(defcustom gnus-decode-encoded-word-method 'gnus-article-de-quoted-unreadable - "*Function to decode MIME encoded words. -The function is called from the article buffer." - :group 'gnus-article-mime - :type 'function) - -(defcustom gnus-show-traditional-method - (if (and (featurep 'mule) - (boundp 'enable-multibyte-characters)) - (lambda () - (if enable-multibyte-characters (gnus-mule-decode-article))) - (lambda ())) - "Function to decode ``localized RFC 822 messages''. -The function is called from the article buffer." - :group 'gnus-article-mime - :type 'function) - (defcustom gnus-page-delimiter "^\^L" "*Regexp describing what to use as article page delimiters. The default value is \"^\^L\", which is a form linefeed at the @@ -412,9 +418,14 @@ :type 'regexp :group 'gnus-article-various) -(defcustom gnus-article-mode-line-format "Gnus: %%b %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) @@ -429,8 +440,7 @@ :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) @@ -559,8 +569,410 @@ (item :tag "skip" nil) (face :value default))))) +(defcustom gnus-article-decode-hook + '(article-decode-charset article-decode-encoded-words) + "*Hook run to decode charsets in articles." + :group 'gnus-article-headers + :type 'hook) + +(defcustom gnus-display-mime-function 'gnus-display-mime + "Function to display MIME articles." + :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) + +(defcustom gnus-article-mime-match-handle-function 'undisplayed-alternative + "Function called with a MIME handle as the argument. +This is meant for people who want to view first matched part. +For `undisplayed-alternative' (default), the first undisplayed +part or alternative part is used. For `undisplayed', the first +undisplayed part is used. For a function, the first part which +the function return `t' is used. For `nil', the first part is +used." + :group 'gnus-article-mime + :type '(choice + (item :tag "first" :value nil) + (item :tag "undisplayed" :value undisplayed) + (item :tag "undisplayed or alternative" + :value undisplayed-alternative) + (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") + (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 100000 + "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 50000 + "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-capitalize-sentences gnus-article-capitalize-sentences) + (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) @@ -576,7 +988,8 @@ (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) @@ -590,7 +1003,6 @@ (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) @@ -600,11 +1012,14 @@ (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) @@ -653,79 +1068,60 @@ 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. + (push 'headers gnus-article-wash-types) + (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. @@ -740,14 +1136,14 @@ (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)) @@ -782,15 +1178,19 @@ ((eq elem 'date) (let ((date (message-fetch-field "date"))) (when (and date - (< (gnus-days-between (current-time-string) date) + (< (days-between (current-time-string) date) 4)) (gnus-article-hide-header "date")))) ((eq elem 'long-to) - (let ((to (message-fetch-field "to"))) + (let ((to (message-fetch-field "to")) + (cc (message-fetch-field "cc"))) (when (> (length to) 1024) - (gnus-article-hide-header "to")))) + (gnus-article-hide-header "to")) + (when (> (length cc) 1024) + (gnus-article-hide-header "cc")))) ((eq elem 'many-to) - (let ((to-count 0)) + (let ((to-count 0) + (cc-count 0)) (goto-char (point-min)) (while (re-search-forward "^to:" nil t) (setq to-count (1+ to-count))) @@ -802,7 +1202,19 @@ (forward-line -1) (narrow-to-region (point) (point-max)) (gnus-article-hide-header "to")) - (setq to-count (1- to-count))))))))))))) + (setq to-count (1- to-count)))) + (goto-char (point-min)) + (while (re-search-forward "^cc:" nil t) + (setq cc-count (1+ cc-count))) + (when (> cc-count 1) + (while (> cc-count 0) + (goto-char (point-min)) + (save-restriction + (re-search-forward "^cc:" nil nil cc-count) + (forward-line -1) + (narrow-to-region (point) (point-max)) + (gnus-article-hide-header "cc")) + (setq cc-count (1- cc-count))))))))))))) (defun gnus-article-hide-header (header) (save-excursion @@ -817,18 +1229,50 @@ (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\223" "`'\"\"")) + (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)) @@ -840,15 +1284,26 @@ (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 @@ -867,32 +1322,46 @@ (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." @@ -904,7 +1373,9 @@ (point) (progn (while (and (not (bobp)) - (looking-at "^[ \t]*$")) + (looking-at "^[ \t]*$") + (not (gnus-annotation-in-region-p + (point) (gnus-point-at-eol)))) (forward-line -1)) (forward-line 1) (point)))))) @@ -920,7 +1391,8 @@ (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 @@ -959,99 +1431,176 @@ (process-send-region "article-x-face" beg end) (process-send-eof "article-x-face")))))))))) -(defun gnus-hack-decode-rfc1522 () - "Emergency hack function for avoiding problems when decoding." - (let ((buffer-read-only nil)) - (goto-char (point-min)) - ;; Remove encoded TABs. - (while (search-forward "=09" nil t) - (replace-match " " t t)) - ;; Remove encoded newlines. - (goto-char (point-min)) - (while (search-forward "=10" nil t) - (replace-match " " t t)))) - -(defalias 'gnus-decode-rfc1522 'article-decode-rfc1522) -(defalias 'gnus-article-decode-rfc1522 'article-decode-rfc1522) -(defun article-decode-rfc1522 () - "Hack to remove QP encoding from headers." - (let ((case-fold-search t) - (inhibit-point-motion-hooks t) - (buffer-read-only nil) - string) +(defun article-decode-mime-words () + "Decode all MIME-encoded words in the article." + (interactive) + (save-excursion + (set-buffer gnus-article-buffer) + (let ((inhibit-point-motion-hooks t) + 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) + "Decode charset-encoded text in the article. +If PROMPT (the prefix), prompt for a coding system to use." + (interactive "P") + (let ((inhibit-point-motion-hooks t) (case-fold-search t) + buffer-read-only + (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)) + ct cte ctl charset format) + (save-excursion (save-restriction - (narrow-to-region - (goto-char (point-min)) - (or (search-forward "\n\n" nil t) (point-max))) - (goto-char (point-min)) - (while (re-search-forward - "=\\?iso-8859-1\\?q\\?\\([^?\t\n]*\\)\\?=" nil t) - (setq string (match-string 1)) - (save-restriction - (narrow-to-region (match-beginning 0) (match-end 0)) - (delete-region (point-min) (point-max)) - (insert string) - (article-mime-decode-quoted-printable - (goto-char (point-min)) (point-max)) - (subst-char-in-region (point-min) (point-max) ?_ ? ) - (goto-char (point-max))) - (goto-char (point-min)))))) + (article-narrow-to-head) + (setq ct (message-fetch-field "Content-Type" t) + cte (message-fetch-field "Content-Transfer-Encoding" t) + 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))) + format (and ctl (mail-content-type-get ctl 'format))) + (when cte + (setq cte (mail-header-strip cte))) + (if (and ctl (not (string-match "/" (car ctl)))) + (setq ctl nil)) + (goto-char (point-max))) + (forward-line 1) + (save-restriction + (narrow-to-region (point) (point-max)) + (when (and (eq mail-parse-charset 'gnus-decoded) + (eq (mm-body-7-or-8) '8bit)) + ;; The text code could have been decoded. + (setq charset mail-parse-charset)) + (when (and (or (not ctl) + (equal (car ctl) "text/plain")) + (not format)) ;; article with format will decode later. + (mm-decode-body + charset (and cte (intern (downcase + (gnus-strip-whitespace cte)))) + (car ctl))))))) + +(defun article-decode-encoded-words () + "Remove encoded-word encoding from headers." + (let ((inhibit-point-motion-hooks t) + (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) + (save-restriction + (article-narrow-to-head) + (funcall gnus-decode-header-function (point-min) (point-max))))) (defun article-de-quoted-unreadable (&optional force) - "Do a naive translation of a quoted-printable-encoded article. -This is in no way, shape or form meant as a replacement for real MIME -processing, but is simply a stop-gap measure until MIME support is -written. + "Translate a quoted-printable-encoded article. If FORCE, decode the article whether it is marked as quoted-printable or not." (interactive (list 'force)) (save-excursion - (let ((case-fold-search t) - (buffer-read-only nil) - (type (gnus-fetch-field "content-transfer-encoding"))) - (gnus-article-decode-rfc1522) + (let ((buffer-read-only nil) + (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) - (article-mime-decode-quoted-printable (point) (point-max)))))) - -(defun article-mime-decode-quoted-printable-buffer () - "Decode Quoted-Printable in the current buffer." - (article-mime-decode-quoted-printable (point-min) (point-max))) - -(defun article-mime-decode-quoted-printable (from to) - "Decode Quoted-Printable in the region between FROM and TO." - (interactive "r") - (goto-char from) - (while (search-forward "=" to t) - (cond ((eq (following-char) ?\n) - (delete-char -1) - (delete-char 1)) - ((looking-at "[0-9A-F][0-9A-F]") - (subst-char-in-region - (1- (point)) (point) ?= - (hexl-hex-string-to-integer - (buffer-substring (point) (+ 2 (point))))) - (delete-char 2)) - ((looking-at "=") - (delete-char 1)) - ((gnus-message 3 "Malformed MIME quoted-printable message"))))) - -(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 + (article-goto-body) + (quoted-printable-decode-region (point) (point-max) charset))))) + +(defun article-de-base64-unreadable (&optional force) + "Translate a base64 article. +If FORCE, decode the article whether it is marked as base64 not." + (interactive (list 'force)) + (save-excursion + (let ((buffer-read-only nil) + (type (gnus-fetch-field "content-transfer-encoding")) + (charset gnus-newsgroup-charset)) + (when (or force + (and type (string-match "base64" (downcase type)))) + (article-goto-body) + (save-restriction + (narrow-to-region (point) (point-max)) + (base64-decode-region (point-min) (point-max)) + (if (mm-coding-system-p charset) + (mm-decode-coding-region (point-min) (point-max) charset))))))) + +(eval-when-compile + (require 'rfc1843)) + +(defun article-decode-HZ () + "Translate a HZ-encoded article." + (interactive) + (require 'rfc1843) + (save-excursion + (let ((buffer-read-only nil)) + (rfc1843-decode-region (point-min) (point-max))))) + +(defun article-wash-html () + "Format an html article." + (interactive) + (save-excursion + (let ((buffer-read-only nil) + (charset gnus-newsgroup-charset)) + (article-goto-body) + (save-window-excursion + (save-restriction + (narrow-to-region (point) (point-max)) + (mm-setup-w3) + (let ((w3-strict-width (window-width)) + (url-standalone-mode t)) + (condition-case var + (w3-region (point-min) (point-max)) + (error)))))))) + +(defun article-hide-list-identifiers () + "Remove list identifies from the Subject header. +The `gnus-list-identifiers' variable specifies what to do." + (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 + " *\\)\\)+\\(Re: +\\)?\\)") + nil t) + (let ((s (or (match-string 3) (match-string 5)))) + (delete-region (match-beginning 1) (match-end 1)) + (when s + (goto-char (match-beginning 1)) + (insert s)))))))))) + +(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)) + ;; Remove armor headers (rfc2440 6.2) + (delete-region (point) (or (re-search-forward "^[ \t]*\n" nil t) + (point))) (setq beg (point)) ;; Hide the actual signature. (and (search-forward "\n-----BEGIN PGP SIGNATURE-----\n" nil t) @@ -1081,25 +1630,62 @@ (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. @@ -1114,18 +1700,50 @@ (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) @@ -1133,15 +1751,17 @@ (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) - (replace-match "" 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) - (replace-match "\n\n" t t))))) + (unless (gnus-annotation-in-region-p + (match-beginning 0) (match-end 0)) + (replace-match "\n\n" t t)))))) (defun article-strip-leading-space () "Remove all white space from the beginning of the lines in the article." @@ -1149,11 +1769,20 @@ (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) @@ -1167,26 +1796,13 @@ (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 @@ -1226,38 +1842,6 @@ (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))) - (nnheader-temp-write nil - (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 @@ -1270,7 +1854,6 @@ means show, 0 means toggle." (save-excursion (save-restriction - (widen) (let ((hide (gnus-article-hidden-text-p type))) (cond ((or (null arg) @@ -1287,12 +1870,13 @@ "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. @@ -1325,144 +1909,158 @@ (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) - (when (and date (not (string= date ""))) - (save-excursion - (save-restriction - (nnheader-narrow-to-headers) + pos + bface eface) + (save-excursion + (save-restriction + (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)) + (when (and date (not (string= date ""))) + (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 pos (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)) + (progn (forward-line 1) (point))) + (delete-region (progn (beginning-of-line) (point)) + (progn (end-of-line) (point))) + (setq pos (point)))) + (when (and (not pos) (re-search-forward tdate-regexp nil t)) + (forward-line 1)) + (if pos (goto-char pos)) + (insert (article-make-date-line date (or type 'ut))) + (when (not pos) + (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." - (cond - ;; Convert to the local timezone. We have to slap a - ;; `condition-case' round the calls to the timezone - ;; functions since they aren't particularly resistant to - ;; buggy dates. - ((eq type 'local) - (concat "Date: " (condition-case () - (timezone-make-date-arpa-standard date) - (error date)))) - ;; Convert to Universal Time. - ((eq type 'ut) - (concat "Date: " - (condition-case () - (timezone-make-date-arpa-standard date nil "UT") - (error date)))) - ;; Get the original date from the article. - ((eq type 'original) - (concat "Date: " date)) - ;; Let the user define the format. - ((eq type 'user) - (if (gnus-functionp gnus-article-time-format) - (funcall - gnus-article-time-format - (ignore-errors - (gnus-encode-date - (timezone-make-date-arpa-standard - date nil "UT")))) - (concat - "Date: " - (format-time-string gnus-article-time-format - (ignore-errors - (gnus-encode-date - (timezone-make-date-arpa-standard - date nil "UT"))))))) - ;; ISO 8601. - ((eq type 'iso8601) - (concat - "Date: " - (format-time-string "%Y%M%DT%h%m%s" - (ignore-errors - (gnus-encode-date - (timezone-make-date-arpa-standard - date nil "UT")))))) - ;; Do an X-Sent lapsed format. - ((eq type 'lapsed) - ;; If the date is seriously mangled, the timezone functions are - ;; liable to bug out, so we ignore all errors. - (let* ((now (current-time)) - (real-time - (ignore-errors - (gnus-time-minus - (gnus-encode-date - (timezone-make-date-arpa-standard - (current-time-string now) - (current-time-zone now) "UT")) - (gnus-encode-date - (timezone-make-date-arpa-standard - date nil "UT"))))) - (real-sec (and real-time - (+ (* (float (car real-time)) 65536) - (cadr real-time)))) - (sec (and real-time (abs real-sec))) - num prev) - (cond - ((null real-time) - "X-Sent: Unknown") - ((zerop sec) - "X-Sent: Now") - (t + (let ((time (condition-case () + (date-to-time date) + (error '(0 0))))) + (cond + ;; Convert to the local timezone. We have to slap a + ;; `condition-case' round the calls to the timezone + ;; functions since they aren't particularly resistant to + ;; buggy dates. + ((eq type 'local) + (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: " + (current-time-string + (let* ((e (parse-time-string date)) + (tm (apply 'encode-time e)) + (ms (car tm)) + (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))))) + " UT")) + ;; Get the original date from the article. + ((eq type 'original) + (concat "Date: " (if (string-match "\n+$" date) + (substring date 0 (match-beginning 0)) + date))) + ;; Let the user define the format. + ((eq type 'user) + (if (gnus-functionp gnus-article-time-format) + (funcall gnus-article-time-format time) + (concat + "Date: " + (format-time-string gnus-article-time-format time)))) + ;; ISO 8601. + ((eq type 'iso8601) + (let ((tz (car (current-time-zone time)))) (concat - "X-Sent: " - ;; This is a bit convoluted, but basically we go - ;; through the time units for years, weeks, etc, - ;; and divide things to see whether that results - ;; in positive answers. - (mapconcat - (lambda (unit) - (if (zerop (setq num (ffloor (/ sec (cdr unit))))) - ;; The (remaining) seconds are too few to - ;; be divided into this time unit. - "" - ;; It's big enough, so we output it. - (setq sec (- sec (* num (cdr unit)))) - (prog1 - (concat (if prev ", " "") (int-to-string - (floor num)) - " " (symbol-name (car unit)) - (if (> num 1) "s" "")) - (setq prev t)))) - article-time-units "") - ;; If dates are odd, then it might appear like the - ;; article was sent in the future. - (if (> real-sec 0) - " ago" - " in the future")))))) - (t - (error "Unknown conversion type: %s" type)))) + "Date: " + (format-time-string "%Y%m%dT%H%M%S" time) + (format "%s%02d%02d" + (if (> tz 0) "+" "-") (/ (abs tz) 3600) + (/ (% (abs tz) 3600) 60))))) + ;; Do an X-Sent lapsed format. + ((eq type 'lapsed) + ;; If the date is seriously mangled, the timezone functions are + ;; liable to bug out, so we ignore all errors. + (let* ((now (current-time)) + (real-time (subtract-time now time)) + (real-sec (and real-time + (+ (* (float (car real-time)) 65536) + (cadr real-time)))) + (sec (and real-time (abs real-sec))) + num prev) + (cond + ((null real-time) + "X-Sent: Unknown") + ((zerop sec) + "X-Sent: Now") + (t + (concat + "X-Sent: " + ;; This is a bit convoluted, but basically we go + ;; through the time units for years, weeks, etc, + ;; and divide things to see whether that results + ;; in positive answers. + (mapconcat + (lambda (unit) + (if (zerop (setq num (ffloor (/ sec (cdr unit))))) + ;; The (remaining) seconds are too few to + ;; be divided into this time unit. + "" + ;; It's big enough, so we output it. + (setq sec (- sec (* num (cdr unit)))) + (prog1 + (concat (if prev ", " "") (int-to-string + (floor num)) + " " (symbol-name (car unit)) + (if (> num 1) "s" "")) + (setq prev t)))) + article-time-units "") + ;; If dates are odd, then it might appear like the + ;; article was sent in the future. + (if (> real-sec 0) + " ago" + " in the future")))))) + (t + (error "Unknown conversion type: %s" type))))) (defun article-date-local (&optional highlight) "Convert the current article date to the local timezone." @@ -1486,11 +2084,14 @@ (let (deactivate-mark) (save-excursion (ignore-errors - (when (gnus-buffer-live-p gnus-article-buffer) - (set-buffer gnus-article-buffer) - (goto-char (point-min)) - (when (re-search-forward "^X-Sent:" nil t) - (article-date-lapsed t))))))) + (walk-windows + (lambda (w) + (set-buffer (window-buffer w)) + (when (eq major-mode 'gnus-article-mode) + (goto-char (point-min)) + (when (re-search-forward "^X-Sent:" nil 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. @@ -1533,13 +2134,17 @@ (interactive (gnus-article-hidden-arg)) (unless (gnus-article-check-hidden-text 'emphasis arg) (save-excursion - (let ((alist gnus-emphasis-alist) + (let ((alist (or + (condition-case nil + (with-current-buffer gnus-summary-buffer + gnus-article-emphasis-alist) + (error)) + 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) @@ -1549,6 +2154,7 @@ face (nth 3 elem)) (while (re-search-forward regexp nil t) (when (and (match-beginning visible) (match-beginning invisible)) + (push 'emphasis gnus-article-wash-types) (gnus-article-hide-text (match-beginning invisible) (match-end invisible) props) (gnus-article-unhide-text-type @@ -1557,6 +2163,26 @@ (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-sequence (cdr elem))))) + highlight) + (copy-sequence highlight-words) + (if gnus-newsgroup-name + (copy-sequence (gnus-group-find-parameter + gnus-newsgroup-name 'highlight-words t))) + gnus-emphasis-alist))))) + (defvar gnus-summary-article-menu) (defvar gnus-summary-post-menu) @@ -1576,7 +2202,7 @@ (if (not gnus-default-article-saver) (error "No default saver is defined") ;; !!! Magic! The saving functions all save - ;; `gnus-original-article-buffer' (or so they think), but we + ;; `gnus-save-article-buffer' (or so they think), but we ;; bind that variable to our save-buffer. (set-buffer gnus-article-buffer) (let* ((gnus-save-article-buffer save-buffer) @@ -1662,8 +2288,8 @@ (gnus-make-directory (file-name-directory file)) ;; If we have read a directory, we append the default file name. (when (file-directory-p file) - (setq file (concat (file-name-as-directory file) - (file-name-nondirectory default-name)))) + (setq file (expand-file-name (file-name-nondirectory default-name) + (file-name-as-directory file)))) ;; Possibly translate some characters. (nnheader-translate-file-chars file))))) (gnus-make-directory (file-name-directory result)) @@ -1710,7 +2336,7 @@ (widen) (if (and (file-readable-p filename) (mail-file-babyl-p filename)) - (gnus-output-to-rmail filename t) + (rmail-output-to-rmail-file filename t) (gnus-output-to-mail filename))))) filename) @@ -1750,8 +2376,7 @@ (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) @@ -1759,7 +2384,8 @@ (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 @@ -1823,17 +2449,6 @@ default (or last-file default)))) -(defun gnus-Plain-save-name (newsgroup headers &optional last-file) - "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE. -If variable `gnus-use-long-file-name' is non-nil, it is -~/News/News.group. Otherwise, it is like ~/News/news/group/news." - (or last-file - (expand-file-name - (if (gnus-use-long-file-name 'not-save) - (gnus-capitalize-newsgroup newsgroup) - (concat (gnus-newsgroup-directory-form newsgroup) "/news")) - gnus-article-save-directory))) - (defun gnus-plain-save-name (newsgroup headers &optional last-file) "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE. If variable `gnus-use-long-file-name' is non-nil, it is @@ -1842,7 +2457,7 @@ (expand-file-name (if (gnus-use-long-file-name 'not-save) newsgroup - (concat (gnus-newsgroup-directory-form newsgroup) "/news")) + (expand-file-name "news" (gnus-newsgroup-directory-form newsgroup))) gnus-article-save-directory))) (eval-and-compile @@ -1854,42 +2469,53 @@ gfunc (cdr func)) (setq afunc func gfunc (intern (format "gnus-%s" func)))) - (fset gfunc - (if (not (fboundp afunc)) - nil - `(lambda (&optional interactive &rest args) - ,(documentation afunc t) - (interactive (list t)) - (save-excursion - (set-buffer gnus-article-buffer) - (if interactive - (call-interactively ',afunc) - (apply ',afunc args)))))))) + (defalias gfunc + (if (fboundp afunc) + `(lambda (&optional interactive &rest args) + ,(documentation afunc t) + (interactive (list t)) + (save-excursion + (set-buffer gnus-article-buffer) + (if interactive + (call-interactively ',afunc) + (apply ',afunc args)))))))) '(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-de-base64-unreadable + article-decode-HZ + article-wash-html + 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-iso8601 article-date-original article-date-ut + article-decode-mime-words + article-decode-charset + article-decode-encoded-words article-date-user article-date-lapsed article-emphasize article-treat-dumbquotes + article-normalize-headers (article-show-all . gnus-article-show-all-headers)))) ;;; @@ -1898,20 +2524,19 @@ (put 'gnus-article-mode 'mode-class 'special) +(set-keymap-parent gnus-article-mode-map widget-keymap) + (gnus-define-keys gnus-article-mode-map " " gnus-article-goto-next-page "\177" gnus-article-goto-prev-page [delete] gnus-article-goto-prev-page + [backspace] gnus-article-goto-prev-page "\C-c^" gnus-article-refer-article "h" gnus-article-show-summary "s" gnus-article-show-summary "\C-c\C-m" gnus-article-mail "?" gnus-article-describe-briefly - gnus-mouse-2 gnus-article-push-button - "\r" gnus-article-press-button - "\t" gnus-article-next-button - "\M-\t" gnus-article-prev-button - "e" gnus-article-edit + "e" gnus-summary-edit-article "<" beginning-of-buffer ">" end-of-buffer "\C-c\C-i" gnus-info-find-node @@ -1947,7 +2572,10 @@ ["Hide citation" gnus-article-hide-citation t] ["Treat overstrike" gnus-article-treat-overstrike t] ["Remove carriage return" gnus-article-remove-cr t] - ["Remove quoted-unreadable" gnus-article-de-quoted-unreadable t])) + ["Remove quoted-unreadable" gnus-article-de-quoted-unreadable t] + ["Remove base64" gnus-article-de-base64-unreadable t] + ["Treat html" gnus-article-wash-html t] + ["Decode HZ" gnus-article-decode-HZ t])) ;; Note "Commands" menu is defined in gnus-sum.el for consistency @@ -1979,18 +2607,21 @@ (setq mode-name "Article") (setq major-mode 'gnus-article-mode) (make-local-variable 'minor-mode-alist) - (unless (assq 'gnus-show-mime minor-mode-alist) - (push (list 'gnus-show-mime " MIME") minor-mode-alist)) (use-local-map gnus-article-mode-map) (gnus-update-format-specifications nil 'article-mode) (set (make-local-variable 'page-delimiter) gnus-page-delimiter) (make-local-variable 'gnus-page-broken) (make-local-variable 'gnus-button-marker-list) (make-local-variable 'gnus-article-current-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-wash-types) (gnus-set-default-directory) - (buffer-disable-undo (current-buffer)) + (buffer-disable-undo) (setq buffer-read-only t) (set-syntax-table gnus-article-mode-syntax-table) + (mm-enable-multibyte) (gnus-run-hooks 'gnus-article-mode-hook)) (defun gnus-article-setup-buffer () @@ -2003,6 +2634,7 @@ (substring name (match-end 0)))))) (setq gnus-article-buffer name) (setq gnus-original-article-buffer original) + (setq gnus-article-mime-handle-alist nil) ;; This might be a variable local to the summary buffer. (unless gnus-single-article-buffer (save-excursion @@ -2010,16 +2642,22 @@ (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)) - (buffer-disable-undo (current-buffer)) + (mm-enable-multibyte) (setq major-mode 'gnus-original-article-mode) (make-local-variable 'gnus-original-article)) (if (get-buffer name) (save-excursion (set-buffer name) - (buffer-disable-undo (current-buffer)) + (when gnus-article-mime-handles + (mm-destroy-parts gnus-article-mime-handles) + (setq gnus-article-mime-handles nil)) + ;; Set it to nil in article-buffer! + (setq gnus-article-mime-handle-alist nil) + (buffer-disable-undo) (setq buffer-read-only t) (unless (eq major-mode 'gnus-article-mode) (gnus-article-mode)) @@ -2028,6 +2666,7 @@ (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 @@ -2084,8 +2723,7 @@ (message "Message marked for downloading")) (gnus-summary-mark-article article gnus-canceled-mark) (unless (memq article gnus-newsgroup-sparse) - (gnus-error 1 - "No such article (may have expired or been canceled)"))))) + (gnus-error 1 "No such article (may have expired or been canceled)"))))) (if (or (eq result 'pseudo) (eq result 'nneething)) (progn @@ -2100,7 +2738,9 @@ (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. @@ -2131,85 +2771,723 @@ (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 (or (numberp article) (stringp article)) - ;; Hooks for getting information from the article. - ;; This hook must be called before being narrowed. - (let (buffer-read-only) - (gnus-run-hooks 'gnus-tmp-internal-hook) - (gnus-run-hooks 'gnus-article-prepare-hook) - ;; Decode MIME message. - (if gnus-show-mime - (if (or (not gnus-strict-mime) - (gnus-fetch-field "Mime-Version")) - (let ((coding-system-for-write 'binary) - (coding-system-for-read 'binary)) - (funcall gnus-show-mime-method)) - (funcall gnus-decode-encoded-word-method)) - (funcall gnus-show-traditional-method)) - ;; Perform the article display hooks. - (gnus-run-hooks 'gnus-article-display-hook)) + (gnus-article-prepare-display) ;; Do page break. (goto-char (point-min)) (setq gnus-page-broken (when gnus-break-pages (gnus-narrow-to-page) t))) - (gnus-set-mode-line 'article) + (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) - (goto-char (point-min)) - (search-forward "\n\n" nil t) - (set-window-point (get-buffer-window (current-buffer)) (point)) t)))))) +;;;###autoload +(defun gnus-article-prepare-display () + "Make the current buffer look like a nice article." + ;; Hooks for getting information from the article. + ;; This hook must be called before being narrowed. + (let ((gnus-article-buffer (current-buffer)) + buffer-read-only) + (unless (eq major-mode 'gnus-article-mode) + (gnus-article-mode)) + (setq buffer-read-only nil + gnus-article-wash-types nil) + (gnus-run-hooks 'gnus-tmp-internal-hook) + (when gnus-display-mime-function + (funcall gnus-display-mime-function)) + (gnus-run-hooks 'gnus-article-prepare-hook))) + +;;; +;;; Gnus MIME viewing functions +;;; + +(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 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) + (?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 + (let ((map (make-sparse-keymap))) + (set-keymap-parent map gnus-article-mode-map) + (define-key map gnus-mouse-2 'gnus-article-push-button) + (define-key map gnus-down-mouse-3 'gnus-mime-button-menu) + (dolist (c gnus-mime-button-commands) + (define-key map (cadr c) (car c))) + map)) + +(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 + (call-interactively response)))))) + +(defun gnus-mime-view-all-parts (&optional handles) + "View all the MIME parts." + (interactive) + (save-current-buffer + (set-buffer gnus-article-buffer) + (let ((handles (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 viewing method for the MIME part under point." + (interactive) + (gnus-article-check-buffer) + (let ((data (get-text-property (point) 'gnus-data))) + (mm-interactively-view-part data))) + +(defun gnus-mime-view-part-as-type-internal () + (gnus-article-check-buffer) + (let* ((name (mail-content-type-get + (mm-handle-type (get-text-property (point) 'gnus-data)) + 'name)) + (def-type (and name (mm-default-file-encoding name)))) + (and def-type (cons def-type 0)))) + +(defun gnus-mime-view-part-as-type (mime-type) + "Choose a MIME media type, and view the part as such." + (interactive + (list (completing-read + "View as MIME type: " + (mapcar #'list (mailcap-mime-types)) + nil nil + (gnus-mime-view-part-as-type-internal)))) + (gnus-article-check-buffer) + (let ((handle (get-text-property (point) 'gnus-data))) + (gnus-mm-display-part + (mm-make-handle (mm-handle-buffer handle) + (cons mime-type (cdr (mm-handle-type handle))) + (mm-handle-encoding handle) + (mm-handle-undisplayer handle) + (mm-handle-disposition handle) + (mm-handle-description handle) + (mm-handle-cache handle) + (mm-handle-id handle))))) + +(defun gnus-mime-copy-part (&optional handle) + "Put the the MIME part under point into a new buffer." + (interactive) + (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 (&optional handle) + "Insert the MIME part under point into the current buffer." + (interactive) + (gnus-article-check-buffer) + (let* ((handle (or handle (get-text-property (point) 'gnus-data))) + contents + (b (point)) + buffer-read-only) + (if (mm-handle-undisplayer handle) + (mm-remove-part handle) + (setq contents (mm-get-part handle)) + (forward-line 2) + (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-inlined-types 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. +In no internal viewer is available, use an external viewer." + (interactive) + (gnus-article-check-buffer) + (let* ((handle (or handle (get-text-property (point) 'gnus-data))) + (mm-inlined-types '(".*")) + (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-mime-match-handle-first (condition) + (if condition + (let ((alist gnus-article-mime-handle-alist) ihandle n) + (while (setq ihandle (pop alist)) + (if (and (cond + ((functionp condition) + (funcall condition (cdr ihandle))) + ((eq condition 'undisplayed) + (not (or (mm-handle-undisplayer (cdr ihandle)) + (equal (mm-handle-media-type (cdr ihandle)) + "multipart/alternative")))) + ((eq condition 'undisplayed-alternative) + (not (mm-handle-undisplayer (cdr ihandle)))) + (t t)) + (gnus-article-goto-part (car ihandle)) + (or (not n) (< (car ihandle) n))) + (setq n (car ihandle)))) + (or n 1)) + 1)) + +(defun gnus-article-view-part (&optional n) + "View MIME part N, which is the numerical prefix." + (interactive "P") + (save-current-buffer + (set-buffer gnus-article-buffer) + (or (numberp n) (setq n (gnus-article-mime-match-handle-first + gnus-article-mime-match-handle-function))) + (when (> n (length gnus-article-mime-handle-alist)) + (error "No such part")) + (let ((handle (cdr (assq n gnus-article-mime-handle-alist)))) + (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." + (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-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 gnus-mm-display-part + gnus-part ,gnus-tmp-id + article-type annotation + gnus-data ,handle)) + (setq e (point)) + (widget-convert-button + 'link b e + :mime-handle handle + :action 'gnus-widget-press-button + :button-keymap gnus-mime-button-map + :help-echo + (lambda (widget/window &optional overlay pos) + ;; Needed to properly clear the message due to a bug in + ;; wid-edit (XEmacs only). + (if (boundp 'help-echo-owns-message) + (setq help-echo-owns-message t)) + (format + "%S: %s the MIME part; %S: more options" + (aref gnus-mouse-2 0) + ;; XEmacs will get a single widget arg; Emacs 21 will get + ;; window, overlay, position. + (if (mm-handle-displayed-p + (if overlay + (with-current-buffer (overlay-buffer overlay) + (widget-get (widget-at (overlay-start overlay)) + :mime-handle)) + (widget-get widget/window :mime-handle))) + "hide" "show") + (aref gnus-down-mouse-3 0)))))) + +(defun gnus-widget-press-button (elems el) + (goto-char (widget-get elems :from)) + (gnus-article-press-button)) + +(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))) + (unless 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 + (and (not (mm-inline-override-p handle)) + (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 (condition-case () + (set-buffer gnus-summary-buffer) + (error)) + 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) + (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)) - (mime gnus-show-mime)) - (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 ? ) (if signature ?s ? ) (if overstrike ?o ? ) - (if mime ?m ? ) (if emphasis ?e ? ))))) -(fset 'gnus-article-hide-headers-if-wanted 'gnus-article-maybe-hide-headers) +(defalias 'gnus-article-hide-headers-if-wanted 'gnus-article-maybe-hide-headers) (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-output-to-file (file-name) "Append the current article to a file named FILE-NAME." (let ((artbuf (current-buffer))) - (nnheader-temp-write nil + (with-temp-buffer (insert-buffer-substring artbuf) ;; Append newline at end of the buffer as separator, and then ;; 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) @@ -2337,8 +3615,7 @@ (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." @@ -2361,9 +3638,15 @@ (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" @@ -2379,7 +3662,10 @@ (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) @@ -2391,7 +3677,8 @@ ;; We disable the pick minor mode commands. (let (gnus-pick-mode) (setq func (lookup-key (current-local-map) keys)))) - (if (not func) + (if (or (not func) + (numberp func)) (ding) (unless (member keys nosave-in-article) (set-buffer gnus-article-current-summary)) @@ -2421,9 +3708,12 @@ (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)))))))) @@ -2435,6 +3725,7 @@ 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)) @@ -2467,8 +3758,7 @@ ;; We only request an article by message-id when we do not have the ;; headers for it, so we'll have to get those. (when (stringp article) - (let ((gnus-override-method gnus-refer-article-method)) - (gnus-read-header article))) + (gnus-read-header article)) ;; If the article number is negative, that means that this article ;; doesn't belong in this newsgroup (possibly), so we find its @@ -2486,8 +3776,7 @@ ;; This is a sparse gap article. (setq do-update-line article) (setq article (mail-header-id header)) - (let ((gnus-override-method gnus-refer-article-method)) - (setq sparse-header (gnus-read-header article))) + (setq sparse-header (gnus-read-header article)) (setq gnus-newsgroup-sparse (delq article gnus-newsgroup-sparse))) ((vectorp header) @@ -2502,11 +3791,11 @@ gnus-newsgroup-name))) (when (and (eq (car method) 'nneething) (vectorp header)) - (let ((dir (concat + (let ((dir (expand-file-name + (mail-header-subject header) (file-name-as-directory (or (cadr (assq 'nneething-address method)) - (nth 1 method))) - (mail-header-subject header)))) + (nth 1 method)))))) (when (file-directory-p dir) (setq article 'nneething) (gnus-group-enter-directory dir)))))))) @@ -2547,20 +3836,40 @@ (gnus-cache-request-article article group)) 'article) ;; Get the article and put into the article buffer. - ((or (stringp article) (numberp article)) - (let ((gnus-override-method - (and (stringp article) gnus-refer-article-method)) + ((or (stringp article) + (numberp article)) + (let ((gnus-override-method gnus-override-method) + (methods (and (stringp article) + gnus-refer-article-method)) + result (buffer-read-only nil)) - (erase-buffer) - (gnus-kill-all-overlays) - (gnus-check-group-server) - (when (gnus-request-article article group (current-buffer)) - (when (numberp article) - (gnus-async-prefetch-next group article gnus-summary-buffer) - (when gnus-keep-backlog - (gnus-backlog-enter-article - group article (current-buffer)))) - 'article))) + (setq methods + (if (listp methods) + methods + (list methods))) + (when (and (null gnus-override-method) + methods) + (setq gnus-override-method (pop methods))) + (while (not result) + (when (eq gnus-override-method 'current) + (setq gnus-override-method gnus-current-select-method)) + (erase-buffer) + (gnus-kill-all-overlays) + (let ((gnus-newsgroup-name group)) + (gnus-check-group-server)) + (when (gnus-request-article article group (current-buffer)) + (when (numberp article) + (gnus-async-prefetch-next group article + gnus-summary-buffer) + (when gnus-keep-backlog + (gnus-backlog-enter-article + group article (current-buffer)))) + (setq result 'article)) + (if (not result) + (if methods + (setq gnus-override-method (pop methods)) + (setq result 'done)))) + (and (eq result 'article) 'article))) ;; It was a pseudo. (t article))) @@ -2576,13 +3885,18 @@ (if (get-buffer gnus-original-article-buffer) (set-buffer gnus-original-article-buffer) (set-buffer (gnus-get-buffer-create gnus-original-article-buffer)) - (buffer-disable-undo (current-buffer)) + (buffer-disable-undo) (setq major-mode 'gnus-original-article-mode) (setq buffer-read-only t)) (let (buffer-read-only) (erase-buffer) (insert-buffer-substring gnus-article-buffer)) - (setq gnus-original-article (cons group article)))) + (setq gnus-original-article (cons group article))) + + ;; Decode charsets. + (run-hooks 'gnus-article-decode-hook) + ;; Mark article as decoded or not. + (setq gnus-article-decoded-p gnus-article-decode-hook)) ;; Update sparse articles. (when (and do-update-line @@ -2609,8 +3923,10 @@ (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 @@ -2647,18 +3963,19 @@ (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) @@ -2670,8 +3987,7 @@ (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) @@ -2696,7 +4012,19 @@ (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)))) @@ -2705,7 +4033,7 @@ "Exit the article editing without updating." (interactive) ;; We remove all text props from the article buffer. - (let ((buf (format "%s" (buffer-string))) + (let ((buf (buffer-substring-no-properties (point-min) (point-max))) (curbuf (current-buffer)) (p (point)) (window-start (window-start))) @@ -2713,25 +4041,12 @@ (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. - (let ((buf (current-buffer))) + (save-current-buffer (set-buffer curbuf) (set-window-start (get-buffer-window (current-buffer)) window-start) - (goto-char p) - (set-buffer buf))))) + (goto-char p))))) (defun gnus-article-edit-full-stops () "Interactively repair spacing at end of sentences." @@ -2750,15 +4065,15 @@ ;;; Internal Variables: -(defcustom gnus-button-url-regexp "\\b\\(s?https?\\|ftp\\|file\\|gopher\\|news\\|telnet\\|wais\\|mailto\\):\\(//[-a-zA-Z0-9_.]+:[0-9]*\\)?\\([-a-zA-Z0-9_=!?#$@~`%&*+|\\/:;.,]\\|\\w\\)+\\([-a-zA-Z0-9_=#$@~`%&*+|\\/]\\|\\w\\)" +(defcustom gnus-button-url-regexp "\\b\\(\\(www\\.\\|\\(s?https?\\|ftp\\|file\\|gopher\\|news\\|telnet\\|wais\\|mailto\\):\\)\\(//[-a-zA-Z0-9_.]+:[0-9]*\\)?\\([-a-zA-Z0-9_=!?#$@~`%&*+|\\/:;.,]\\|\\w\\)+\\([-a-zA-Z0-9_=#$@~`%&*+|\\/]\\|\\w\\)\\)" "Regular expression that matches URLs." :group 'gnus-article-buttons :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) @@ -2766,12 +4081,12 @@ ("\\bin\\( +article\\| +message\\)? +\\(<\\([^\n @<>]+@[^\n @<>]+\\)>\\)" 2 t gnus-button-message-id 3) ("\\(<URL: *\\)mailto: *\\([^> \n\t]+\\)>" 0 t gnus-url-mailto 2) - ("mailto:\\([a-zA-Z.-@_+0-9%]+\\)" 0 t gnus-url-mailto 1) + ("mailto:\\([-a-zA-Z.@_+0-9%]+\\)" 0 t gnus-url-mailto 1) ("\\bmailto:\\([^ \n\t]+\\)" 0 t gnus-url-mailto 1) ;; This is how URLs _should_ be embedded in text... - ("<URL: *\\([^>]*\\)>" 0 t gnus-button-embedded-url 1) + ("<URL: *\\([^<>]*\\)>" 0 t gnus-button-embedded-url 1) ;; Raw URLs. - (,gnus-button-url-regexp 0 t gnus-button-url 0)) + (,gnus-button-url-regexp 0 t browse-url 0)) "*Alist of regexps matching buttons in article bodies. Each entry has the form (REGEXP BUTTON FORM CALLBACK PAR...), where @@ -2799,9 +4114,9 @@ ("^\\(From\\|Reply-To\\):" ": *\\(.+\\)$" 1 t gnus-button-reply 1) ("^\\(Cc\\|To\\):" "[^ \t\n<>,()\"]+@[^ \t\n<>,()\"]+" 0 t gnus-button-mailto 0) - ("^X-[Uu][Rr][Ll]:" ,gnus-button-url-regexp 0 t gnus-button-url 0) - ("^Subject:" ,gnus-button-url-regexp 0 t gnus-button-url 0) - ("^[^:]+:" ,gnus-button-url-regexp 0 t gnus-button-url 0) + ("^X-[Uu][Rr][Ll]:" ,gnus-button-url-regexp 0 t browse-url 0) + ("^Subject:" ,gnus-button-url-regexp 0 t browse-url 0) + ("^[^:]+:" ,gnus-button-url-regexp 0 t browse-url 0) ("^[^:]+:" "\\(<\\(url: \\)?news:\\([^>\n ]*\\)>\\)" 1 t gnus-button-message-id 3)) "*Alist of headers and regexps to match buttons in article heads. @@ -2856,40 +4171,6 @@ (when fun (funcall fun data)))) -(defun gnus-article-prev-button (n) - "Move point to N buttons backward. -If N is negative, move forward instead." - (interactive "p") - (gnus-article-next-button (- n))) - -(defun gnus-article-next-button (n) - "Move point to N buttons forward. -If N is negative, move backward instead." - (interactive "p") - (let ((function (if (< n 0) 'previous-single-property-change - 'next-single-property-change)) - (inhibit-point-motion-hooks t) - (backward (< n 0)) - (limit (if (< n 0) (point-min) (point-max)))) - (setq n (abs n)) - (while (and (not (= limit (point))) - (> n 0)) - ;; Skip past the current button. - (when (get-text-property (point) 'gnus-callback) - (goto-char (funcall function (point) 'gnus-callback nil limit))) - ;; Go to the next (or previous) button. - (gnus-goto-char (funcall function (point) 'gnus-callback nil limit)) - ;; Put point at the start of the button. - (when (and backward (not (get-text-property (point) 'gnus-callback))) - (goto-char (funcall function (point) 'gnus-callback nil limit))) - ;; Skip past intangible buttons. - (when (get-text-property (point) 'intangible) - (incf n)) - (decf n)) - (unless (zerop n) - (gnus-message 5 "No more buttons")) - n)) - (defun gnus-article-highlight (&optional force) "Highlight current article. This function calls `gnus-article-highlight-headers', @@ -2924,7 +4205,7 @@ (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 "^\\(" @@ -2990,18 +4271,19 @@ (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)) @@ -3027,38 +4309,38 @@ (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: @@ -3072,7 +4354,9 @@ (nconc (and gnus-article-mouse-face (list gnus-mouse-face-prop gnus-article-mouse-face)) (list 'gnus-callback fun) - (and data (list 'gnus-data data))))) + (and data (list 'gnus-data data)))) + (widget-convert-button 'link from to :action 'gnus-widget-press-button + :button-keymap gnus-widget-button-keymap)) ;;; Internal functions: @@ -3104,7 +4388,6 @@ (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) @@ -3149,7 +4432,7 @@ (defun gnus-url-parse-query-string (query &optional downcase) (let (retval pairs cur key val) - (setq pairs (gnus-split-string query "&")) + (setq pairs (split-string query "&")) (while pairs (setq cur (car pairs) pairs (cdr pairs)) @@ -3230,13 +4513,8 @@ ;; Reply to ADDRESS. (message-reply address)) -(defun gnus-button-url (address) - "Browse ADDRESS." - (browse-url address)) - (defun gnus-button-embedded-url (address) "Browse ADDRESS." - ;; In Emacs 20, `browse-url-browser-function' may be an alist. (browse-url (gnus-strip-whitespace address))) ;;; Next/prev buttons in the article buffer. @@ -3256,7 +4534,7 @@ 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 @@ -3287,7 +4565,7 @@ `(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." @@ -3305,6 +4583,117 @@ (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)) + (mapcar (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 + (save-excursion + (if (gnus-buffer-live-p gnus-summary-buffer) + (set-buffer gnus-summary-buffer)) + (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 + ((null val) + nil) + ((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 (car val) type)) + (t + (error "%S is not a valid predicate" pred))))) + (condition + (eq condition val)) + ((eq val t) + t) + ((eq val 'head) + nil) + ((eq val 'last) + (eq part-number total-parts)) + ((numberp val) + (< length val)) + (t + (error "%S is not a valid value" val)))) + (gnus-ems-redefine) (provide 'gnus-art)