gnus-art.el: Misc improvements for displaying MIME parts
[gnus] / lisp / gnus-art.el
1 ;;; gnus-art.el --- article mode commands for Gnus
2
3 ;; Copyright (C) 1996-2014 Free Software Foundation, Inc.
4
5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
6 ;; Keywords: news
7
8 ;; This file is part of GNU Emacs.
9
10 ;; GNU Emacs is free software: you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation, either version 3 of the License, or
13 ;; (at your option) any later version.
14
15 ;; GNU Emacs is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
18 ;; GNU General Public License for more details.
19
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
22
23 ;;; Commentary:
24
25 ;;; Code:
26
27 (eval-when-compile
28   (require 'cl))
29 (defvar tool-bar-map)
30 (defvar w3m-minor-mode-map)
31
32 (require 'gnus)
33 (require 'gnus-util)
34 (require 'gnus-sum)
35 (require 'gnus-spec)
36 (require 'gnus-int)
37 (require 'gnus-win)
38 (require 'mm-bodies)
39 (require 'mail-parse)
40 (require 'mm-decode)
41 (require 'mm-view)
42 (require 'wid-edit)
43 (require 'mm-uu)
44 (require 'message)
45 (require 'mouse)
46
47 (autoload 'gnus-msg-mail "gnus-msg" nil t)
48 (autoload 'gnus-button-mailto "gnus-msg")
49 (autoload 'gnus-button-reply "gnus-msg" nil t)
50 (autoload 'parse-time-string "parse-time" nil nil)
51 (autoload 'ansi-color-apply-on-region "ansi-color")
52 (autoload 'mm-url-insert-file-contents-external "mm-url")
53 (autoload 'mm-extern-cache-contents "mm-extern")
54
55 (defgroup gnus-article nil
56   "Article display."
57   :link '(custom-manual "(gnus)Article Buffer")
58   :group 'gnus)
59
60 (defgroup gnus-article-treat nil
61   "Treating article parts."
62   :link '(custom-manual "(gnus)Article Hiding")
63   :group 'gnus-article)
64
65 (defgroup gnus-article-hiding nil
66   "Hiding article parts."
67   :link '(custom-manual "(gnus)Article Hiding")
68   :group 'gnus-article)
69
70 (defgroup gnus-article-highlight nil
71   "Article highlighting."
72   :link '(custom-manual "(gnus)Article Highlighting")
73   :group 'gnus-article
74   :group 'gnus-visual)
75
76 (defgroup gnus-article-signature nil
77   "Article signatures."
78   :link '(custom-manual "(gnus)Article Signature")
79   :group 'gnus-article)
80
81 (defgroup gnus-article-headers nil
82   "Article headers."
83   :link '(custom-manual "(gnus)Hiding Headers")
84   :group 'gnus-article)
85
86 (defgroup gnus-article-washing nil
87   "Special commands on articles."
88   :link '(custom-manual "(gnus)Article Washing")
89   :group 'gnus-article)
90
91 (defgroup gnus-article-emphasis nil
92   "Fontisizing articles."
93   :link '(custom-manual "(gnus)Article Fontisizing")
94   :group 'gnus-article)
95
96 (defgroup gnus-article-saving nil
97   "Saving articles."
98   :link '(custom-manual "(gnus)Saving Articles")
99   :group 'gnus-article)
100
101 (defgroup gnus-article-mime nil
102   "Worshiping the MIME wonder."
103   :link '(custom-manual "(gnus)Using MIME")
104   :group 'gnus-article)
105
106 (defgroup gnus-article-buttons nil
107   "Pushable buttons in the article buffer."
108   :link '(custom-manual "(gnus)Article Buttons")
109   :group 'gnus-article)
110
111 (defgroup gnus-article-various nil
112   "Other article options."
113   :link '(custom-manual "(gnus)Misc Article")
114   :group 'gnus-article)
115
116 (defcustom gnus-ignored-headers
117   (mapcar
118    (lambda (header)
119      (concat "^" header ":"))
120    '("Path" "Expires" "Date-Received" "References" "Xref" "Lines"
121      "Relay-Version" "Message-ID" "Approved" "Sender" "Received"
122      "X-UIDL" "MIME-Version" "Return-Path" "In-Reply-To"
123      "Content-Type" "Content-Transfer-Encoding" "X-WebTV-Signature"
124      "X-MimeOLE" "X-MSMail-Priority" "X-Priority" "X-Loop"
125      "X-Authentication-Warning" "X-MIME-Autoconverted" "X-Face"
126      "X-Attribution" "X-Originating-IP" "Delivered-To"
127      "NNTP-[-A-Za-z]+" "Distribution" "X-no-archive" "X-Trace"
128      "X-Complaints-To" "X-NNTP-Posting-Host" "X-Orig.*"
129      "Abuse-Reports-To" "Cache-Post-Path" "X-Article-Creation-Date"
130      "X-Poster" "X-Mail2News-Path" "X-Server-Date" "X-Cache"
131      "Originator" "X-Problems-To" "X-Auth-User" "X-Post-Time"
132      "X-Admin" "X-UID" "Resent-[-A-Za-z]+" "X-Mailing-List"
133      "Precedence" "Original-[-A-Za-z]+" "X-filename" "X-Orcpt"
134      "Old-Received" "X-Pgp" "X-Auth" "X-From-Line"
135      "X-Gnus-Article-Number" "X-Majordomo" "X-Url" "X-Sender"
136      "MBOX-Line" "Priority" "X400-[-A-Za-z]+"
137      "Status" "X-Gnus-Mail-Source" "Cancel-Lock"
138      "X-FTN" "X-EXP32-SerialNo" "Encoding" "Importance"
139      "Autoforwarded" "Original-Encoded-Information-Types" "X-Ya-Pop3"
140      "X-Face-Version" "X-Vms-To" "X-ML-NAME" "X-ML-COUNT"
141      "Mailing-List" "X-finfo" "X-md5sum" "X-md5sum-Origin"
142      "X-Sun-Charset" "X-Accept-Language" "X-Envelope-Sender"
143      "List-[A-Za-z]+" "X-Listprocessor-Version"
144      "X-Received" "X-Distribute" "X-Sequence" "X-Juno-Line-Breaks"
145      "X-Notes-Item" "X-MS-TNEF-Correlator" "x-uunet-gateway"
146      "X-Received" "Content-length" "X-precedence"
147      "X-Authenticated-User" "X-Comment" "X-Report" "X-Abuse-Info"
148      "X-HTTP-Proxy" "X-Mydeja-Info" "X-Copyright" "X-No-Markup"
149      "X-Abuse-Info" "X-From_" "X-Accept-Language" "Errors-To"
150      "X-BeenThere" "X-Mailman-Version" "List-Help" "List-Post"
151      "List-Subscribe" "List-Id" "List-Unsubscribe" "List-Archive"
152      "X-Content-length" "X-Posting-Agent" "Original-Received"
153      "X-Request-PGP" "X-Fingerprint" "X-WRIEnvto" "X-WRIEnvfrom"
154      "X-Virus-Scanned" "X-Delivery-Agent" "Posted-Date" "X-Gateway"
155      "X-Local-Origin" "X-Local-Destination" "X-UserInfo1"
156      "X-Received-Date" "X-Hashcash" "Face" "X-DMCA-Notifications"
157      "X-Abuse-and-DMCA-Info" "X-Postfilter" "X-Gpg-.*" "X-Disclaimer"
158      "Envelope-To" "X-Spam-Score" "System-Type" "X-Injected-Via-Gmane"
159      "X-Gmane-NNTP-Posting-Host" "Jabber-ID" "Archived-At"
160      "Envelope-Sender" "Envelope-Recipients"))
161   "*All headers that start with this regexp will be hidden.
162 This variable can also be a list of regexps of headers to be ignored.
163 If `gnus-visible-headers' is non-nil, this variable will be ignored."
164   :type '(choice regexp
165                  (repeat regexp))
166   :group 'gnus-article-hiding)
167
168 (defcustom gnus-visible-headers
169   "^From:\\|^Newsgroups:\\|^Subject:\\|^Date:\\|^Followup-To:\\|^Reply-To:\\|^Organization:\\|^Summary:\\|^Keywords:\\|^To:\\|^[BGF]?Cc:\\|^Posted-To:\\|^Mail-Copies-To:\\|^Mail-Followup-To:\\|^Apparently-To:\\|^Gnus-Warning:\\|^Resent-From:"
170   "*All headers that do not match this regexp will be hidden.
171 This variable can also be a list of regexp of headers to remain visible.
172 If this variable is non-nil, `gnus-ignored-headers' will be ignored."
173   :type '(choice
174           (repeat :value-to-internal (lambda (widget value)
175                                        (custom-split-regexp-maybe value))
176                   :match (lambda (widget value)
177                            (or (stringp value)
178                                (widget-editable-list-match widget value)))
179                   regexp)
180           (const :tag "Use gnus-ignored-headers" nil)
181           regexp)
182   :group 'gnus-article-hiding)
183
184 (defcustom gnus-sorted-header-list
185   '("^From:" "^Subject:" "^Summary:" "^Keywords:" "^Newsgroups:"
186     "^Followup-To:" "^To:" "^Cc:" "^Date:" "^Organization:")
187   "*This variable is a list of regular expressions.
188 If it is non-nil, headers that match the regular expressions will
189 be placed first in the article buffer in the sequence specified by
190 this list."
191   :type '(repeat regexp)
192   :group 'gnus-article-hiding)
193
194 (defcustom gnus-boring-article-headers '(empty followup-to reply-to)
195   "Headers that are only to be displayed if they have interesting data.
196 Possible values in this list are:
197
198   'empty       Headers with no content.
199   'newsgroups  Newsgroup identical to Gnus group.
200   'to-address  To identical to To-address.
201   'to-list     To identical to To-list.
202   'cc-list     CC identical to To-list.
203   'followup-to Followup-to identical to Newsgroups.
204   'reply-to    Reply-to identical to From.
205   'date        Date less than four days old.
206   'long-to     To and/or Cc longer than 1024 characters.
207   'many-to     Multiple To and/or Cc."
208   :type '(set (const :tag "Headers with no content." empty)
209               (const :tag "Newsgroups identical to Gnus group." newsgroups)
210               (const :tag "To identical to To-address." to-address)
211               (const :tag "To identical to To-list." to-list)
212               (const :tag "CC identical to To-list." cc-list)
213               (const :tag "Followup-to identical to Newsgroups." followup-to)
214               (const :tag "Reply-to identical to From." reply-to)
215               (const :tag "Date less than four days old." date)
216               (const :tag "To and/or Cc longer than 1024 characters." long-to)
217               (const :tag "Multiple To and/or Cc headers." many-to))
218   :group 'gnus-article-hiding)
219
220 (defcustom gnus-article-skip-boring nil
221   "Skip over text that is not worth reading.
222 By default, if you set this t, then Gnus will display citations and
223 signatures, but will never scroll down to show you a page consisting
224 only of boring text.  Boring text is controlled by
225 `gnus-article-boring-faces'."
226   :version "22.1"
227   :type 'boolean
228   :group 'gnus-article-hiding)
229
230 (defcustom gnus-signature-separator '("^-- $" "^-- *$")
231   "Regexp matching signature separator.
232 This can also be a list of regexps.  In that case, it will be checked
233 from head to tail looking for a separator.  Searches will be done from
234 the end of the buffer."
235   :type '(choice :format "%{%t%}: %[Value Menu%]\n%v"
236                  (regexp)
237                  (repeat :tag "List of regexp" regexp))
238   :group 'gnus-article-signature)
239
240 (defcustom gnus-signature-limit nil
241   "Provide a limit to what is considered a signature.
242 If it is a number, no signature may not be longer (in characters) than
243 that number.  If it is a floating point number, no signature may be
244 longer (in lines) than that number.  If it is a function, the function
245 will be called without any parameters, and if it returns nil, there is
246 no signature in the buffer.  If it is a string, it will be used as a
247 regexp.  If it matches, the text in question is not a signature.
248
249 This can also be a list of the above values."
250   :type '(choice (const nil)
251                  (integer :value 200)
252                  (number :value 4.0)
253                  function
254                  (regexp :value ".*"))
255   :group 'gnus-article-signature)
256
257 (defcustom gnus-hidden-properties '(invisible t intangible t)
258   "Property list to use for hiding text."
259   :type 'sexp
260   :group 'gnus-article-hiding)
261
262 ;; Fixme: This isn't the right thing for mixed graphical and non-graphical
263 ;; frames in a session.
264 (defcustom gnus-article-x-face-command
265   (if (featurep 'xemacs)
266       (if (or (gnus-image-type-available-p 'xface)
267               (gnus-image-type-available-p 'pbm))
268           'gnus-display-x-face-in-from
269         "{ echo \
270 '/* Format_version=1, Width=48, Height=48, Depth=1, Valid_bits_per_item=16 */'\
271 ; uncompface; } | icontopbm | ee -")
272     (if (gnus-image-type-available-p 'pbm)
273         'gnus-display-x-face-in-from
274       "{ echo \
275 '/* Format_version=1, Width=48, Height=48, Depth=1, Valid_bits_per_item=16 */'\
276 ; uncompface; } | icontopbm | display -"))
277   "*String or function to be executed to display an X-Face header.
278 If it is a string, the command will be executed in a sub-shell
279 asynchronously.  The compressed face will be piped to this command."
280   :type `(choice string
281                  (function-item gnus-display-x-face-in-from)
282                  function)
283   :version "21.1"
284   :group 'gnus-picon
285   :group 'gnus-article-washing)
286
287 (defcustom gnus-article-x-face-too-ugly nil
288   "Regexp matching posters whose face shouldn't be shown automatically."
289   :type '(choice regexp (const nil))
290   :group 'gnus-article-washing)
291
292 (defcustom gnus-article-banner-alist nil
293   "Banner alist for stripping.
294 For example,
295      ((egroups . \"^[ \\t\\n]*-------------------+\\\\( \\\\(e\\\\|Yahoo! \\\\)Groups Sponsor -+\\\\)?....\\n\\\\(.+\\n\\\\)+\"))"
296   :version "21.1"
297   :type '(repeat (cons symbol regexp))
298   :group 'gnus-article-washing)
299
300 (gnus-define-group-parameter
301  banner
302  :variable-document
303  "Alist of regexps (to match group names) and banner."
304  :variable-group gnus-article-washing
305  :parameter-type
306  '(choice :tag "Banner"
307           :value nil
308           (const :tag "Remove signature" signature)
309           (symbol :tag "Item in `gnus-article-banner-alist'" none)
310           regexp
311           (const :tag "None" nil))
312  :parameter-document
313  "If non-nil, specify how to remove `banners' from articles.
314
315 Symbol `signature' means to remove signatures delimited by
316 `gnus-signature-separator'.  Any other symbol is used to look up a
317 regular expression to match the banner in `gnus-article-banner-alist'.
318 A string is used as a regular expression to match the banner
319 directly.")
320
321 (defcustom gnus-article-address-banner-alist nil
322   "Alist of mail addresses and banners.
323 Each element has the form (ADDRESS . BANNER), where ADDRESS is a regexp
324 to match a mail address in the From: header, BANNER is one of a symbol
325 `signature', an item in `gnus-article-banner-alist', a regexp and nil.
326 If ADDRESS matches author's mail address, it will remove things like
327 advertisements.  For example:
328
329 \((\"@yoo-hoo\\\\.co\\\\.jp\\\\'\" . \"\\n_+\\nDo You Yoo-hoo!\\\\?\\n.*\\n.*\\n\"))
330 "
331   :type '(repeat
332           (cons
333            (regexp :tag "Address")
334            (choice :tag "Banner" :value nil
335                    (const :tag "Remove signature" signature)
336                    (symbol :tag "Item in `gnus-article-banner-alist'" none)
337                    regexp
338                    (const :tag "None" nil))))
339   :version "22.1"
340   :group 'gnus-article-washing)
341
342 (defmacro gnus-emphasis-custom-with-format (&rest body)
343   `(let ((format "\
344 \\(\\s-\\|^\\|\\=\\|[-\"]\\|\\s(\\)\\(%s\\(\\w+\\(\\s-+\\w+\\)*[.,]?\\)%s\\)\
345 \\(\\([-,.;:!?\"]\\|\\s)\\)+\\s-\\|[?!.]\\s-\\|\\s)\\|\\s-\\)"))
346      ,@body))
347
348 (defun gnus-emphasis-custom-value-to-external (value)
349   (gnus-emphasis-custom-with-format
350    (if (consp (car value))
351        (list (format format (car (car value)) (cdr (car value)))
352              2
353              (if (nth 1 value) 2 3)
354              (nth 2 value))
355      value)))
356
357 (defun gnus-emphasis-custom-value-to-internal (value)
358   (gnus-emphasis-custom-with-format
359    (let ((regexp (concat "\\`"
360                          (format (regexp-quote format)
361                                  "\\([^()]+\\)" "\\([^()]+\\)")
362                          "\\'"))
363          pattern)
364      (if (string-match regexp (setq pattern (car value)))
365          (list (cons (match-string 1 pattern) (match-string 2 pattern))
366                (= (nth 2 value) 2)
367                (nth 3 value))
368        value))))
369
370 (defcustom gnus-emphasis-alist
371   (let ((types
372          '(("\\*" "\\*" bold nil 2)
373            ("_" "_" underline)
374            ("/" "/" italic)
375            ("_/" "/_" underline-italic)
376            ("_\\*" "\\*_" underline-bold)
377            ("\\*/" "/\\*" bold-italic)
378            ("_\\*/" "/\\*_" underline-bold-italic))))
379     (nconc
380      (gnus-emphasis-custom-with-format
381       (mapcar (lambda (spec)
382                 (list (format format (car spec) (cadr spec))
383                       (or (nth 3 spec) 2)
384                       (or (nth 4 spec) 3)
385                       (intern (format "gnus-emphasis-%s" (nth 2 spec)))))
386               types))
387      '(;; I've never seen anyone use this strikethru convention whereas I've
388        ;; several times seen it triggered by normal text.  --Stef
389        ;; Miles suggests that this form is sometimes used but for italics,
390        ;; so maybe we should map it to `italic'.
391        ;; ("\\(\\s-\\|^\\)\\(-\\(\\(\\w\\|-[^-]\\)+\\)-\\)\\(\\s-\\|[?!.,;]\\)"
392        ;; 2 3 gnus-emphasis-strikethru)
393        ("\\(\\s-\\|^\\)\\(_\\(\\(\\w\\|_[^_]\\)+\\)_\\)\\(\\s-\\|[?!.,;]\\)"
394         2 3 gnus-emphasis-underline))))
395   "*Alist that says how to fontify certain phrases.
396 Each item looks like this:
397
398   (\"_\\\\(\\\\w+\\\\)_\" 0 1 'underline)
399
400 The first element is a regular expression to be matched.  The second
401 is a number that says what regular expression grouping used to find
402 the entire emphasized word.  The third is a number that says what
403 regexp grouping should be displayed and highlighted.  The fourth
404 is the face used for highlighting."
405   :type
406   '(repeat
407     (menu-choice
408      :format "%[Customizing Style%]\n%v"
409      :indent 2
410      (group :tag "Default"
411             :value ("" 0 0 default)
412             :value-create
413             (lambda (widget)
414               (let ((value (widget-get
415                             (cadr (widget-get (widget-get widget :parent)
416                                               :args))
417                             :value)))
418                 (if (not (eq (nth 2 value) 'default))
419                     (widget-put
420                      widget
421                      :value
422                      (gnus-emphasis-custom-value-to-external value))))
423               (widget-group-value-create widget))
424             regexp
425             (integer :format "Match group: %v")
426             (integer :format "Emphasize group: %v")
427             face)
428      (group :tag "Simple"
429             :value (("_" . "_") nil default)
430             (cons :format "%v"
431                   (regexp :format "Start regexp: %v")
432                   (regexp :format "End regexp: %v"))
433             (boolean :format "Show start and end patterns: %[%v%]\n"
434                      :on " On " :off " Off ")
435             face)))
436   :get (lambda (symbol)
437          (mapcar 'gnus-emphasis-custom-value-to-internal
438                  (default-value symbol)))
439   :set (lambda (symbol value)
440          (set-default symbol (mapcar 'gnus-emphasis-custom-value-to-external
441                                      value)))
442   :group 'gnus-article-emphasis)
443
444 (defcustom gnus-emphasize-whitespace-regexp "^[ \t]+\\|[ \t]*\n"
445   "A regexp to describe whitespace which should not be emphasized.
446 Typical values are \"^[ \\t]+\\\\|[ \\t]*\\n\" and \"[ \\t]+\\\\|[ \\t]*\\n\".
447 The former avoids underlining of leading and trailing whitespace,
448 and the latter avoids underlining any whitespace at all."
449   :version "21.1"
450   :group 'gnus-article-emphasis
451   :type 'regexp)
452
453 (defface gnus-emphasis-bold '((t (:bold t)))
454   "Face used for displaying strong emphasized text (*word*)."
455   :group 'gnus-article-emphasis)
456
457 (defface gnus-emphasis-italic '((t (:italic t)))
458   "Face used for displaying italic emphasized text (/word/)."
459   :group 'gnus-article-emphasis)
460
461 (defface gnus-emphasis-underline '((t (:underline t)))
462   "Face used for displaying underlined emphasized text (_word_)."
463   :group 'gnus-article-emphasis)
464
465 (defface gnus-emphasis-underline-bold '((t (:bold t :underline t)))
466   "Face used for displaying underlined bold emphasized text (_*word*_)."
467   :group 'gnus-article-emphasis)
468
469 (defface gnus-emphasis-underline-italic '((t (:italic t :underline t)))
470   "Face used for displaying underlined italic emphasized text (_/word/_)."
471   :group 'gnus-article-emphasis)
472
473 (defface gnus-emphasis-bold-italic '((t (:bold t :italic t)))
474   "Face used for displaying bold italic emphasized text (/*word*/)."
475   :group 'gnus-article-emphasis)
476
477 (defface gnus-emphasis-underline-bold-italic
478   '((t (:bold t :italic t :underline t)))
479   "Face used for displaying underlined bold italic emphasized text.
480 Example: (_/*word*/_)."
481   :group 'gnus-article-emphasis)
482
483 (defface gnus-emphasis-strikethru (if (featurep 'xemacs)
484                                       '((t (:strikethru t)))
485                                     '((t (:strike-through t))))
486   "Face used for displaying strike-through text (-word-)."
487   :group 'gnus-article-emphasis)
488
489 (defface gnus-emphasis-highlight-words
490   '((t (:background "black" :foreground "yellow")))
491   "Face used for displaying highlighted words."
492   :group 'gnus-article-emphasis)
493
494 (defcustom gnus-article-time-format "%a, %d %b %Y %T %Z"
495   "Format for display of Date headers in article bodies.
496 See `format-time-string' for the possible values.
497
498 The variable can also be function, which should return a complete Date
499 header.  The function is called with one argument, the time, which can
500 be fed to `format-time-string'."
501   :type '(choice string function)
502   :link '(custom-manual "(gnus)Article Date")
503   :group 'gnus-article-washing)
504
505 (defcustom gnus-save-all-headers t
506   "*If non-nil, don't remove any headers before saving.
507 This will be overridden by the `:headers' property that the symbol of
508 the saver function, which is specified by `gnus-default-article-saver',
509 might have."
510   :group 'gnus-article-saving
511   :type 'boolean)
512
513 (defcustom gnus-prompt-before-saving 'always
514   "*This variable says how much prompting is to be done when saving articles.
515 If it is nil, no prompting will be done, and the articles will be
516 saved to the default files.  If this variable is `always', each and
517 every article that is saved will be preceded by a prompt, even when
518 saving large batches of articles.  If this variable is neither nil not
519 `always', there the user will be prompted once for a file name for
520 each invocation of the saving commands."
521   :group 'gnus-article-saving
522   :type '(choice (item always)
523                  (item :tag "never" nil)
524                  (sexp :tag "once" :format "%t\n" :value t)))
525
526 (defcustom gnus-saved-headers gnus-visible-headers
527   "Headers to keep if `gnus-save-all-headers' is nil.
528 If `gnus-save-all-headers' is non-nil, this variable will be ignored.
529 If that variable is nil, however, all headers that match this regexp
530 will be kept while the rest will be deleted before saving.  This and
531 `gnus-save-all-headers' will be overridden by the `:headers' property
532 that the symbol of the saver function, which is specified by
533 `gnus-default-article-saver', might have."
534   :group 'gnus-article-saving
535   :type 'regexp)
536
537 ;; Note that "Rmail format" is mbox since Emacs 23, but Babyl before.
538 (defcustom gnus-default-article-saver 'gnus-summary-save-in-rmail
539   "A function to save articles in your favorite format.
540 The function will be called by way of the `gnus-summary-save-article'
541 command, and friends such as `gnus-summary-save-article-rmail'.
542
543 Gnus provides the following functions:
544
545 * gnus-summary-save-in-rmail (Rmail format)
546 * gnus-summary-save-in-mail (Unix mail format)
547 * gnus-summary-save-in-folder (MH folder)
548 * gnus-summary-save-in-file (article format)
549 * gnus-summary-save-body-in-file (article body)
550 * gnus-summary-save-in-vm (use VM's folder format)
551 * gnus-summary-write-to-file (article format -- overwrite)
552 * gnus-summary-write-body-to-file (article body -- overwrite)
553 * gnus-summary-save-in-pipe (article format)
554
555 The symbol of each function may have the following properties:
556
557 * :decode
558 The value non-nil means save decoded articles.  This is meaningful
559 only with `gnus-summary-save-in-file', `gnus-summary-save-body-in-file',
560 `gnus-summary-write-to-file', `gnus-summary-write-body-to-file', and
561 `gnus-summary-save-in-pipe'.
562
563 * :function
564 The value specifies an alternative function which appends, not
565 overwrites, articles to a file.  This implies that when saving many
566 articles at a time, `gnus-prompt-before-saving' is bound to t and all
567 articles are saved in a single file.  This is meaningful only with
568 `gnus-summary-write-to-file' and `gnus-summary-write-body-to-file'.
569
570 * :headers
571 The value specifies the symbol of a variable of which the value
572 specifies headers to be saved.  If it is omitted,
573 `gnus-save-all-headers' and `gnus-saved-headers' control what
574 headers should be saved."
575   :group 'gnus-article-saving
576   :type '(radio (function-item gnus-summary-save-in-rmail)
577                 (function-item gnus-summary-save-in-mail)
578                 (function-item gnus-summary-save-in-folder)
579                 (function-item gnus-summary-save-in-file)
580                 (function-item gnus-summary-save-body-in-file)
581                 (function-item gnus-summary-save-in-vm)
582                 (function-item gnus-summary-write-to-file)
583                 (function-item gnus-summary-write-body-to-file)
584                 (function-item gnus-summary-save-in-pipe)
585                 (function)))
586
587 (defcustom gnus-article-save-coding-system
588   (or (and (mm-coding-system-p 'utf-8) 'utf-8)
589       (and (mm-coding-system-p 'iso-2022-7bit) 'iso-2022-7bit)
590       (and (mm-coding-system-p 'emacs-mule) 'emacs-mule)
591       (and (mm-coding-system-p 'escape-quoted) 'escape-quoted))
592   "Coding system used to save decoded articles to a file.
593
594 The recommended coding systems are `utf-8', `iso-2022-7bit' and so on,
595 which can safely encode any characters in text.  This is used by the
596 commands including:
597
598 * gnus-summary-save-article-file
599 * gnus-summary-save-article-body-file
600 * gnus-summary-write-article-file
601 * gnus-summary-write-article-body-file
602
603 and the functions to which you may set `gnus-default-article-saver':
604
605 * gnus-summary-save-in-file
606 * gnus-summary-save-body-in-file
607 * gnus-summary-write-to-file
608 * gnus-summary-write-body-to-file
609
610 Those commands and functions save just text displayed in the article
611 buffer to a file if the value of this variable is non-nil.  Note that
612 buttonized MIME parts will be lost in a saved file in that case.
613 Otherwise, raw articles will be saved."
614   :group 'gnus-article-saving
615   :type `(choice
616           :format "%{%t%}:\n %[Value Menu%] %v"
617           (const :tag "Save raw articles" nil)
618           ,@(delq nil
619                   (mapcar
620                    (lambda (arg) (if (mm-coding-system-p (nth 3 arg)) arg))
621                    '((const :tag "UTF-8" utf-8)
622                      (const :tag "iso-2022-7bit" iso-2022-7bit)
623                      (const :tag "Emacs internal" emacs-mule)
624                      (const :tag "escape-quoted" escape-quoted))))
625           (symbol :tag "Coding system")))
626
627 (defcustom gnus-rmail-save-name 'gnus-plain-save-name
628   "A function generating a file name to save articles in Rmail format.
629 The function is called with NEWSGROUP, HEADERS, and optional LAST-FILE."
630   :group 'gnus-article-saving
631   :type 'function)
632
633 (defcustom gnus-mail-save-name 'gnus-plain-save-name
634   "A function generating a file name to save articles in Unix mail format.
635 The function is called with NEWSGROUP, HEADERS, and optional LAST-FILE."
636   :group 'gnus-article-saving
637   :type 'function)
638
639 (defcustom gnus-folder-save-name 'gnus-folder-save-name
640   "A function generating a file name to save articles in MH folder.
641 The function is called with NEWSGROUP, HEADERS, and optional LAST-FOLDER."
642   :group 'gnus-article-saving
643   :type 'function)
644
645 (defcustom gnus-file-save-name 'gnus-numeric-save-name
646   "A function generating a file name to save articles in article format.
647 The function is called with NEWSGROUP, HEADERS, and optional
648 LAST-FILE."
649   :group 'gnus-article-saving
650   :type 'function)
651
652 (defcustom gnus-split-methods
653   '((gnus-article-archive-name)
654     (gnus-article-nndoc-name))
655   "*Variable used to suggest where articles are to be saved.
656 For instance, if you would like to save articles related to Gnus in
657 the file \"gnus-stuff\", and articles related to VM in \"vm-stuff\",
658 you could set this variable to something like:
659
660  '((\"^Subject:.*gnus\\|^Newsgroups:.*gnus\" \"gnus-stuff\")
661    (\"^Subject:.*vm\\|^Xref:.*vm\" \"vm-stuff\"))
662
663 This variable is an alist where the key is the match and the
664 value is a list of possible files to save in if the match is
665 non-nil.
666
667 If the match is a string, it is used as a regexp match on the
668 article.  If the match is a symbol, that symbol will be funcalled
669 from the buffer of the article to be saved with the newsgroup as the
670 parameter.  If it is a list, it will be evalled in the same buffer.
671
672 If this form or function returns a string, this string will be used as a
673 possible file name; and if it returns a non-nil list, that list will be
674 used as possible file names."
675   :group 'gnus-article-saving
676   :type '(repeat (choice (list :value (fun) function)
677                          (cons :value ("" "") regexp (repeat string))
678                          (sexp :value nil))))
679
680 (defcustom gnus-page-delimiter "^\^L"
681   "*Regexp describing what to use as article page delimiters.
682 The default value is \"^\^L\", which is a form linefeed at the
683 beginning of a line."
684   :type 'regexp
685   :group 'gnus-article-various)
686
687 (defcustom gnus-article-mode-line-format "Gnus: %g %S%m"
688   "*The format specification for the article mode line.
689 See `gnus-summary-mode-line-format' for a closer description.
690
691 The following additional specs are available:
692
693 %w  The article washing status.
694 %m  The number of MIME parts in the article."
695   :version "24.1"
696   :type 'string
697   :group 'gnus-article-various)
698
699 (defcustom gnus-article-mode-hook nil
700   "*A hook for Gnus article mode."
701   :type 'hook
702   :group 'gnus-article-various)
703
704 (when (featurep 'xemacs)
705   ;; Extracted from gnus-xmas-define in order to preserve user settings
706   (when (fboundp 'turn-off-scroll-in-place)
707     (add-hook 'gnus-article-mode-hook 'turn-off-scroll-in-place))
708   ;; Extracted from gnus-xmas-redefine in order to preserve user settings
709   (add-hook 'gnus-article-mode-hook 'gnus-xmas-article-menu-add))
710
711 (defcustom gnus-article-menu-hook nil
712   "*Hook run after the creation of the article mode menu."
713   :type 'hook
714   :group 'gnus-article-various)
715
716 (defcustom gnus-article-prepare-hook nil
717   "*A hook called after an article has been prepared in the article buffer."
718   :type 'hook
719   :group 'gnus-article-various)
720
721 (defcustom gnus-copy-article-ignored-headers nil
722   "List of headers to be removed when copying an article.
723 Each element is a regular expression."
724   :version "23.1" ;; No Gnus
725   :type '(repeat regexp)
726   :group 'gnus-article-various)
727
728 (make-obsolete-variable 'gnus-article-hide-pgp-hook nil
729                         "Gnus 5.10 (Emacs 22.1)")
730
731 (defface gnus-button
732   '((t (:weight bold)))
733   "Face used for highlighting a button in the article buffer."
734   :group 'gnus-article-buttons)
735
736 (defcustom gnus-article-button-face 'gnus-button
737   "Face used for highlighting buttons in the article buffer.
738
739 An article button is a piece of text that you can activate by pressing
740 `RET' or `mouse-2' above it."
741   :type 'face
742   :group 'gnus-article-buttons)
743
744 (defcustom gnus-article-mouse-face 'highlight
745   "Face used for mouse highlighting in the article buffer.
746
747 Article buttons will be displayed in this face when the cursor is
748 above them."
749   :type 'face
750   :group 'gnus-article-buttons)
751
752 (defcustom gnus-signature-face 'gnus-signature
753   "Face used for highlighting a signature in the article buffer.
754 Obsolete; use the face `gnus-signature' for customizations instead."
755   :type 'face
756   :group 'gnus-article-highlight
757   :group 'gnus-article-signature)
758
759 (defface gnus-signature
760   '((t
761      (:italic t)))
762   "Face used for highlighting a signature in the article buffer."
763   :group 'gnus-article-highlight
764   :group 'gnus-article-signature)
765 ;; backward-compatibility alias
766 (put 'gnus-signature-face 'face-alias 'gnus-signature)
767 (put 'gnus-signature-face 'obsolete-face "22.1")
768
769 (defface gnus-header-from
770   '((((class color)
771       (background dark))
772      (:foreground "PaleGreen1"))
773     (((class color)
774       (background light))
775      (:foreground "red3"))
776     (t
777      (:italic t)))
778   "Face used for displaying from headers."
779   :group 'gnus-article-headers
780   :group 'gnus-article-highlight)
781 ;; backward-compatibility alias
782 (put 'gnus-header-from-face 'face-alias 'gnus-header-from)
783 (put 'gnus-header-from-face 'obsolete-face "22.1")
784
785 (defface gnus-header-subject
786   '((((class color)
787       (background dark))
788      (:foreground "SeaGreen1"))
789     (((class color)
790       (background light))
791      (:foreground "red4"))
792     (t
793      (:bold t :italic t)))
794   "Face used for displaying subject headers."
795   :group 'gnus-article-headers
796   :group 'gnus-article-highlight)
797 ;; backward-compatibility alias
798 (put 'gnus-header-subject-face 'face-alias 'gnus-header-subject)
799 (put 'gnus-header-subject-face 'obsolete-face "22.1")
800
801 (defface gnus-header-newsgroups
802   '((((class color)
803       (background dark))
804      (:foreground "yellow" :italic t))
805     (((class color)
806       (background light))
807      (:foreground "MidnightBlue" :italic t))
808     (t
809      (:italic t)))
810   "Face used for displaying newsgroups headers.
811 In the default setup this face is only used for crossposted
812 articles."
813   :group 'gnus-article-headers
814   :group 'gnus-article-highlight)
815 ;; backward-compatibility alias
816 (put 'gnus-header-newsgroups-face 'face-alias 'gnus-header-newsgroups)
817 (put 'gnus-header-newsgroups-face 'obsolete-face "22.1")
818
819 (defface gnus-header-name
820   '((((class color)
821       (background dark))
822      (:foreground "SpringGreen2"))
823     (((class color)
824       (background light))
825      (:foreground "maroon"))
826     (t
827      (:bold t)))
828   "Face used for displaying header names."
829   :group 'gnus-article-headers
830   :group 'gnus-article-highlight)
831 ;; backward-compatibility alias
832 (put 'gnus-header-name-face 'face-alias 'gnus-header-name)
833 (put 'gnus-header-name-face 'obsolete-face "22.1")
834
835 (defface gnus-header-content
836   '((((class color)
837       (background dark))
838      (:foreground "SpringGreen1" :italic t))
839     (((class color)
840       (background light))
841      (:foreground "indianred4" :italic t))
842     (t
843      (:italic t)))  "Face used for displaying header content."
844   :group 'gnus-article-headers
845   :group 'gnus-article-highlight)
846 ;; backward-compatibility alias
847 (put 'gnus-header-content-face 'face-alias 'gnus-header-content)
848 (put 'gnus-header-content-face 'obsolete-face "22.1")
849
850 (defcustom gnus-header-face-alist
851   '(("From" nil gnus-header-from)
852     ("Subject" nil gnus-header-subject)
853     ("Newsgroups:.*," nil gnus-header-newsgroups)
854     ("" gnus-header-name gnus-header-content))
855   "*Controls highlighting of article headers.
856
857 An alist of the form (HEADER NAME CONTENT).
858
859 HEADER is a regular expression which should match the name of a
860 header and NAME and CONTENT are either face names or nil.
861
862 The name of each header field will be displayed using the face
863 specified by the first element in the list where HEADER matches
864 the header name and NAME is non-nil.  Similarly, the content will
865 be displayed by the first non-nil matching CONTENT face."
866   :group 'gnus-article-headers
867   :group 'gnus-article-highlight
868   :type '(repeat (list (regexp :tag "Header")
869                        (choice :tag "Name"
870                                (item :tag "skip" nil)
871                                (face :value default))
872                        (choice :tag "Content"
873                                (item :tag "skip" nil)
874                                (face :value default)))))
875
876 (defcustom gnus-face-properties-alist (if (featurep 'xemacs)
877                                           '((xface . (:face gnus-x-face)))
878                                         '((pbm . (:face gnus-x-face))
879                                           (png . nil)))
880   "Alist of image types and properties applied to Face and X-Face images.
881 Here are examples:
882
883 ;; Specify the altitude of Face images in the From header.
884 \(setq gnus-face-properties-alist
885       '((pbm . (:face gnus-x-face :ascent 80))
886         (png . (:ascent 80))))
887
888 ;; Show Face images as pressed buttons.
889 \(setq gnus-face-properties-alist
890       '((pbm . (:face gnus-x-face :relief -2))
891         (png . (:relief -2))))
892
893 See the manual for the valid properties for various image types.
894 Currently, `pbm' is used for X-Face images and `png' is used for Face
895 images in Emacs.  Only the `:face' property is effective on the `xface'
896 image type in XEmacs if it is built with the libcompface library."
897   :version "23.1" ;; No Gnus
898   :group 'gnus-article-headers
899   :type '(repeat (cons :format "%v" (symbol :tag "Image type") plist)))
900
901 (defcustom gnus-article-decode-hook
902   '(article-decode-charset article-decode-encoded-words
903                            article-decode-group-name article-decode-idna-rhs)
904   "*Hook run to decode charsets in articles."
905   :group 'gnus-article-headers
906   :type 'hook)
907
908 (defcustom gnus-display-mime-function 'gnus-display-mime
909   "Function to display MIME articles."
910   :group 'gnus-article-mime
911   :type 'function)
912
913 (defvar gnus-decode-header-function 'mail-decode-encoded-word-region
914   "Function used to decode headers.")
915
916 (defvar gnus-decode-address-function 'mail-decode-encoded-address-region
917   "Function used to decode addresses.")
918
919 (defvar gnus-article-dumbquotes-map
920   '((?\200 "EUR")
921     (?\202 ",")
922     (?\203 "f")
923     (?\204 ",,")
924     (?\205 "...")
925     (?\213 "<")
926     (?\214 "OE")
927     (?\221 "`")
928     (?\222 "'")
929     (?\223 "``")
930     (?\224 "\"")
931     (?\225 "*")
932     (?\226 "-")
933     (?\227 "--")
934     (?\230 "~")
935     (?\231 "(TM)")
936     (?\233 ">")
937     (?\234 "oe")
938     (?\264 "'"))
939   "Table for MS-to-Latin1 translation.")
940
941 (defcustom gnus-ignored-mime-types nil
942   "List of MIME types that should be ignored by Gnus."
943   :version "21.1"
944   :group 'gnus-article-mime
945   :type '(repeat regexp))
946
947 (defcustom gnus-unbuttonized-mime-types '(".*/.*")
948   "List of MIME types that should not be given buttons when rendered inline.
949 See also `gnus-buttonized-mime-types' which may override this variable.
950 This variable is only used when `gnus-inhibit-mime-unbuttonizing' is nil."
951   :version "21.1"
952   :group 'gnus-article-mime
953   :type '(repeat regexp))
954
955 (defcustom gnus-buttonized-mime-types nil
956   "List of MIME types that should be given buttons when rendered inline.
957 If set, this variable overrides `gnus-unbuttonized-mime-types'.
958 To see e.g. security buttons you could set this to
959 `(\"multipart/signed\")'.  You could also add \"multipart/alternative\" to
960 this list to display radio buttons that allow you to choose one of two
961 media types those mails include.  See also `mm-discouraged-alternatives'.
962 This variable is only used when `gnus-inhibit-mime-unbuttonizing' is nil."
963   :version "22.1"
964   :group 'gnus-article-mime
965   :type '(repeat regexp))
966
967 (defcustom gnus-inhibit-mime-unbuttonizing nil
968   "If non-nil, all MIME parts get buttons.
969 When nil (the default value), then some MIME parts do not get buttons,
970 as described by the variables `gnus-buttonized-mime-types' and
971 `gnus-unbuttonized-mime-types'."
972   :version "22.1"
973   :group 'gnus-article-mime
974   :type 'boolean)
975
976 (defcustom gnus-body-boundary-delimiter "_"
977   "String used to delimit header and body.
978 This variable is used by `gnus-article-treat-body-boundary' which can
979 be controlled by `gnus-treat-body-boundary'."
980   :version "22.1"
981   :group 'gnus-article-various
982   :type '(choice (item :tag "None" :value nil)
983                  string))
984
985 (defcustom gnus-picon-databases '("/usr/lib/picon" "/usr/local/faces"
986                                   "/usr/share/picons")
987   "Defines the location of the faces database.
988 For information on obtaining this database of pretty pictures, please
989 see http://www.cs.indiana.edu/picons/ftp/index.html"
990   :version "22.1"
991   :type '(repeat directory)
992   :link '(url-link :tag "download"
993                    "http://www.cs.indiana.edu/picons/ftp/index.html")
994   :link '(custom-manual "(gnus)Picons")
995   :group 'gnus-picon)
996
997 (defun gnus-picons-installed-p ()
998   "Say whether picons are installed on your machine."
999   (let ((installed nil))
1000     (dolist (database gnus-picon-databases)
1001       (when (file-exists-p database)
1002         (setq installed t)))
1003     installed))
1004
1005 (defcustom gnus-article-mime-part-function nil
1006   "Function called with a MIME handle as the argument.
1007 This is meant for people who want to do something automatic based
1008 on parts -- for instance, adding Vcard info to a database."
1009   :group 'gnus-article-mime
1010   :type '(choice (const nil)
1011                  function))
1012
1013 (defcustom gnus-mime-multipart-functions nil
1014   "An alist of MIME types to functions to display them."
1015   :version "21.1"
1016   :group 'gnus-article-mime
1017   :type '(repeat (cons :format "%v" (string :tag "MIME type") function)))
1018
1019 (defcustom gnus-article-date-headers '(combined-lapsed)
1020   "A list of Date header formats to display.
1021 Valid formats are `ut' (universal time), `local' (local time
1022 zone), `english' (readable English), `lapsed' (elapsed time),
1023 `combined-lapsed' (both the original date and the elapsed time),
1024 `original' (the original date header), `iso8601' (ISO8601
1025 format), and `user-defined' (a user-defined format defined by the
1026 `gnus-article-time-format' variable).
1027
1028 You have as many date headers as you want in the article buffer.
1029 Some of these headers are updated automatically.  See
1030 `gnus-article-update-date-headers' for details."
1031   :version "24.1"
1032   :group 'gnus-article-headers
1033   :type '(set
1034           (const :tag "Universal time (UT)" ut)
1035           (const :tag "Local time zone" local)
1036           (const :tag "Readable English" english)
1037           (const :tag "Elapsed time" lapsed)
1038           (const :tag "Original and elapsed time" combined-lapsed)
1039           (const :tag "Original date header" original)
1040           (const :tag "ISO8601 format" iso8601)
1041           (const :tag "User-defined" user-defined)))
1042
1043 (defcustom gnus-article-update-date-headers nil
1044   "A number that says how often to update the date header (in seconds).
1045 If nil, don't update it at all."
1046   :version "24.1"
1047   :group 'gnus-article-headers
1048   :type '(choice
1049           (item :tag "Don't update" :value nil)
1050           integer))
1051
1052 (defcustom gnus-article-mime-match-handle-function 'undisplayed-alternative
1053   "Function called with a MIME handle as the argument.
1054 This is meant for people who want to view first matched part.
1055 For `undisplayed-alternative' (default), the first undisplayed
1056 part or alternative part is used.  For `undisplayed', the first
1057 undisplayed part is used.  For a function, the first part which
1058 the function return t is used.  For nil, the first part is
1059 used."
1060   :version "21.1"
1061   :group 'gnus-article-mime
1062   :type '(choice
1063           (item :tag "first" :value nil)
1064           (item :tag "undisplayed" :value undisplayed)
1065           (item :tag "undisplayed or alternative"
1066                 :value undisplayed-alternative)
1067           (function)))
1068
1069 (defcustom gnus-mime-action-alist
1070   '(("save to file" . gnus-mime-save-part)
1071     ("save and strip" . gnus-mime-save-part-and-strip)
1072     ("replace with file" . gnus-mime-replace-part)
1073     ("delete part" . gnus-mime-delete-part)
1074     ("display as text" . gnus-mime-inline-part)
1075     ("view the part" . gnus-mime-view-part)
1076     ("pipe to command" . gnus-mime-pipe-part)
1077     ("toggle display" . gnus-article-press-button)
1078     ("toggle display" . gnus-article-view-part-as-charset)
1079     ("view as type" . gnus-mime-view-part-as-type)
1080     ("view internally" . gnus-mime-view-part-internally)
1081     ("view externally" . gnus-mime-view-part-externally))
1082   "An alist of actions that run on the MIME attachment."
1083   :group 'gnus-article-mime
1084   :type '(repeat (cons (string :tag "name")
1085                        (function))))
1086
1087 (defcustom gnus-auto-select-part 1
1088   "Advance to next MIME part when deleting or stripping parts.
1089
1090 When 0, point will be placed on the same part as before.  When
1091 positive (negative), move point forward (backwards) this many
1092 parts.  When nil, redisplay article."
1093   :version "23.1" ;; No Gnus
1094   :group 'gnus-article-mime
1095   :type '(choice (const nil :tag "Redisplay article.")
1096                  (const 1 :tag "Next part.")
1097                  (const 0 :tag "Current part.")
1098                  integer))
1099
1100 ;;;
1101 ;;; The treatment variables
1102 ;;;
1103
1104 (defvar gnus-part-display-hook nil
1105   "Hook called on parts that are to receive treatment.")
1106
1107 (defvar gnus-article-treat-custom
1108   '(choice (const :tag "Off" nil)
1109            (const :tag "On" t)
1110            (const :tag "Header" head)
1111            (const :tag "First" first)
1112            (const :tag "Last" last)
1113            (integer :tag "Less")
1114            (repeat :tag "Groups" regexp)
1115            (sexp :tag "Predicate")))
1116
1117 (defvar gnus-article-treat-head-custom
1118   '(choice (const :tag "Off" nil)
1119            (const :tag "Header" head)))
1120
1121 (defvar gnus-article-treat-types '("text/plain" "text/x-verbatim"
1122                                    "text/x-patch" "text/html")
1123   "Part types eligible for treatment.")
1124
1125 (defvar gnus-inhibit-treatment nil
1126   "Whether to inhibit treatment.")
1127
1128 (defcustom gnus-treat-highlight-signature '(or t (typep "text/x-vcard"))
1129   "Highlight the signature.
1130 Valid values are nil, t, `head', `first', `last', an integer or a
1131 predicate.  See Info node `(gnus)Customizing Articles'."
1132   :group 'gnus-article-treat
1133   :link '(custom-manual "(gnus)Customizing Articles")
1134   :type gnus-article-treat-custom)
1135 (put 'gnus-treat-highlight-signature 'highlight t)
1136
1137 (defcustom gnus-treat-buttonize 100000
1138   "Add buttons.
1139 Valid values are nil, t, `head', `first', `last', an integer or a
1140 predicate.  See Info node `(gnus)Customizing Articles'."
1141   :group 'gnus-article-treat
1142   :link '(custom-manual "(gnus)Customizing Articles")
1143   :type gnus-article-treat-custom)
1144 (put 'gnus-treat-buttonize 'highlight t)
1145
1146 (defcustom gnus-treat-buttonize-head 'head
1147   "Add buttons to the head.
1148 Valid values are nil, t, `head', `first', `last', an integer or a
1149 predicate.  See Info node `(gnus)Customizing Articles'."
1150   :group 'gnus-article-treat
1151   :link '(custom-manual "(gnus)Customizing Articles")
1152   :type gnus-article-treat-head-custom)
1153 (put 'gnus-treat-buttonize-head 'highlight t)
1154
1155 (defcustom gnus-treat-date 'head
1156   "Display dates according to the `gnus-article-date-headers' variable.
1157 Valid values are nil, t, `head', `first', `last', an integer or a
1158 predicate.  See Info node `(gnus)Customizing Articles'."
1159   :version "24.1"
1160   :group 'gnus-article-treat
1161   :link '(custom-manual "(gnus)Customizing Articles")
1162   :type gnus-article-treat-head-custom)
1163
1164 (defcustom gnus-treat-emphasize 50000
1165   "Emphasize text.
1166 Valid values are nil, t, `head', `first', `last', an integer or a
1167 predicate.  See Info node `(gnus)Customizing Articles'."
1168   :group 'gnus-article-treat
1169   :link '(custom-manual "(gnus)Customizing Articles")
1170   :type gnus-article-treat-custom)
1171 (put 'gnus-treat-emphasize 'highlight t)
1172
1173 (defcustom gnus-treat-strip-cr nil
1174   "Remove carriage returns.
1175 Valid values are nil, t, `head', `first', `last', an integer or a
1176 predicate.  See Info node `(gnus)Customizing Articles'."
1177   :version "22.1"
1178   :group 'gnus-article-treat
1179   :link '(custom-manual "(gnus)Customizing Articles")
1180   :type gnus-article-treat-custom)
1181
1182 (defcustom gnus-treat-unsplit-urls nil
1183   "Remove newlines from within URLs.
1184 Valid values are nil, t, `head', `first', `last', an integer or a
1185 predicate.  See Info node `(gnus)Customizing Articles'."
1186   :version "22.1"
1187   :group 'gnus-article-treat
1188   :link '(custom-manual "(gnus)Customizing Articles")
1189   :type gnus-article-treat-custom)
1190
1191 (defcustom gnus-treat-leading-whitespace nil
1192   "Remove leading whitespace in headers.
1193 Valid values are nil, t, `head', `first', `last', an integer or a
1194 predicate.  See Info node `(gnus)Customizing Articles'."
1195   :version "22.1"
1196   :group 'gnus-article-treat
1197   :link '(custom-manual "(gnus)Customizing Articles")
1198   :type gnus-article-treat-custom)
1199
1200 (defcustom gnus-treat-hide-headers 'head
1201   "Hide headers.
1202 Valid values are nil, t, `head', `first', `last', an integer or a
1203 predicate.  See Info node `(gnus)Customizing Articles'."
1204   :group 'gnus-article-treat
1205   :link '(custom-manual "(gnus)Customizing Articles")
1206   :type gnus-article-treat-head-custom)
1207
1208 (defcustom gnus-treat-hide-boring-headers nil
1209   "Hide boring headers.
1210 Valid values are nil, t, `head', `first', `last', an integer or a
1211 predicate.  See Info node `(gnus)Customizing Articles'."
1212   :group 'gnus-article-treat
1213   :link '(custom-manual "(gnus)Customizing Articles")
1214   :type gnus-article-treat-head-custom)
1215
1216 (defcustom gnus-treat-hide-signature nil
1217   "Hide the signature.
1218 Valid values are nil, t, `head', `first', `last', an integer or a
1219 predicate.  See Info node `(gnus)Customizing Articles'."
1220   :group 'gnus-article-treat
1221   :link '(custom-manual "(gnus)Customizing Articles")
1222   :type gnus-article-treat-custom)
1223
1224 (defcustom gnus-treat-fill-article nil
1225   "Fill the article.
1226 Valid values are nil, t, `head', `first', `last', an integer or a
1227 predicate.  See Info node `(gnus)Customizing Articles'."
1228   :group 'gnus-article-treat
1229   :link '(custom-manual "(gnus)Customizing Articles")
1230   :type gnus-article-treat-custom)
1231
1232 (defcustom gnus-treat-hide-citation nil
1233   "Hide cited text.
1234 Valid values are nil, t, `head', `first', `last', an integer or a
1235 predicate.  See Info node `(gnus)Customizing Articles'.
1236
1237 See `gnus-article-highlight-citation' for variables used to
1238 control what it hides."
1239   :group 'gnus-article-treat
1240   :link '(custom-manual "(gnus)Customizing Articles")
1241   :type gnus-article-treat-custom)
1242
1243 (defcustom gnus-treat-hide-citation-maybe nil
1244   "Hide cited text according to certain conditions.
1245 Valid values are nil, t, `head', `first', `last', an integer or a
1246 predicate.  See Info node `(gnus)Customizing Articles'.
1247
1248 See `gnus-cite-hide-percentage' and `gnus-cite-hide-absolute' for
1249 how to control what it hides."
1250   :group 'gnus-article-treat
1251   :link '(custom-manual "(gnus)Customizing Articles")
1252   :type gnus-article-treat-custom)
1253
1254 (defcustom gnus-treat-strip-list-identifiers 'head
1255   "Strip list identifiers from `gnus-list-identifiers`.
1256 Valid values are nil, t, `head', `first', `last', an integer or a
1257 predicate.  See Info node `(gnus)Customizing Articles'."
1258   :version "21.1"
1259   :group 'gnus-article-treat
1260   :link '(custom-manual "(gnus)Customizing Articles")
1261   :type gnus-article-treat-custom)
1262
1263 (gnus-define-group-parameter
1264  list-identifier
1265  :variable-document
1266  "Alist of regexps and correspondent identifiers."
1267  :variable-group gnus-article-washing
1268  :parameter-type
1269  '(choice :tag "Identifier"
1270           :value nil
1271           (symbol :tag "Item in `gnus-list-identifiers'" none)
1272           regexp
1273           (const :tag "None" nil))
1274  :parameter-document
1275  "If non-nil, specify how to remove `identifiers' from articles' subject.
1276
1277 Any symbol is used to look up a regular expression to match the
1278 banner in `gnus-list-identifiers'.  A string is used as a regular
1279 expression to match the identifier directly.")
1280
1281 (make-obsolete-variable 'gnus-treat-strip-pgp nil
1282                         "Gnus 5.10 (Emacs 22.1)")
1283
1284 (defcustom gnus-treat-strip-pem nil
1285   "Strip PEM signatures.
1286 Valid values are nil, t, `head', `first', `last', an integer or a
1287 predicate.  See Info node `(gnus)Customizing Articles'."
1288   :group 'gnus-article-treat
1289   :link '(custom-manual "(gnus)Customizing Articles")
1290   :type gnus-article-treat-custom)
1291
1292 (defcustom gnus-treat-strip-banner t
1293   "Strip banners from articles.
1294 The banner to be stripped is specified in the `banner' group parameter.
1295 Valid values are nil, t, `head', `first', `last', an integer or a
1296 predicate.  See Info node `(gnus)Customizing Articles'."
1297   :group 'gnus-article-treat
1298   :link '(custom-manual "(gnus)Customizing Articles")
1299   :type gnus-article-treat-custom)
1300
1301 (defcustom gnus-treat-highlight-headers 'head
1302   "Highlight the headers.
1303 Valid values are nil, t, `head', `first', `last', an integer or a
1304 predicate.  See Info node `(gnus)Customizing Articles'."
1305   :group 'gnus-article-treat
1306   :link '(custom-manual "(gnus)Customizing Articles")
1307   :type gnus-article-treat-head-custom)
1308 (put 'gnus-treat-highlight-headers 'highlight t)
1309
1310 (defcustom gnus-treat-highlight-citation t
1311   "Highlight cited text.
1312 Valid values are nil, t, `head', `first', `last', an integer or a
1313 predicate.  See Info node `(gnus)Customizing Articles'."
1314   :group 'gnus-article-treat
1315   :link '(custom-manual "(gnus)Customizing Articles")
1316   :type gnus-article-treat-custom)
1317 (put 'gnus-treat-highlight-citation 'highlight t)
1318
1319 (defcustom gnus-treat-strip-headers-in-body t
1320   "Strip the X-No-Archive header line from the beginning of the body.
1321 Valid values are nil, t, `head', `first', `last', an integer or a
1322 predicate.  See Info node `(gnus)Customizing Articles'."
1323   :version "21.1"
1324   :group 'gnus-article-treat
1325   :link '(custom-manual "(gnus)Customizing Articles")
1326   :type gnus-article-treat-custom)
1327
1328 (defcustom gnus-treat-strip-trailing-blank-lines nil
1329   "Strip trailing blank lines.
1330 Valid values are nil, t, `head', `first', `last', an integer or a
1331 predicate.  See Info node `(gnus)Customizing Articles'.
1332
1333 When set to t, it also strips trailing blanks in all MIME parts.
1334 Consider to use `last' instead."
1335   :group 'gnus-article-treat
1336   :link '(custom-manual "(gnus)Customizing Articles")
1337   :type gnus-article-treat-custom)
1338
1339 (defcustom gnus-treat-strip-leading-blank-lines nil
1340   "Strip leading blank lines.
1341 Valid values are nil, t, `head', `first', `last', an integer or a
1342 predicate.  See Info node `(gnus)Customizing Articles'.
1343
1344 When set to t, it also strips trailing blanks in all MIME parts."
1345   :group 'gnus-article-treat
1346   :link '(custom-manual "(gnus)Customizing Articles")
1347   :type gnus-article-treat-custom)
1348
1349 (defcustom gnus-treat-strip-multiple-blank-lines nil
1350   "Strip multiple blank lines.
1351 Valid values are nil, t, `head', `first', `last', an integer or a
1352 predicate.  See Info node `(gnus)Customizing Articles'."
1353   :group 'gnus-article-treat
1354   :link '(custom-manual "(gnus)Customizing Articles")
1355   :type gnus-article-treat-custom)
1356
1357 (defcustom gnus-treat-unfold-headers 'head
1358   "Unfold folded header lines.
1359 Valid values are nil, t, `head', `first', `last', an integer or a
1360 predicate.  See Info node `(gnus)Customizing Articles'."
1361   :version "22.1"
1362   :group 'gnus-article-treat
1363   :link '(custom-manual "(gnus)Customizing Articles")
1364   :type gnus-article-treat-custom)
1365
1366 (defcustom gnus-article-unfold-long-headers nil
1367   "If non-nil, allow unfolding headers even if the header is long.
1368 If it is a regexp, only long headers matching this regexp are unfolded.
1369 If it is t, all long headers are unfolded.
1370
1371 This variable has no effect if `gnus-treat-unfold-headers' is nil."
1372   :version "23.1" ;; No Gnus
1373   :group 'gnus-article-treat
1374   :type '(choice (const nil)
1375                  (const :tag "all" t)
1376                  (regexp)))
1377
1378 (defcustom gnus-treat-fold-headers nil
1379   "Fold headers.
1380 Valid values are nil, t, `head', `first', `last', an integer or a
1381 predicate.  See Info node `(gnus)Customizing Articles'."
1382   :version "22.1"
1383   :group 'gnus-article-treat
1384   :link '(custom-manual "(gnus)Customizing Articles")
1385   :type gnus-article-treat-custom)
1386
1387 (defcustom gnus-treat-fold-newsgroups 'head
1388   "Fold the Newsgroups and Followup-To headers.
1389 Valid values are nil, t, `head', `first', `last', an integer or a
1390 predicate.  See Info node `(gnus)Customizing Articles'."
1391   :version "22.1"
1392   :group 'gnus-article-treat
1393   :link '(custom-manual "(gnus)Customizing Articles")
1394   :type gnus-article-treat-custom)
1395
1396 (defcustom gnus-treat-overstrike t
1397   "Treat overstrike highlighting.
1398 Valid values are nil, t, `head', `first', `last', an integer or a
1399 predicate.  See Info node `(gnus)Customizing Articles'."
1400   :group 'gnus-article-treat
1401   :link '(custom-manual "(gnus)Customizing Articles")
1402   :type gnus-article-treat-custom)
1403 (put 'gnus-treat-overstrike 'highlight t)
1404
1405 (defcustom gnus-treat-ansi-sequences (if (locate-library "ansi-color") t)
1406   "Treat ANSI SGR control sequences.
1407 Valid values are nil, t, `head', `first', `last', an integer or a
1408 predicate.  See Info node `(gnus)Customizing Articles'."
1409   :group 'gnus-article-treat
1410   :link '(custom-manual "(gnus)Customizing Articles")
1411   :type gnus-article-treat-custom)
1412
1413 (make-obsolete-variable 'gnus-treat-display-xface
1414                         'gnus-treat-display-x-face "Emacs 22.1")
1415
1416 (defcustom gnus-treat-display-x-face
1417   (and (not noninteractive)
1418        (gnus-image-type-available-p 'xbm)
1419        (if (featurep 'xemacs)
1420            (featurep 'xface)
1421          (condition-case nil
1422              (and (string-match "^0x" (shell-command-to-string "uncompface"))
1423                   (executable-find "icontopbm"))
1424            ;; shell-command-to-string may signal an error, e.g. if
1425            ;; shell-file-name is not found.
1426            (error nil)))
1427        'head)
1428   "Display X-Face headers.
1429 Valid values are nil and `head'.
1430 See Info node `(gnus)Customizing Articles' and Info node
1431 `(gnus)X-Face' for details."
1432   :group 'gnus-article-treat
1433   :version "21.1"
1434   :link '(custom-manual "(gnus)Customizing Articles")
1435   :link '(custom-manual "(gnus)X-Face")
1436   :type gnus-article-treat-head-custom
1437   :set (lambda (symbol value)
1438          (set-default
1439           symbol
1440           (cond ((or (boundp symbol) (get symbol 'saved-value))
1441                  value)
1442                 ((boundp 'gnus-treat-display-xface)
1443                  (message "\
1444 ** gnus-treat-display-xface is an obsolete variable;\
1445  use gnus-treat-display-x-face instead")
1446                  (default-value 'gnus-treat-display-xface))
1447                 ((get 'gnus-treat-display-xface 'saved-value)
1448                  (message "\
1449 ** gnus-treat-display-xface is an obsolete variable;\
1450  use gnus-treat-display-x-face instead")
1451                  (eval (car (get 'gnus-treat-display-xface 'saved-value))))
1452                 (t
1453                  value)))))
1454 (put 'gnus-treat-display-x-face 'highlight t)
1455
1456 (defcustom gnus-treat-display-face
1457   (and (not noninteractive)
1458        (gnus-image-type-available-p 'png)
1459        'head)
1460   "Display Face headers.
1461 Valid values are nil, t, `head', `first', `last', an integer or a
1462 predicate.  See Info node `(gnus)Customizing Articles' and Info
1463 node `(gnus)Face' for details."
1464   :group 'gnus-article-treat
1465   :version "22.1"
1466   :link '(custom-manual "(gnus)Customizing Articles")
1467   :link '(custom-manual "(gnus)X-Face")
1468   :type gnus-article-treat-head-custom)
1469 (put 'gnus-treat-display-face 'highlight t)
1470
1471 (defcustom gnus-treat-display-smileys (gnus-image-type-available-p 'xpm)
1472   "Display smileys.
1473 Valid values are nil, t, `head', `first', `last', an integer or a
1474 predicate.  See Info node `(gnus)Customizing Articles' and Info
1475 node `(gnus)Smileys' for details."
1476   :group 'gnus-article-treat
1477   :version "21.1"
1478   :link '(custom-manual "(gnus)Customizing Articles")
1479   :link '(custom-manual "(gnus)Smileys")
1480   :type gnus-article-treat-custom)
1481 (put 'gnus-treat-display-smileys 'highlight t)
1482
1483 (defcustom gnus-treat-from-picon
1484   (if (and (gnus-image-type-available-p 'xpm)
1485            (gnus-picons-installed-p))
1486       'head nil)
1487   "Display picons in the From header.
1488 Valid values are nil, t, `head', `first', `last', an integer or a
1489 predicate.  See Info node `(gnus)Customizing Articles' and Info
1490 node `(gnus)Picons' for details."
1491   :version "22.1"
1492   :group 'gnus-article-treat
1493   :group 'gnus-picon
1494   :link '(custom-manual "(gnus)Customizing Articles")
1495   :link '(custom-manual "(gnus)Picons")
1496   :type gnus-article-treat-head-custom)
1497 (put 'gnus-treat-from-picon 'highlight t)
1498
1499 (defcustom gnus-treat-mail-picon
1500   (if (and (gnus-image-type-available-p 'xpm)
1501            (gnus-picons-installed-p))
1502       'head nil)
1503   "Display picons in To and Cc headers.
1504 Valid values are nil, t, `head', `first', `last', an integer or a
1505 predicate.  See Info node `(gnus)Customizing Articles' and Info
1506 node `(gnus)Picons' for details."
1507   :version "22.1"
1508   :group 'gnus-article-treat
1509   :group 'gnus-picon
1510   :link '(custom-manual "(gnus)Customizing Articles")
1511   :link '(custom-manual "(gnus)Picons")
1512   :type gnus-article-treat-head-custom)
1513 (put 'gnus-treat-mail-picon 'highlight t)
1514
1515 (defcustom gnus-treat-newsgroups-picon
1516   (if (and (gnus-image-type-available-p 'xpm)
1517            (gnus-picons-installed-p))
1518       'head nil)
1519   "Display picons in the Newsgroups and Followup-To headers.
1520 Valid values are nil, t, `head', `first', `last', an integer or a
1521 predicate.  See Info node `(gnus)Customizing Articles' and Info
1522 node `(gnus)Picons' for details."
1523   :version "22.1"
1524   :group 'gnus-article-treat
1525   :group 'gnus-picon
1526   :link '(custom-manual "(gnus)Customizing Articles")
1527   :link '(custom-manual "(gnus)Picons")
1528   :type gnus-article-treat-head-custom)
1529 (put 'gnus-treat-newsgroups-picon 'highlight t)
1530
1531 (defcustom gnus-treat-from-gravatar nil
1532   "Display gravatars in the From header.
1533 Valid values are nil, t, `head', `first', `last', an integer or a
1534 predicate.  See Info node `(gnus)Customizing Articles' and Info
1535 node `(gnus)Gravatars' for details."
1536   :version "24.1"
1537   :group 'gnus-article-treat
1538   :group 'gnus-gravatar
1539   :link '(custom-manual "(gnus)Customizing Articles")
1540   :link '(custom-manual "(gnus)Gravatars")
1541   :type gnus-article-treat-head-custom)
1542 (put 'gnus-treat-from-gravatar 'highlight t)
1543
1544 (defcustom gnus-treat-mail-gravatar nil
1545   "Display gravatars in To and Cc headers.
1546 Valid values are nil, t, `head', `first', `last', an integer or a
1547 predicate.  See Info node `(gnus)Customizing Articles' and Info
1548 node `(gnus)Gravatars' for details."
1549   :version "24.1"
1550   :group 'gnus-article-treat
1551   :group 'gnus-gravatar
1552   :link '(custom-manual "(gnus)Customizing Articles")
1553   :link '(custom-manual "(gnus)Gravatars")
1554   :type gnus-article-treat-head-custom)
1555 (put 'gnus-treat-mail-gravatar 'highlight t)
1556
1557 (defcustom gnus-treat-body-boundary
1558   (if (or gnus-treat-newsgroups-picon
1559           gnus-treat-mail-picon
1560           gnus-treat-from-picon
1561           gnus-treat-from-gravatar
1562           gnus-treat-mail-gravatar)
1563       ;; If there's much decoration, the user might prefer a boundary.
1564       'head
1565     nil)
1566   "Draw a boundary at the end of the headers.
1567 Valid values are nil and `head'.
1568 See Info node `(gnus)Customizing Articles' for details."
1569   :version "22.1"
1570   :group 'gnus-article-treat
1571   :link '(custom-manual "(gnus)Customizing Articles")
1572   :type gnus-article-treat-head-custom)
1573
1574 (defcustom gnus-treat-capitalize-sentences nil
1575   "Capitalize sentence-starting words.
1576 Valid values are nil, t, `head', `first', `last', an integer or a
1577 predicate.  See Info node `(gnus)Customizing Articles'."
1578   :version "21.1"
1579   :group 'gnus-article-treat
1580   :link '(custom-manual "(gnus)Customizing Articles")
1581   :type gnus-article-treat-custom)
1582
1583 (defcustom gnus-treat-wash-html nil
1584   "Format as HTML.
1585 Valid values are nil, t, `head', `first', `last', an integer or a
1586 predicate.  See Info node `(gnus)Customizing Articles'."
1587   :version "22.1"
1588   :group 'gnus-article-treat
1589   :link '(custom-manual "(gnus)Customizing Articles")
1590   :type gnus-article-treat-custom)
1591
1592 (defcustom gnus-treat-fill-long-lines '(typep "text/plain")
1593   "Fill long lines.
1594 Valid values are nil, t, `head', `first', `last', an integer or a
1595 predicate.  See Info node `(gnus)Customizing Articles'."
1596   :version "24.1"
1597   :group 'gnus-article-treat
1598   :link '(custom-manual "(gnus)Customizing Articles")
1599   :type gnus-article-treat-custom)
1600
1601 (defcustom gnus-treat-x-pgp-sig nil
1602   "Verify X-PGP-Sig.
1603 To automatically treat X-PGP-Sig, set it to head.
1604 Valid values are nil, t, `head', `first', `last', an integer or a
1605 predicate.  See Info node `(gnus)Customizing Articles'."
1606   :version "22.1"
1607   :group 'gnus-article-treat
1608   :group 'mime-security
1609   :link '(custom-manual "(gnus)Customizing Articles")
1610   :type gnus-article-treat-custom)
1611
1612 (defvar gnus-article-encrypt-protocol-alist
1613   '(("PGP" . mml2015-self-encrypt)))
1614
1615 ;; Set to nil if more than one protocol added to
1616 ;; gnus-article-encrypt-protocol-alist.
1617 (defcustom gnus-article-encrypt-protocol "PGP"
1618   "The protocol used for encrypt articles.
1619 It is a string, such as \"PGP\". If nil, ask user."
1620   :version "22.1"
1621   :type 'string
1622   :group 'mime-security)
1623
1624 (defcustom gnus-use-idna (and (condition-case nil (require 'idna) (file-error))
1625                               (mm-coding-system-p 'utf-8)
1626                               (executable-find idna-program))
1627   "Whether IDNA decoding of headers is used when viewing messages.
1628 This requires GNU Libidn, and by default only enabled if it is found."
1629   :version "22.1"
1630   :group 'gnus-article-headers
1631   :type 'boolean)
1632
1633 (defcustom gnus-article-over-scroll nil
1634   "If non-nil, allow scrolling the article buffer even when there no more text."
1635   :version "22.1"
1636   :group 'gnus-article
1637   :type 'boolean)
1638
1639 (defcustom gnus-inhibit-images nil
1640   "Non-nil means inhibit displaying of images inline in the article body."
1641   :version "24.1"
1642   :group 'gnus-article
1643   :type 'boolean)
1644
1645 (defcustom gnus-blocked-images 'gnus-block-private-groups
1646   "Images that have URLs matching this regexp will be blocked.
1647 This can also be a function to be evaluated.  If so, it will be
1648 called with the group name as the parameter, and should return a
1649 regexp."
1650   :version "24.1"
1651   :group 'gnus-art
1652   :type '(choice regexp function))
1653
1654 ;;; Internal variables
1655
1656 (defvar gnus-english-month-names
1657   '("January" "February" "March" "April" "May" "June" "July" "August"
1658     "September" "October" "November" "December"))
1659
1660 (defvar article-goto-body-goes-to-point-min-p nil)
1661 (defvar gnus-article-wash-types nil)
1662 (defvar gnus-article-emphasis-alist nil)
1663 (defvar gnus-article-image-alist nil)
1664
1665 (defvar gnus-article-mime-handle-alist-1 nil)
1666 (defvar gnus-treatment-function-alist
1667   '((gnus-treat-strip-cr gnus-article-remove-cr)
1668     (gnus-treat-x-pgp-sig gnus-article-verify-x-pgp-sig)
1669     (gnus-treat-strip-banner gnus-article-strip-banner)
1670     (gnus-treat-strip-headers-in-body gnus-article-strip-headers-in-body)
1671     (gnus-treat-highlight-signature gnus-article-highlight-signature)
1672     (gnus-treat-buttonize gnus-article-add-buttons)
1673     (gnus-treat-fill-article gnus-article-fill-cited-article)
1674     (gnus-treat-fill-long-lines gnus-article-fill-cited-long-lines)
1675     (gnus-treat-unsplit-urls gnus-article-unsplit-urls)
1676     (gnus-treat-display-x-face gnus-article-display-x-face)
1677     (gnus-treat-display-face gnus-article-display-face)
1678     (gnus-treat-hide-headers gnus-article-maybe-hide-headers)
1679     (gnus-treat-hide-boring-headers gnus-article-hide-boring-headers)
1680     (gnus-treat-hide-signature gnus-article-hide-signature)
1681     (gnus-treat-strip-list-identifiers gnus-article-hide-list-identifiers)
1682     (gnus-treat-leading-whitespace gnus-article-remove-leading-whitespace)
1683     (gnus-treat-from-picon gnus-treat-from-picon)
1684     (gnus-treat-mail-picon gnus-treat-mail-picon)
1685     (gnus-treat-newsgroups-picon gnus-treat-newsgroups-picon)
1686     (gnus-treat-strip-pem gnus-article-hide-pem)
1687     (gnus-treat-date gnus-article-treat-date)
1688     (gnus-treat-from-gravatar gnus-treat-from-gravatar)
1689     (gnus-treat-mail-gravatar gnus-treat-mail-gravatar)
1690     (gnus-treat-highlight-headers gnus-article-highlight-headers)
1691     (gnus-treat-highlight-signature gnus-article-highlight-signature)
1692     (gnus-treat-strip-trailing-blank-lines
1693      gnus-article-remove-trailing-blank-lines)
1694     (gnus-treat-strip-leading-blank-lines
1695      gnus-article-strip-leading-blank-lines)
1696     (gnus-treat-strip-multiple-blank-lines
1697      gnus-article-strip-multiple-blank-lines)
1698     (gnus-treat-overstrike gnus-article-treat-overstrike)
1699     (gnus-treat-ansi-sequences gnus-article-treat-ansi-sequences)
1700     (gnus-treat-unfold-headers gnus-article-treat-unfold-headers)
1701     (gnus-treat-fold-newsgroups gnus-article-treat-fold-newsgroups)
1702     (gnus-treat-fold-headers gnus-article-treat-fold-headers)
1703     (gnus-treat-buttonize-head gnus-article-add-buttons-to-head)
1704     (gnus-treat-display-smileys gnus-treat-smiley)
1705     (gnus-treat-capitalize-sentences gnus-article-capitalize-sentences)
1706     (gnus-treat-wash-html gnus-article-wash-html)
1707     (gnus-treat-emphasize gnus-article-emphasize)
1708     (gnus-treat-hide-citation gnus-article-hide-citation)
1709     (gnus-treat-hide-citation-maybe gnus-article-hide-citation-maybe)
1710     (gnus-treat-highlight-citation gnus-article-highlight-citation)
1711     (gnus-treat-body-boundary gnus-article-treat-body-boundary)))
1712
1713 (defvar gnus-article-mime-handle-alist nil)
1714 (defvar article-lapsed-timer nil)
1715 (defvar gnus-article-current-summary nil)
1716
1717 (defvar gnus-article-mode-syntax-table
1718   (let ((table (copy-syntax-table text-mode-syntax-table)))
1719     ;; This causes the citation match run O(2^n).
1720     ;; (modify-syntax-entry ?- "w" table)
1721     (modify-syntax-entry ?> ")<" table)
1722     (modify-syntax-entry ?< "(>" table)
1723     ;; make M-. in article buffers work for `foo' strings
1724     (modify-syntax-entry ?' " " table)
1725     (modify-syntax-entry ?` " " table)
1726     table)
1727   "Syntax table used in article mode buffers.
1728 Initialized from `text-mode-syntax-table.")
1729
1730 (defvar gnus-save-article-buffer nil)
1731
1732 (defvar gnus-number-of-articles-to-be-saved nil)
1733
1734 (defvar gnus-inhibit-hiding nil)
1735
1736 (defvar gnus-article-edit-mode nil)
1737
1738 ;;; Macros for dealing with the article buffer.
1739
1740 (defmacro gnus-with-article-headers (&rest forms)
1741   `(with-current-buffer gnus-article-buffer
1742      (save-restriction
1743        (let ((inhibit-read-only t)
1744              (inhibit-point-motion-hooks t)
1745              (case-fold-search t))
1746          (article-narrow-to-head)
1747          ,@forms))))
1748
1749 (put 'gnus-with-article-headers 'lisp-indent-function 0)
1750 (put 'gnus-with-article-headers 'edebug-form-spec '(body))
1751
1752 (defmacro gnus-with-article-buffer (&rest forms)
1753   `(when (buffer-live-p (get-buffer gnus-article-buffer))
1754      (with-current-buffer gnus-article-buffer
1755        (let ((inhibit-read-only t))
1756          ,@forms))))
1757
1758 (put 'gnus-with-article-buffer 'lisp-indent-function 0)
1759 (put 'gnus-with-article-buffer 'edebug-form-spec '(body))
1760
1761 (defun gnus-article-goto-header (header)
1762   "Go to HEADER, which is a regular expression."
1763   (re-search-forward (concat "^\\(" header "\\):") nil t))
1764
1765 (defsubst gnus-article-hide-text (b e props)
1766   "Set text PROPS on the B to E region, extending `intangible' 1 past B."
1767   (gnus-add-text-properties-when 'article-type nil b e props)
1768   (when (memq 'intangible props)
1769     (put-text-property
1770      (max (1- b) (point-min))
1771      b 'intangible (cddr (memq 'intangible props)))))
1772
1773 (defsubst gnus-article-unhide-text (b e)
1774   "Remove hidden text properties from region between B and E."
1775   (remove-text-properties b e gnus-hidden-properties)
1776   (when (memq 'intangible gnus-hidden-properties)
1777     (put-text-property (max (1- b) (point-min))
1778                        b 'intangible nil)))
1779
1780 (defun gnus-article-hide-text-type (b e type)
1781   "Hide text of TYPE between B and E."
1782   (gnus-add-wash-type type)
1783   (gnus-article-hide-text
1784    b e (cons 'article-type (cons type gnus-hidden-properties))))
1785
1786 (defun gnus-article-unhide-text-type (b e type)
1787   "Unhide text of TYPE between B and E."
1788   (gnus-delete-wash-type type)
1789   (remove-text-properties
1790    b e (cons 'article-type (cons type gnus-hidden-properties)))
1791   (when (memq 'intangible gnus-hidden-properties)
1792     (put-text-property (max (1- b) (point-min))
1793                        b 'intangible nil)))
1794
1795 (defun gnus-article-delete-text-of-type (type)
1796   "Delete text of TYPE in the current buffer."
1797   (save-excursion
1798     (let ((b (point-min)))
1799       (if (eq type 'multipart)
1800           ;; Remove MIME buttons associated with multipart/alternative parts.
1801           (progn
1802             (goto-char b)
1803             (while (if (get-text-property (point) 'gnus-part)
1804                        (setq b (point))
1805                      (when (setq b (next-single-property-change (point)
1806                                                                 'gnus-part))
1807                        (goto-char b)
1808                        t))
1809               (end-of-line)
1810               (skip-chars-forward "\n")
1811               (when (eq (get-text-property b 'article-type) 'multipart)
1812                 (delete-region b (point)))))
1813         (while (setq b (text-property-any b (point-max) 'article-type type))
1814           (delete-region
1815            b (or (text-property-not-all b (point-max) 'article-type type)
1816                  (point-max))))))))
1817
1818 (defun gnus-article-delete-invisible-text ()
1819   "Delete all invisible text in the current buffer."
1820   (save-excursion
1821     (let ((b (point-min)))
1822       (while (setq b (text-property-any b (point-max) 'invisible t))
1823         (delete-region
1824          b (or (text-property-not-all b (point-max) 'invisible t)
1825                (point-max)))))))
1826
1827 (defsubst gnus-article-header-rank ()
1828   "Give the rank of the string HEADER as given by `gnus-sorted-header-list'."
1829   (let ((list gnus-sorted-header-list)
1830         (i 1))
1831     (while list
1832       (if (looking-at (car list))
1833           (setq list nil)
1834         (setq list (cdr list))
1835         (incf i)))
1836       i))
1837
1838 (defun article-hide-headers (&optional arg delete)
1839   "Hide unwanted headers and possibly sort them as well."
1840   (interactive)
1841   ;; This function might be inhibited.
1842   (unless gnus-inhibit-hiding
1843     (let ((inhibit-read-only t)
1844           (case-fold-search t)
1845           (max (1+ (length gnus-sorted-header-list)))
1846           (inhibit-point-motion-hooks t)
1847           (cur (current-buffer))
1848           ignored visible beg)
1849       (save-excursion
1850         ;; `gnus-ignored-headers' and `gnus-visible-headers' may be
1851         ;; group parameters, so we should go to the summary buffer.
1852         (when (prog1
1853                   (condition-case nil
1854                       (progn (set-buffer gnus-summary-buffer) t)
1855                     (error nil))
1856                 (setq ignored (when (not gnus-visible-headers)
1857                                 (cond ((stringp gnus-ignored-headers)
1858                                        gnus-ignored-headers)
1859                                       ((listp gnus-ignored-headers)
1860                                        (mapconcat 'identity
1861                                                   gnus-ignored-headers
1862                                                   "\\|"))))
1863                       visible (cond ((stringp gnus-visible-headers)
1864                                      gnus-visible-headers)
1865                                     ((and gnus-visible-headers
1866                                           (listp gnus-visible-headers))
1867                                      (mapconcat 'identity
1868                                                 gnus-visible-headers
1869                                                 "\\|")))))
1870           (set-buffer cur))
1871         (save-restriction
1872           ;; First we narrow to just the headers.
1873           (article-narrow-to-head)
1874           ;; Hide any "From " lines at the beginning of (mail) articles.
1875           (while (looking-at "From ")
1876             (forward-line 1))
1877           (unless (bobp)
1878             (delete-region (point-min) (point)))
1879           ;; Then treat the rest of the header lines.
1880           ;; Then we use the two regular expressions
1881           ;; `gnus-ignored-headers' and `gnus-visible-headers' to
1882           ;; select which header lines is to remain visible in the
1883           ;; article buffer.
1884           (while (re-search-forward "^[^ \t:]*:" nil t)
1885             (beginning-of-line)
1886             ;; Mark the rank of the header.
1887             (put-text-property
1888              (point) (1+ (point)) 'message-rank
1889              (if (or (and visible (looking-at visible))
1890                      (and ignored
1891                           (not (looking-at ignored))))
1892                  (gnus-article-header-rank)
1893                (+ 2 max)))
1894             (forward-line 1))
1895           (message-sort-headers-1)
1896           (when (setq beg (text-property-any
1897                            (point-min) (point-max) 'message-rank (+ 2 max)))
1898             ;; We delete the unwanted headers.
1899             (gnus-add-wash-type 'headers)
1900             (add-text-properties (point-min) (+ 5 (point-min))
1901                                  '(article-type headers dummy-invisible t))
1902             (delete-region beg (point-max))))))))
1903
1904 (defun article-hide-boring-headers (&optional arg)
1905   "Toggle hiding of headers that aren't very interesting.
1906 If given a negative prefix, always show; if given a positive prefix,
1907 always hide."
1908   (interactive (gnus-article-hidden-arg))
1909   (when (and (not (gnus-article-check-hidden-text 'boring-headers arg))
1910              (not gnus-show-all-headers))
1911     (save-excursion
1912       (save-restriction
1913         (let ((inhibit-read-only t)
1914               (inhibit-point-motion-hooks t))
1915           (article-narrow-to-head)
1916           (dolist (elem gnus-boring-article-headers)
1917             (goto-char (point-min))
1918             (cond
1919              ;; Hide empty headers.
1920              ((eq elem 'empty)
1921               (while (re-search-forward "^[^: \t]+:[ \t]*\n[^ \t]" nil t)
1922                 (forward-line -1)
1923                 (gnus-article-hide-text-type
1924                  (point-at-bol)
1925                  (progn
1926                    (end-of-line)
1927                    (if (re-search-forward "^[^ \t]" nil t)
1928                        (match-beginning 0)
1929                      (point-max)))
1930                  'boring-headers)))
1931              ;; Hide boring Newsgroups header.
1932              ((eq elem 'newsgroups)
1933               (when (gnus-string-equal
1934                      (gnus-fetch-field "newsgroups")
1935                      (gnus-group-real-name
1936                       (if (boundp 'gnus-newsgroup-name)
1937                           gnus-newsgroup-name
1938                         "")))
1939                 (gnus-article-hide-header "newsgroups")))
1940              ((eq elem 'to-address)
1941               (let ((to (message-fetch-field "to"))
1942                     (to-address
1943                      (gnus-parameter-to-address
1944                       (if (boundp 'gnus-newsgroup-name)
1945                           gnus-newsgroup-name ""))))
1946                 (when (and to to-address
1947                            (ignore-errors
1948                              (gnus-string-equal
1949                               ;; only one address in To
1950                               (nth 1 (mail-extract-address-components to))
1951                               to-address)))
1952                   (gnus-article-hide-header "to"))))
1953              ((eq elem 'to-list)
1954               (let ((to (message-fetch-field "to"))
1955                     (to-list
1956                      (gnus-parameter-to-list
1957                       (if (boundp 'gnus-newsgroup-name)
1958                           gnus-newsgroup-name ""))))
1959                 (when (and to to-list
1960                            (ignore-errors
1961                              (gnus-string-equal
1962                               ;; only one address in To
1963                               (nth 1 (mail-extract-address-components to))
1964                               to-list)))
1965                   (gnus-article-hide-header "to"))))
1966              ((eq elem 'cc-list)
1967               (let ((cc (message-fetch-field "cc"))
1968                     (to-list
1969                      (gnus-parameter-to-list
1970                       (if (boundp 'gnus-newsgroup-name)
1971                           gnus-newsgroup-name ""))))
1972                 (when (and cc to-list
1973                            (ignore-errors
1974                              (gnus-string-equal
1975                               ;; only one address in CC
1976                               (nth 1 (mail-extract-address-components cc))
1977                               to-list)))
1978                   (gnus-article-hide-header "cc"))))
1979              ((eq elem 'followup-to)
1980               (when (gnus-string-equal
1981                      (message-fetch-field "followup-to")
1982                      (message-fetch-field "newsgroups"))
1983                 (gnus-article-hide-header "followup-to")))
1984              ((eq elem 'reply-to)
1985               (if (gnus-group-find-parameter
1986                    gnus-newsgroup-name 'broken-reply-to)
1987                   (gnus-article-hide-header "reply-to")
1988                 (let ((from (message-fetch-field "from"))
1989                       (reply-to (message-fetch-field "reply-to")))
1990                   (when
1991                       (and
1992                        from reply-to
1993                        (ignore-errors
1994                          (equal
1995                           (sort (mapcar
1996                                  (lambda (x) (downcase (cadr x)))
1997                                  (mail-extract-address-components from t))
1998                                 'string<)
1999                           (sort (mapcar
2000                                  (lambda (x) (downcase (cadr x)))
2001                                  (mail-extract-address-components reply-to t))
2002                                 'string<))))
2003                     (gnus-article-hide-header "reply-to")))))
2004              ((eq elem 'date)
2005               (let ((date (with-current-buffer gnus-original-article-buffer
2006                             ;; If date in `gnus-article-buffer' is localized
2007                             ;; (`gnus-treat-date-user-defined'),
2008                             ;; `days-between' might fail.
2009                             (message-fetch-field "date"))))
2010                 (when (and date
2011                            (< (days-between (current-time-string) date)
2012                               4))
2013                   (gnus-article-hide-header "date"))))
2014              ((eq elem 'long-to)
2015               (let ((to (message-fetch-field "to"))
2016                     (cc (message-fetch-field "cc")))
2017                 (when (> (length to) 1024)
2018                   (gnus-article-hide-header "to"))
2019                 (when (> (length cc) 1024)
2020                   (gnus-article-hide-header "cc"))))
2021              ((eq elem 'many-to)
2022               (let ((to-count 0)
2023                     (cc-count 0))
2024                 (goto-char (point-min))
2025                 (while (re-search-forward "^to:" nil t)
2026                   (setq to-count (1+ to-count)))
2027                 (when (> to-count 1)
2028                   (while (> to-count 0)
2029                     (goto-char (point-min))
2030                     (save-restriction
2031                       (re-search-forward "^to:" nil nil to-count)
2032                       (forward-line -1)
2033                       (narrow-to-region (point) (point-max))
2034                       (gnus-article-hide-header "to"))
2035                     (setq to-count (1- to-count))))
2036                 (goto-char (point-min))
2037                 (while (re-search-forward "^cc:" nil t)
2038                   (setq cc-count (1+ cc-count)))
2039                 (when (> cc-count 1)
2040                   (while (> cc-count 0)
2041                     (goto-char (point-min))
2042                     (save-restriction
2043                       (re-search-forward "^cc:" nil nil cc-count)
2044                       (forward-line -1)
2045                       (narrow-to-region (point) (point-max))
2046                       (gnus-article-hide-header "cc"))
2047                     (setq cc-count (1- cc-count)))))))))))))
2048
2049 (defun gnus-article-hide-header (header)
2050   (save-excursion
2051     (goto-char (point-min))
2052     (when (re-search-forward (concat "^" header ":") nil t)
2053       (gnus-article-hide-text-type
2054        (point-at-bol)
2055        (progn
2056          (end-of-line)
2057          (if (re-search-forward "^[^ \t]" nil t)
2058              (match-beginning 0)
2059            (point-max)))
2060        'boring-headers))))
2061
2062 (defvar gnus-article-normalized-header-length 40
2063   "Length of normalized headers.")
2064
2065 (defun article-normalize-headers ()
2066   "Make all header lines 40 characters long."
2067   (interactive)
2068   (let ((inhibit-read-only t)
2069         column)
2070     (save-excursion
2071       (save-restriction
2072         (article-narrow-to-head)
2073         (while (not (eobp))
2074           (cond
2075            ((< (setq column (- (point-at-eol) (point)))
2076                gnus-article-normalized-header-length)
2077             (end-of-line)
2078             (insert (make-string
2079                      (- gnus-article-normalized-header-length column)
2080                      ? )))
2081            ((> column gnus-article-normalized-header-length)
2082             (gnus-put-text-property
2083              (progn
2084                (forward-char gnus-article-normalized-header-length)
2085                (point))
2086              (point-at-eol)
2087              'invisible t))
2088            (t
2089             ;; Do nothing.
2090             ))
2091           (forward-line 1))))))
2092
2093 (defun article-treat-dumbquotes ()
2094   "Translate M****s*** sm*rtq**t*s and other symbols into proper text.
2095 Note that this function guesses whether a character is a sm*rtq**t* or
2096 not, so it should only be used interactively.
2097
2098 Sm*rtq**t*s are M****s***'s unilateral extension to the
2099 iso-8859-1 character map in an attempt to provide more quoting
2100 characters.  If you see something like \\222 or \\264 where
2101 you're expecting some kind of apostrophe or quotation mark, then
2102 try this wash."
2103   (interactive)
2104   (article-translate-strings gnus-article-dumbquotes-map))
2105
2106 (defvar org-entities)
2107
2108 (defun article-treat-non-ascii ()
2109   "Translate many Unicode characters into their ASCII equivalents."
2110   (interactive)
2111   (require 'org-entities)
2112   (let ((table (make-char-table (if (featurep 'xemacs) 'generic))))
2113     (dolist (elem org-entities)
2114       (when (and (listp elem)
2115                  (= (length (nth 6 elem)) 1))
2116         (if (featurep 'xemacs)
2117             (put-char-table (aref (nth 6 elem) 0) (nth 4 elem) table)
2118           (set-char-table-range table (aref (nth 6 elem) 0) (nth 4 elem)))))
2119     (save-excursion
2120       (when (article-goto-body)
2121         (let ((inhibit-read-only t)
2122               replace props)
2123           (while (not (eobp))
2124             (if (not (setq replace (if (featurep 'xemacs)
2125                                        (get-char-table (following-char) table)
2126                                      (aref table (following-char)))))
2127                 (forward-char 1)
2128               (if (prog1
2129                       (setq props (text-properties-at (point)))
2130                     (delete-char 1))
2131                   (add-text-properties (point) (progn (insert replace) (point))
2132                                        props)
2133                 (insert replace)))))))))
2134
2135 (defun article-translate-strings (map)
2136   "Translate all string in the body of the article according to MAP.
2137 MAP is an alist where the elements are on the form (\"from\" \"to\")."
2138   (save-excursion
2139     (when (article-goto-body)
2140       (let ((inhibit-read-only t))
2141         (dolist (elem map)
2142           (let ((from (car elem))
2143                 (to (cadr elem)))
2144             (save-excursion
2145               (if (stringp from)
2146                   (while (search-forward from nil t)
2147                     (replace-match to))
2148                 (while (not (eobp))
2149                   (if (eq (following-char) from)
2150                       (progn
2151                         (delete-char 1)
2152                         (insert to))
2153                     (forward-char 1)))))))))))
2154
2155 (defun article-treat-overstrike ()
2156   "Translate overstrikes into bold text."
2157   (interactive)
2158   (save-excursion
2159     (when (article-goto-body)
2160       (let ((inhibit-read-only t))
2161         (while (search-forward "\b" nil t)
2162           (let ((next (char-after))
2163                 (previous (char-after (- (point) 2))))
2164             ;; We do the boldification/underlining by hiding the
2165             ;; overstrikes and putting the proper text property
2166             ;; on the letters.
2167             (cond
2168              ((eq next previous)
2169               (gnus-article-hide-text-type (- (point) 2) (point) 'overstrike)
2170               (put-text-property (point) (1+ (point)) 'face 'bold))
2171              ((eq next ?_)
2172               (gnus-article-hide-text-type
2173                (1- (point)) (1+ (point)) 'overstrike)
2174               (put-text-property
2175                (- (point) 2) (1- (point)) 'face 'underline))
2176              ((eq previous ?_)
2177               (gnus-article-hide-text-type (- (point) 2) (point) 'overstrike)
2178               (put-text-property
2179                (point) (1+ (point)) 'face 'underline)))))))))
2180
2181 (defun article-treat-ansi-sequences ()
2182   "Translate ANSI SGR control sequences into overlays or extents."
2183   (interactive)
2184   (save-excursion
2185     (when (article-goto-body)
2186       (let ((inhibit-read-only t))
2187         (ansi-color-apply-on-region (point) (point-max))))))
2188
2189 (defun gnus-article-treat-unfold-headers ()
2190   "Unfold folded message headers.
2191 Only the headers that fit into the current window width will be
2192 unfolded."
2193   (interactive)
2194   (gnus-with-article-headers
2195     (let (length)
2196       (while (not (eobp))
2197         (save-restriction
2198           (mail-header-narrow-to-field)
2199           (let* ((header (buffer-string))
2200                  (unfoldable
2201                   (or (equal gnus-article-unfold-long-headers t)
2202                       (and (stringp gnus-article-unfold-long-headers)
2203                            (string-match gnus-article-unfold-long-headers
2204                                          header)))))
2205             (with-temp-buffer
2206               (insert header)
2207               (goto-char (point-min))
2208               (while (re-search-forward "\n[\t ]" nil t)
2209                 (replace-match " " t t)))
2210             (setq length (- (point-max) (point-min) 1))
2211             (when (or unfoldable
2212                       (< length (window-width)))
2213               (while (re-search-forward "\n[\t ]" nil t)
2214                 (replace-match " " t t))))
2215           (goto-char (point-max)))))))
2216
2217 (defun gnus-article-treat-fold-headers ()
2218   "Fold message headers."
2219   (interactive)
2220   (gnus-with-article-headers
2221     (while (not (eobp))
2222       (save-restriction
2223         (mail-header-narrow-to-field)
2224         (mail-header-fold-field)
2225         (goto-char (point-max))))))
2226
2227 (defun gnus-treat-smiley ()
2228   "Toggle display of textual emoticons (\"smileys\") as small graphical icons."
2229   (interactive)
2230   (gnus-with-article-buffer
2231     (if (memq 'smiley gnus-article-wash-types)
2232         (gnus-delete-images 'smiley)
2233       (article-goto-body)
2234       (let ((images (smiley-region (point) (point-max))))
2235         (when images
2236           (gnus-add-wash-type 'smiley)
2237           (dolist (image images)
2238             (gnus-add-image 'smiley image)))))))
2239
2240 (defun gnus-article-remove-images ()
2241   "Remove all images from the article buffer."
2242   (interactive)
2243   (gnus-with-article-buffer
2244     (save-restriction
2245       (widen)
2246       (dolist (elem gnus-article-image-alist)
2247         (gnus-delete-images (car elem))))))
2248
2249 (autoload 'w3m-toggle-inline-images "w3m")
2250
2251 (defun gnus-article-show-images ()
2252   "Show any images that are in the HTML-rendered article buffer.
2253 This only works if the article in question is HTML."
2254   (interactive)
2255   (gnus-with-article-buffer
2256     (save-restriction
2257       (widen)
2258       (if (eq mm-text-html-renderer 'w3m)
2259           (let ((mm-inline-text-html-with-images nil))
2260             (w3m-toggle-inline-images))
2261         (dolist (region (gnus-find-text-property-region (point-min) (point-max)
2262                                                         'image-displayer))
2263           (destructuring-bind (start end function) region
2264             (funcall function (get-text-property start 'image-url)
2265                      start end)))))))
2266
2267 (defun gnus-article-treat-fold-newsgroups ()
2268   "Unfold folded message headers.
2269 Only the headers that fit into the current window width will be
2270 unfolded."
2271   (interactive)
2272   (gnus-with-article-headers
2273     (while (gnus-article-goto-header "newsgroups\\|followup-to")
2274       (save-restriction
2275         (mail-header-narrow-to-field)
2276         (while (re-search-forward ", *" nil t)
2277           (replace-match ", " t t))
2278         (mail-header-fold-field)
2279         (goto-char (point-max))))))
2280
2281 (defcustom gnus-article-truncate-lines (default-value 'truncate-lines)
2282   "Value of `truncate-lines' in Gnus Article buffer.
2283 Valid values are nil, t, `head', `first', `last', an integer or a
2284 predicate.  See Info node `(gnus)Customizing Articles'."
2285   :version "23.1" ;; No Gnus
2286   :group 'gnus-article
2287   ;; :link '(custom-manual "(gnus)Customizing Articles")
2288   :type 'boolean)
2289
2290 (defun gnus-article-toggle-truncate-lines (&optional arg)
2291   "Toggle whether to fold or truncate long lines in article the buffer.
2292 If ARG is non-nil and not a number, toggle
2293 `gnus-article-truncate-lines' too.  If ARG is a number, truncate
2294 long lines if and only if arg is positive."
2295   (interactive "P")
2296   (cond
2297    ((and (numberp arg) (> arg 0))
2298     (setq gnus-article-truncate-lines t))
2299    ((numberp arg)
2300     (setq gnus-article-truncate-lines nil))
2301    (arg
2302     (setq gnus-article-truncate-lines
2303           (not gnus-article-truncate-lines))))
2304   (gnus-with-article-buffer
2305     (cond
2306      ((and (numberp arg) (> arg 0))
2307       (setq truncate-lines nil))
2308      ((numberp arg)
2309       (setq truncate-lines t)))
2310     ;; In versions of Emacs 22 (CVS) before 2006-05-26,
2311     ;; `toggle-truncate-lines' needs an argument.
2312     (toggle-truncate-lines)))
2313
2314 (defun gnus-article-treat-body-boundary ()
2315   "Place a boundary line at the end of the headers."
2316   (interactive)
2317   (when (and gnus-body-boundary-delimiter
2318              (> (length gnus-body-boundary-delimiter) 0))
2319     (gnus-with-article-headers
2320       (goto-char (point-max))
2321       (let ((start (point)))
2322         (insert "X-Boundary: ")
2323         (gnus-add-text-properties start (point) '(invisible t intangible t))
2324        (insert (let (str (max (window-width)))
2325                  (if (featurep 'xemacs)
2326                      (setq max (1- max)))
2327                  (while (>= max (length str))
2328                     (setq str (concat str gnus-body-boundary-delimiter)))
2329                  (substring str 0 max))
2330                 "\n")
2331         (gnus-put-text-property start (point) 'gnus-decoration 'header)))))
2332
2333 (defun article-fill-long-lines ()
2334   "Fill lines that are wider than the window width."
2335   (interactive)
2336   (save-excursion
2337     (let ((inhibit-read-only t)
2338           (width (window-width (get-buffer-window (current-buffer)))))
2339       (save-restriction
2340         (article-goto-body)
2341         (let ((adaptive-fill-mode nil)) ;Why?  -sm
2342           (while (not (eobp))
2343             (end-of-line)
2344             (when (>= (current-column) (min fill-column width))
2345               (narrow-to-region (min (1+ (point)) (point-max))
2346                                 (point-at-bol))
2347               (let ((goback (point-marker)))
2348                 (fill-paragraph nil)
2349                 (goto-char (marker-position goback)))
2350               (widen))
2351             (forward-line 1)))))))
2352
2353 (defun article-capitalize-sentences ()
2354   "Capitalize the first word in each sentence."
2355   (interactive)
2356   (save-excursion
2357     (let ((inhibit-read-only t)
2358           (paragraph-start "^[\n\^L]"))
2359       (article-goto-body)
2360       (while (not (eobp))
2361         (capitalize-word 1)
2362         (forward-sentence)))))
2363
2364 (defun article-remove-cr ()
2365   "Remove trailing CRs and then translate remaining CRs into LFs."
2366   (interactive)
2367   (save-excursion
2368     (let ((inhibit-read-only t))
2369       (goto-char (point-min))
2370       (while (re-search-forward "\r+$" nil t)
2371         (replace-match "" t t))
2372       (goto-char (point-min))
2373       (while (search-forward "\r" nil t)
2374         (replace-match "\n" t t)))))
2375
2376 (defun article-remove-trailing-blank-lines ()
2377   "Remove all trailing blank lines from the article."
2378   (interactive)
2379   (save-excursion
2380     (let ((inhibit-read-only t))
2381       (goto-char (point-max))
2382       (delete-region
2383        (point)
2384        (progn
2385          (while (and (not (bobp))
2386                      (looking-at "^[ \t]*$")
2387                      (not (gnus-annotation-in-region-p
2388                            (point) (point-at-eol))))
2389            (forward-line -1))
2390          (forward-line 1)
2391          (point))))))
2392
2393 (defvar gnus-face-properties-alist)
2394
2395 (defun article-display-face (&optional force)
2396   "Display any Face headers in the header."
2397   (interactive (list 'force))
2398   (let ((wash-face-p buffer-read-only))
2399     (gnus-with-article-headers
2400       ;; When displaying parts, this function can be called several times on
2401       ;; the same article, without any intended toggle semantic (as typing `W
2402       ;; D d' would have). So face deletion must occur only when we come from
2403       ;; an interactive command, that is when the *Article* buffer is
2404       ;; read-only.
2405       (if (and wash-face-p (memq 'face gnus-article-wash-types))
2406           (gnus-delete-images 'face)
2407         (let ((from (message-fetch-field "from"))
2408               face faces)
2409           (save-current-buffer
2410             (when (and wash-face-p
2411                        (gnus-buffer-live-p gnus-original-article-buffer)
2412                        (not (re-search-forward "^Face:[\t ]*" nil t)))
2413               (set-buffer gnus-original-article-buffer))
2414             (save-restriction
2415               (mail-narrow-to-head)
2416               (when (or force
2417                         ;; Check whether this face is censored.
2418                         (not (and gnus-article-x-face-too-ugly
2419                                   (or from
2420                                       (setq from (message-fetch-field "from")))
2421                                   (string-match gnus-article-x-face-too-ugly
2422                                                 from))))
2423                 (while (gnus-article-goto-header "Face")
2424                   (push (mail-header-field-value) faces)))))
2425           (when faces
2426             (goto-char (point-min))
2427             (let (png image)
2428               (unless (setq from (gnus-article-goto-header "from"))
2429                 (insert "From:")
2430                 (setq from (point))
2431                 (insert " [no `from' set]\n"))
2432               (while faces
2433                 (when (setq png (gnus-convert-face-to-png (pop faces)))
2434                   (setq image
2435                         (apply 'gnus-create-image png 'png t
2436                                (cdr (assq 'png gnus-face-properties-alist))))
2437                   (goto-char from)
2438                   (when image
2439                     (gnus-add-wash-type 'face)
2440                     (gnus-add-image 'face image)
2441                     (gnus-put-image image nil 'face)))))))))))
2442
2443 (defun article-display-x-face (&optional force)
2444   "Look for an X-Face header and display it if present."
2445   (interactive (list 'force))
2446   (let ((wash-face-p buffer-read-only)) ;; When type `W f'
2447     (gnus-with-article-headers
2448       ;; Delete the old process, if any.
2449       (when (process-status "article-x-face")
2450         (delete-process "article-x-face"))
2451       ;; See the comment in `article-display-face'.
2452       (if (and wash-face-p (memq 'xface gnus-article-wash-types))
2453           ;; We have already displayed X-Faces, so we remove them
2454           ;; instead.
2455           (gnus-delete-images 'xface)
2456         ;; Display X-Faces.
2457         (let ((from (message-fetch-field "from"))
2458               x-faces face)
2459           (save-current-buffer
2460             (when (and wash-face-p
2461                        (gnus-buffer-live-p gnus-original-article-buffer)
2462                        (not (re-search-forward "^X-Face:[\t ]*" nil t)))
2463               ;; If type `W f', use gnus-original-article-buffer,
2464               ;; otherwise use the current buffer because displaying
2465               ;; RFC822 parts calls this function too.
2466               (set-buffer gnus-original-article-buffer))
2467             (save-restriction
2468               (mail-narrow-to-head)
2469               (and gnus-article-x-face-command
2470                    (or force
2471                        ;; Check whether this face is censored.
2472                        (not (and gnus-article-x-face-too-ugly
2473                                  (or from
2474                                      (setq from (message-fetch-field "from")))
2475                                  (string-match gnus-article-x-face-too-ugly
2476                                                from))))
2477                    (while (gnus-article-goto-header "X-Face")
2478                      (push (mail-header-field-value) x-faces)))))
2479           (when x-faces
2480             ;; We display the face.
2481             (cond ((functionp gnus-article-x-face-command)
2482                    ;; The command is a lisp function, so we call it.
2483                    (mapc gnus-article-x-face-command x-faces))
2484                   ((stringp gnus-article-x-face-command)
2485                    ;; The command is a string, so we interpret the command
2486                    ;; as a, well, command, and fork it off.
2487                    (let ((process-connection-type nil))
2488                      (gnus-set-process-query-on-exit-flag
2489                       (start-process
2490                        "article-x-face" nil shell-file-name
2491                        shell-command-switch gnus-article-x-face-command)
2492                       nil)
2493                      ;; Sending multiple EOFs to xv doesn't work,
2494                      ;; so we only do a single external face.
2495                      (with-temp-buffer
2496                        (insert (car x-faces))
2497                        (process-send-region "article-x-face"
2498                                             (point-min) (point-max)))
2499                      (process-send-eof "article-x-face")))
2500                   (t
2501                    (error "`%s' set to `%s' is not a function"
2502                           gnus-article-x-face-command
2503                           'gnus-article-x-face-command)))))))))
2504
2505 (defun article-decode-mime-words ()
2506   "Decode all MIME-encoded words in the article."
2507   (interactive)
2508   (gnus-with-article-buffer
2509     (let ((inhibit-point-motion-hooks t)
2510           (mail-parse-charset gnus-newsgroup-charset)
2511           (mail-parse-ignored-charsets
2512            (with-current-buffer gnus-summary-buffer
2513              gnus-newsgroup-ignored-charsets)))
2514       (mail-decode-encoded-word-region (point-min) (point-max)))))
2515
2516 (defun article-decode-charset (&optional prompt)
2517   "Decode charset-encoded text in the article.
2518 If PROMPT (the prefix), prompt for a coding system to use."
2519   (interactive "P")
2520   (let ((inhibit-point-motion-hooks t) (case-fold-search t)
2521         (inhibit-read-only t)
2522         (mail-parse-charset gnus-newsgroup-charset)
2523         (mail-parse-ignored-charsets
2524          (save-excursion (condition-case nil
2525                              (set-buffer gnus-summary-buffer)
2526                            (error))
2527                          gnus-newsgroup-ignored-charsets))
2528         ct cte ctl charset format)
2529     (save-excursion
2530       (save-restriction
2531         (article-narrow-to-head)
2532         (setq ct (message-fetch-field "Content-Type" t)
2533               cte (message-fetch-field "Content-Transfer-Encoding" t)
2534               ctl (and ct (mail-header-parse-content-type ct))
2535               charset (cond
2536                        (prompt
2537                         (mm-read-coding-system "Charset to decode: "))
2538                        (ctl
2539                         (mail-content-type-get ctl 'charset)))
2540               format (and ctl (mail-content-type-get ctl 'format)))
2541         (when cte
2542           (setq cte (mail-header-strip cte)))
2543         (if (and ctl (not (string-match "/" (car ctl))))
2544             (setq ctl nil))
2545         (goto-char (point-max)))
2546       (forward-line 1)
2547       (save-restriction
2548         (narrow-to-region (point) (point-max))
2549         (when (and (eq mail-parse-charset 'gnus-decoded)
2550                    (eq (mm-body-7-or-8) '8bit))
2551           ;; The text code could have been decoded.
2552           (setq charset mail-parse-charset))
2553         (when (and (or (not ctl)
2554                        (equal (car ctl) "text/plain"))
2555                    (not format)) ;; article with format will decode later.
2556           (mm-decode-body
2557            charset (and cte (intern (downcase
2558                                      (gnus-strip-whitespace cte))))
2559            (car ctl)))))))
2560
2561 (defun article-decode-encoded-words ()
2562   "Remove encoded-word encoding from headers."
2563   (let ((inhibit-point-motion-hooks t)
2564         (mail-parse-charset gnus-newsgroup-charset)
2565         (mail-parse-ignored-charsets
2566          (save-excursion (condition-case nil
2567                              (set-buffer gnus-summary-buffer)
2568                            (error))
2569                          gnus-newsgroup-ignored-charsets))
2570         (inhibit-read-only t)
2571         end start)
2572     (goto-char (point-min))
2573     (when (search-forward "\n\n" nil 'move)
2574       (forward-line -1))
2575     (setq end (point))
2576     (while (not (bobp))
2577       (while (progn
2578                (forward-line -1)
2579                (and (not (bobp))
2580                     (memq (char-after) '(?\t ? )))))
2581       (setq start (point))
2582       (if (looking-at "\
2583 \\(?:Resent-\\)?\\(?:From\\|Cc\\|To\\|Bcc\\|\\(?:In-\\)?Reply-To\\|Sender\
2584 \\|Mail-Followup-To\\|Mail-Copies-To\\|Approved\\):")
2585           (funcall gnus-decode-address-function start end)
2586         (funcall gnus-decode-header-function start end))
2587       (goto-char (setq end start)))))
2588
2589 (defun article-decode-group-name ()
2590   "Decode group names in Newsgroups, Followup-To and Xref headers."
2591   (let ((inhibit-point-motion-hooks t)
2592         (inhibit-read-only t)
2593         (method (gnus-find-method-for-group gnus-newsgroup-name))
2594         regexp)
2595     (when (and (or gnus-group-name-charset-method-alist
2596                    gnus-group-name-charset-group-alist)
2597                (gnus-buffer-live-p gnus-original-article-buffer))
2598       (save-restriction
2599         (article-narrow-to-head)
2600         (dolist (header '("Newsgroups" "Followup-To" "Xref"))
2601           (with-current-buffer gnus-original-article-buffer
2602             (goto-char (point-min)))
2603           (setq regexp (concat "^" header
2604                                ":\\([^\n]*\\(?:\n[\t ]+[^\n]+\\)*\\)\n"))
2605           (while (re-search-forward regexp nil t)
2606             (replace-match (save-match-data
2607                              (gnus-decode-newsgroups
2608                               ;; XXX how to use data in article buffer?
2609                               (with-current-buffer gnus-original-article-buffer
2610                                 (re-search-forward regexp nil t)
2611                                 (match-string 1))
2612                               gnus-newsgroup-name method))
2613                            t t nil 1))
2614           (goto-char (point-min)))))))
2615
2616 (autoload 'idna-to-unicode "idna")
2617
2618 (defun article-decode-idna-rhs ()
2619   "Decode IDNA strings in RHS in various headers in current buffer.
2620 The following headers are decoded: From:, To:, Cc:, Reply-To:,
2621 Mail-Reply-To: and Mail-Followup-To:."
2622   (when gnus-use-idna
2623     (save-restriction
2624       (let ((inhibit-point-motion-hooks t)
2625             (inhibit-read-only t))
2626         (article-narrow-to-head)
2627         (goto-char (point-min))
2628         (while (re-search-forward "@[^ \t\n\r,>]*\\(xn--[-A-Za-z0-9.]*\\)[ \t\n\r,>]" nil t)
2629           (let (ace unicode)
2630             (when (save-match-data
2631                     (and (setq ace (match-string 1))
2632                          (save-excursion
2633                            (and (re-search-backward "^[^ \t]" nil t)
2634                                 (looking-at "From\\|To\\|Cc\\|Reply-To\\|Mail-Reply-To\\|Mail-Followup-To")))
2635                          (setq unicode (idna-to-unicode ace))))
2636               (unless (string= ace unicode)
2637                 (replace-match unicode nil nil nil 1)))))))))
2638
2639 (defun article-de-quoted-unreadable (&optional force read-charset)
2640   "Translate a quoted-printable-encoded article.
2641 If FORCE, decode the article whether it is marked as quoted-printable
2642 or not.
2643 If READ-CHARSET, ask for a coding system."
2644   (interactive (list 'force current-prefix-arg))
2645   (save-excursion
2646     (let ((inhibit-read-only t) type charset)
2647       (if (gnus-buffer-live-p gnus-original-article-buffer)
2648           (with-current-buffer gnus-original-article-buffer
2649             (setq type
2650                   (gnus-fetch-field "content-transfer-encoding"))
2651             (let* ((ct (gnus-fetch-field "content-type"))
2652                    (ctl (and ct (mail-header-parse-content-type ct))))
2653               (setq charset (and ctl
2654                                  (mail-content-type-get ctl 'charset)))
2655               (if (stringp charset)
2656                   (setq charset (intern (downcase charset)))))))
2657       (if read-charset
2658           (setq charset (mm-read-coding-system "Charset: " charset)))
2659       (unless charset
2660         (setq charset gnus-newsgroup-charset))
2661       (when (or force
2662                 (and type (let ((case-fold-search t))
2663                             (string-match "quoted-printable" type))))
2664         (article-goto-body)
2665         (quoted-printable-decode-region
2666          (point) (point-max) (mm-charset-to-coding-system charset nil t))))))
2667
2668 (defun article-de-base64-unreadable (&optional force read-charset)
2669   "Translate a base64 article.
2670 If FORCE, decode the article whether it is marked as base64 not.
2671 If READ-CHARSET, ask for a coding system."
2672   (interactive (list 'force current-prefix-arg))
2673   (save-excursion
2674     (let ((inhibit-read-only t) type charset)
2675       (if (gnus-buffer-live-p gnus-original-article-buffer)
2676           (with-current-buffer gnus-original-article-buffer
2677             (setq type
2678                   (gnus-fetch-field "content-transfer-encoding"))
2679             (let* ((ct (gnus-fetch-field "content-type"))
2680                    (ctl (and ct (mail-header-parse-content-type ct))))
2681               (setq charset (and ctl
2682                                  (mail-content-type-get ctl 'charset)))
2683               (if (stringp charset)
2684                   (setq charset (intern (downcase charset)))))))
2685       (if read-charset
2686           (setq charset (mm-read-coding-system "Charset: " charset)))
2687       (unless charset
2688         (setq charset gnus-newsgroup-charset))
2689       (when (or force
2690                 (and type (let ((case-fold-search t))
2691                             (string-match "base64" type))))
2692         (article-goto-body)
2693         (save-restriction
2694           (narrow-to-region (point) (point-max))
2695           (base64-decode-region (point-min) (point-max))
2696           (mm-decode-coding-region
2697            (point-min) (point-max)
2698            (mm-charset-to-coding-system charset nil t)))))))
2699
2700 (eval-when-compile
2701   (require 'rfc1843))
2702
2703 (defun article-decode-HZ ()
2704   "Translate a HZ-encoded article."
2705   (interactive)
2706   (require 'rfc1843)
2707   (save-excursion
2708     (let ((inhibit-read-only t))
2709       (rfc1843-decode-region (point-min) (point-max)))))
2710
2711 (defun article-unsplit-urls ()
2712   "Remove the newlines that some other mailers insert into URLs."
2713   (interactive)
2714   (save-excursion
2715     (let ((inhibit-read-only t))
2716       (goto-char (point-min))
2717       (while (re-search-forward
2718               "\\(\\(https?\\|ftp\\)://\\S-+\\) *\n\\(\\S-+\\)" nil t)
2719         (replace-match "\\1\\3" t)))
2720     (when (gmm-called-interactively-p 'any)
2721       (gnus-treat-article nil))))
2722
2723 (defun article-wash-html ()
2724   "Format an HTML article."
2725   (interactive)
2726   (let ((handles nil)
2727         (buffer-read-only nil))
2728     (when (gnus-buffer-live-p gnus-original-article-buffer)
2729       (with-current-buffer gnus-original-article-buffer
2730         (setq handles (mm-dissect-buffer t t))))
2731     (article-goto-body)
2732     (delete-region (point) (point-max))
2733     (mm-enable-multibyte)
2734     (mm-inline-text-html handles)))
2735
2736 (defvar gnus-article-browse-html-temp-list nil
2737   "List of temporary files created by `gnus-article-browse-html-parts'.
2738 Internal variable.")
2739
2740 (defcustom gnus-article-browse-delete-temp 'ask
2741   "What to do with temporary files from `gnus-article-browse-html-parts'.
2742 If nil, don't delete temporary files.  If it is t, delete them on
2743 exit from the summary buffer.  If it is the symbol `file', query
2744 on each file, if it is `ask' ask once when exiting from the
2745 summary buffer."
2746   :group 'gnus-article
2747   :version "23.1" ;; No Gnus
2748   :type '(choice (const :tag "Don't delete" nil)
2749                  (const :tag "Don't ask" t)
2750                  (const :tag "Ask" ask)
2751                  (const :tag "Ask for each file" file)))
2752
2753 ;; Cf. mm-postponed-undisplay-list / mm-destroy-postponed-undisplay-list.
2754
2755 (defun gnus-article-browse-delete-temp-files (&optional how)
2756   "Delete temp-files created by `gnus-article-browse-html-parts'."
2757   (when (and gnus-article-browse-html-temp-list
2758              (progn
2759                (or how (setq how gnus-article-browse-delete-temp))
2760                (if (eq how 'ask)
2761                    (let ((files (length gnus-article-browse-html-temp-list)))
2762                      (or (gnus-y-or-n-p
2763                           (if (= files 1)
2764                               "Delete the temporary HTML file? "
2765                             (format "Delete all %s temporary HTML files? "
2766                                     files)))
2767                          (setq gnus-article-browse-html-temp-list nil)))
2768                  how)))
2769     (dolist (file gnus-article-browse-html-temp-list)
2770       (cond ((file-directory-p file)
2771              (when (or (not (eq how 'file))
2772                        (gnus-y-or-n-p
2773                         (format
2774                          "Delete temporary HTML file(s) in directory `%s'? "
2775                          (file-name-as-directory file))))
2776                (gnus-delete-directory file)))
2777             ((file-exists-p file)
2778              (when (or (not (eq how 'file))
2779                        (gnus-y-or-n-p
2780                         (format "Delete temporary HTML file `%s'? " file)))
2781                (delete-file file)))))
2782     ;; Also remove file from the list when not deleted or if file doesn't
2783     ;; exist anymore.
2784     (setq gnus-article-browse-html-temp-list nil))
2785   gnus-article-browse-html-temp-list)
2786
2787 (defun gnus-article-browse-html-save-cid-content (cid handles directory)
2788   "Find CID content in HANDLES and save it in a file in DIRECTORY.
2789 Return file name."
2790   (save-match-data
2791     (let (file type)
2792       (catch 'found
2793         (dolist (handle handles)
2794           (cond
2795            ((not (listp handle)))
2796            ;; Exclude broken handles that `gnus-summary-enter-digest-group'
2797            ;; may create.
2798            ((not (or (bufferp (car handle)) (stringp (car handle)))))
2799            ((equal (mm-handle-media-supertype handle) "multipart")
2800             (when (setq file (gnus-article-browse-html-save-cid-content
2801                               cid handle directory))
2802               (throw 'found file)))
2803            ((equal (concat "<" cid ">") (mm-handle-id handle))
2804             (setq file
2805                   (expand-file-name
2806                    (or (mm-handle-filename handle)
2807                        (concat
2808                         (make-temp-name "cid")
2809                         (car (rassoc (car (mm-handle-type handle))
2810                                      mailcap-mime-extensions))))
2811                    directory))
2812             (mm-save-part-to-file handle file)
2813             (throw 'found file))))))))
2814
2815 (defun gnus-article-browse-html-parts (list &optional header)
2816   "View all \"text/html\" parts from LIST.
2817 Recurse into multiparts.  The optional HEADER that should be a decoded
2818 message header will be added to the bodies of the \"text/html\" parts."
2819   ;; Internal function used by `gnus-article-browse-html-article'.
2820   (let (type file charset content cid-dir tmp-file showed)
2821     ;; Find and show the html-parts.
2822     (dolist (handle list)
2823       ;; If HTML, show it:
2824       (cond ((not (listp handle)))
2825             ((or (equal (car (setq type (mm-handle-type handle))) "text/html")
2826                  (and (equal (car type) "message/external-body")
2827                       (or header
2828                           (setq file (mm-handle-filename handle)))
2829                       (or (mm-handle-cache handle)
2830                           (condition-case code
2831                               (progn (mm-extern-cache-contents handle) t)
2832                             (error
2833                              (gnus-message 3 "%s" (error-message-string code))
2834                              (when (>= gnus-verbose 3) (sit-for 2))
2835                              nil)))
2836                       (progn
2837                         (setq handle (mm-handle-cache handle)
2838                               type (mm-handle-type handle))
2839                         (equal (car type) "text/html"))))
2840              (setq charset (mail-content-type-get type 'charset)
2841                    content (mm-get-part handle))
2842              (with-temp-buffer
2843                (if (eq charset 'gnus-decoded)
2844                    (mm-enable-multibyte)
2845                  (mm-disable-multibyte))
2846                (insert content)
2847                ;; resolve cid contents
2848                (let ((case-fold-search t)
2849                      cid-file)
2850                  (goto-char (point-min))
2851                  (while (re-search-forward "\
2852 <img[\t\n ]+\\(?:[^\t\n >]+[\t\n ]+\\)*src=\"\\(cid:\\([^\"]+\\)\\)\""
2853                                            nil t)
2854                    (unless cid-dir
2855                      (setq cid-dir (mm-make-temp-file "cid" t))
2856                      (add-to-list 'gnus-article-browse-html-temp-list cid-dir))
2857                    (setq file nil
2858                          content nil)
2859                    (when (setq cid-file
2860                                (gnus-article-browse-html-save-cid-content
2861                                 (match-string 2)
2862                                 (with-current-buffer gnus-article-buffer
2863                                   gnus-article-mime-handles)
2864                                 cid-dir))
2865                      (when (eq system-type 'cygwin)
2866                        (setq cid-file
2867                              (concat "/" (substring
2868                                           (with-output-to-string
2869                                             (call-process "cygpath" nil
2870                                                           standard-output
2871                                                           nil "-m" cid-file))
2872                                           0 -1))))
2873                      (replace-match (concat "file://" cid-file)
2874                                     nil nil nil 1))))
2875                (unless content (setq content (buffer-string))))
2876              (when (or charset header (not file))
2877                (setq tmp-file (mm-make-temp-file
2878                                ;; Do we need to care for 8.3 filenames?
2879                                "mm-" nil ".html")))
2880              ;; Add a meta html tag to specify charset and a header.
2881              (cond
2882               (header
2883                (let (title eheader body hcharset coding)
2884                  (with-temp-buffer
2885                    (mm-enable-multibyte)
2886                    (setq case-fold-search t)
2887                    (insert header "\n")
2888                    (setq title (message-fetch-field "subject"))
2889                    (goto-char (point-min))
2890                    (while (re-search-forward "\\(<\\)\\|\\(>\\)\\|\\(&\\)\\|\n"
2891                                              nil t)
2892                      (replace-match (cond ((match-beginning 1) "&lt;")
2893                                           ((match-beginning 2) "&gt;")
2894                                           ((match-beginning 3) "&amp;")
2895                                           (t "<br>\n"))))
2896                    (goto-char (point-min))
2897                    (while (re-search-forward "^[\t ]+" nil t)
2898                      (dotimes (i (prog1
2899                                      (current-column)
2900                                    (delete-region (match-beginning 0)
2901                                                   (match-end 0))))
2902                        (insert "&nbsp;")))
2903                    (goto-char (point-min))
2904                    (insert "<div align=\"left\">\n")
2905                    (goto-char (point-max))
2906                    (insert "</div>\n<hr>\n")
2907                    ;; We have to examine charset one by one since
2908                    ;; charset specified in parts might be different.
2909                    (if (eq charset 'gnus-decoded)
2910                        (setq charset 'utf-8
2911                              eheader (mm-encode-coding-string (buffer-string)
2912                                                               charset)
2913                              title (when title
2914                                      (mm-encode-coding-string title charset))
2915                              body (mm-encode-coding-string content charset))
2916                      (setq hcharset (mm-find-mime-charset-region (point-min)
2917                                                                  (point-max)))
2918                      (cond ((= (length hcharset) 1)
2919                             (setq hcharset (car hcharset)
2920                                   coding (mm-charset-to-coding-system
2921                                           hcharset nil t)))
2922                            ((> (length hcharset) 1)
2923                             (setq hcharset 'utf-8
2924                                   coding hcharset)))
2925                      (if coding
2926                          (if charset
2927                              (progn
2928                                (setq body
2929                                      (mm-charset-to-coding-system charset
2930                                                                   nil t))
2931                                (if (eq coding body)
2932                                    (setq eheader (mm-encode-coding-string
2933                                                   (buffer-string) coding)
2934                                          title (when title
2935                                                  (mm-encode-coding-string
2936                                                   title coding))
2937                                          body content)
2938                                  (setq charset 'utf-8
2939                                        eheader (mm-encode-coding-string
2940                                                 (buffer-string) charset)
2941                                        title (when title
2942                                                (mm-encode-coding-string
2943                                                 title charset))
2944                                        body (mm-encode-coding-string
2945                                              (mm-decode-coding-string
2946                                               content body)
2947                                              charset))))
2948                            (setq charset hcharset
2949                                  eheader (mm-encode-coding-string
2950                                           (buffer-string) coding)
2951                                  title (when title
2952                                          (mm-encode-coding-string
2953                                           title coding))
2954                                  body content))
2955                        (setq eheader (mm-string-as-unibyte (buffer-string))
2956                              body content)))
2957                    (erase-buffer)
2958                    (mm-disable-multibyte)
2959                    (insert body)
2960                    (when charset
2961                      (mm-add-meta-html-tag handle charset t))
2962                    (when title
2963                      (goto-char (point-min))
2964                      (unless (search-forward "<title>" nil t)
2965                        (re-search-forward "<head>\\s-*" nil t)
2966                        (insert "<title>" title "</title>\n")))
2967                    (goto-char (point-min))
2968                    (or (re-search-forward
2969                         "<body\\(?:\\s-+[^>]+\\|\\s-*\\)>\\s-*" nil t)
2970                        (re-search-forward
2971                         "</head\\(?:\\s-+[^>]+\\|\\s-*\\)>\\s-*" nil t))
2972                    (insert eheader)
2973                    (mm-write-region (point-min) (point-max)
2974                                     tmp-file nil nil nil 'binary t))))
2975               (charset
2976                (mm-with-unibyte-buffer
2977                  (insert (if (eq charset 'gnus-decoded)
2978                              (mm-encode-coding-string content
2979                                                       (setq charset 'utf-8))
2980                            content))
2981                  (if (or (mm-add-meta-html-tag handle charset)
2982                          (not file))
2983                      (mm-write-region (point-min) (point-max)
2984                                       tmp-file nil nil nil 'binary t)
2985                    (setq tmp-file nil))))
2986               (tmp-file
2987                (mm-save-part-to-file handle tmp-file)))
2988              (when tmp-file
2989                (add-to-list 'gnus-article-browse-html-temp-list tmp-file))
2990              (add-hook 'gnus-summary-prepare-exit-hook
2991                        'gnus-article-browse-delete-temp-files)
2992              (add-hook 'gnus-exit-gnus-hook
2993                        (lambda  ()
2994                          (gnus-article-browse-delete-temp-files t)))
2995              ;; FIXME: Warn if there's an <img> tag?
2996              (browse-url-of-file (or tmp-file (expand-file-name file)))
2997              (setq showed t))
2998             ;; If multipart, recurse
2999             ((equal (mm-handle-media-supertype handle) "multipart")
3000              (when (gnus-article-browse-html-parts handle header)
3001                (setq showed t)))
3002             ((equal (mm-handle-media-type handle) "message/rfc822")
3003              (mm-with-multibyte-buffer
3004                (mm-insert-part handle)
3005                (setq handle (mm-dissect-buffer t t))
3006                (when (and (bufferp (car handle))
3007                           (stringp (car (mm-handle-type handle))))
3008                  (setq handle (list handle)))
3009                (when header
3010                  (article-decode-encoded-words)
3011                  (let ((gnus-visible-headers
3012                         (or (get 'gnus-visible-headers 'standard-value)
3013                             gnus-visible-headers)))
3014                    (article-hide-headers))
3015                  (goto-char (point-min))
3016                  (search-forward "\n\n" nil 'move)
3017                  (skip-chars-backward "\t\n ")
3018                  (setq header (buffer-substring (point-min) (point)))))
3019              (when (prog1
3020                        (gnus-article-browse-html-parts handle header)
3021                      (mm-destroy-parts handle))
3022                (setq showed t)))))
3023     showed))
3024
3025 (defun gnus-article-browse-html-article (&optional arg)
3026   "View \"text/html\" parts of the current article with a WWW browser.
3027 Inline images embedded in a message using the cid scheme, as they are
3028 generally considered to be safe, will be processed properly.
3029 The message header is added to the beginning of every html part unless
3030 the prefix argument ARG is given.
3031
3032 Warning: Spammers use links to images (using the http scheme) in HTML
3033 articles to verify whether you have read the message.  As
3034 `gnus-article-browse-html-article' passes the HTML content to the
3035 browser without eliminating these \"web bugs\" you should only
3036 use it for mails from trusted senders.
3037
3038 If you always want to display HTML parts in the browser, set
3039 `mm-text-html-renderer' to nil.
3040
3041 This command creates temporary files to pass HTML contents including
3042 images if any to the browser, and deletes them when exiting the group
3043 \(if you want)."
3044   ;; Cf. `mm-w3m-safe-url-regexp'
3045   (interactive "P")
3046   (if arg
3047       (gnus-summary-show-article)
3048     (let ((gnus-visible-headers (or (get 'gnus-visible-headers 'standard-value)
3049                                     gnus-visible-headers))
3050           ;; As we insert a <hr>, there's no need for the body boundary.
3051           (gnus-treat-body-boundary nil))
3052       (gnus-summary-show-article)))
3053   (with-current-buffer gnus-article-buffer
3054     (let ((header (unless arg
3055                     (save-restriction
3056                       (widen)
3057                       (buffer-substring-no-properties
3058                        (goto-char (point-min))
3059                        (if (search-forward "\n\n" nil t)
3060                            (match-beginning 0)
3061                          (goto-char (point-max))
3062                          (skip-chars-backward "\t\n ")
3063                          (point))))))
3064           parts)
3065       (set-buffer gnus-original-article-buffer)
3066       (setq parts (mm-dissect-buffer t t))
3067       ;; If singlepart, enforce a list.
3068       (when (and (bufferp (car parts))
3069                  (stringp (car (mm-handle-type parts))))
3070         (setq parts (list parts)))
3071       ;; Process the list
3072       (unless (gnus-article-browse-html-parts parts header)
3073         (gnus-error 3 "Mail doesn't contain a \"text/html\" part!"))
3074       (mm-destroy-parts parts)
3075       (unless arg
3076         (gnus-summary-show-article)))))
3077
3078 (defun article-hide-list-identifiers ()
3079   "Remove list identifies from the Subject header.
3080 The `gnus-list-identifiers' variable specifies what to do."
3081   (interactive)
3082   (let ((inhibit-point-motion-hooks t)
3083         (regexp (gnus-group-get-list-identifiers gnus-newsgroup-name))
3084         (inhibit-read-only t))
3085     (when regexp
3086       (save-excursion
3087         (save-restriction
3088           (article-narrow-to-head)
3089           (goto-char (point-min))
3090           (while (re-search-forward
3091                   (concat "^Subject: +\\(R[Ee]: +\\)*\\(" regexp " *\\)")
3092                   nil t)
3093             (delete-region (match-beginning 2) (match-end 0))
3094             (beginning-of-line))
3095           (when (re-search-forward
3096                  "^Subject: +\\(\\(R[Ee]: +\\)+\\)R[Ee]: +" nil t)
3097             (delete-region (match-beginning 1) (match-end 1))))))))
3098
3099 (defun article-hide-pem (&optional arg)
3100   "Toggle hiding of any PEM headers and signatures in the current article.
3101 If given a negative prefix, always show; if given a positive prefix,
3102 always hide."
3103   (interactive (gnus-article-hidden-arg))
3104   (unless (gnus-article-check-hidden-text 'pem arg)
3105     (save-excursion
3106       (let ((inhibit-read-only t) end)
3107         (goto-char (point-min))
3108         ;; Hide the horrendously ugly "header".
3109         (when (and (search-forward
3110                     "\n-----BEGIN PRIVACY-ENHANCED MESSAGE-----\n"
3111                     nil t)
3112                    (setq end (1+ (match-beginning 0))))
3113           (gnus-add-wash-type 'pem)
3114           (gnus-article-hide-text-type
3115            end
3116            (if (search-forward "\n\n" nil t)
3117                (match-end 0)
3118              (point-max))
3119            'pem)
3120           ;; Hide the trailer as well
3121           (when (search-forward "\n-----END PRIVACY-ENHANCED MESSAGE-----\n"
3122                                 nil t)
3123             (gnus-article-hide-text-type
3124              (match-beginning 0) (match-end 0) 'pem)))))))
3125
3126 (defun article-strip-banner ()
3127   "Strip the banners specified by the `banner' group parameter and by
3128 `gnus-article-address-banner-alist'."
3129   (interactive)
3130   (save-excursion
3131     (save-restriction
3132       (let ((inhibit-point-motion-hooks t))
3133         (when (gnus-parameter-banner gnus-newsgroup-name)
3134           (article-really-strip-banner
3135            (gnus-parameter-banner gnus-newsgroup-name)))
3136         (when gnus-article-address-banner-alist
3137           ;; Note that the From header is decoded here, so it is
3138           ;; required that the *-extract-address-components function
3139           ;; supports non-ASCII text.
3140           (let ((from (save-restriction
3141                         (widen)
3142                         (article-narrow-to-head)
3143                         (mail-fetch-field "from"))))
3144             (when (and from
3145                        (setq from
3146                              (cadr (funcall gnus-extract-address-components
3147                                             from))))
3148               (catch 'found
3149                 (dolist (pair gnus-article-address-banner-alist)
3150                   (when (string-match (car pair) from)
3151                     (throw 'found
3152                            (article-really-strip-banner (cdr pair)))))))))))))
3153
3154 (defun article-really-strip-banner (banner)
3155   "Strip the banner specified by the argument."
3156   (save-excursion
3157     (save-restriction
3158       (let ((inhibit-point-motion-hooks t)
3159             (gnus-signature-limit nil)
3160             (inhibit-read-only t))
3161         (article-goto-body)
3162         (cond
3163          ((eq banner 'signature)
3164           (when (gnus-article-narrow-to-signature)
3165             (widen)
3166             (forward-line -1)
3167             (delete-region (point) (point-max))))
3168          ((symbolp banner)
3169           (if (setq banner (cdr (assq banner gnus-article-banner-alist)))
3170               (while (re-search-forward banner nil t)
3171                 (delete-region (match-beginning 0) (match-end 0)))))
3172          ((stringp banner)
3173           (while (re-search-forward banner nil t)
3174             (delete-region (match-beginning 0) (match-end 0)))))))))
3175
3176 (defun article-babel ()
3177   "Translate article using an online translation service."
3178   (interactive)
3179   (require 'babel)
3180   (gnus-with-article-buffer
3181     (when (article-goto-body)
3182       (let* ((start (point))
3183              (end (point-max))
3184              (orig (buffer-substring start end))
3185              (trans (babel-as-string orig)))
3186         (save-restriction
3187           (narrow-to-region start end)
3188           (delete-region start end)
3189           (insert trans))))))
3190
3191 (defun article-hide-signature (&optional arg)
3192   "Hide the signature in the current article.
3193 If given a negative prefix, always show; if given a positive prefix,
3194 always hide."
3195   (interactive (gnus-article-hidden-arg))
3196   (unless (gnus-article-check-hidden-text 'signature arg)
3197     (save-excursion
3198       (save-restriction
3199         (let ((inhibit-read-only t))
3200           (when (gnus-article-narrow-to-signature)
3201             (gnus-article-hide-text-type
3202              (point-min) (point-max) 'signature))))))
3203   (gnus-set-mode-line 'article))
3204
3205 (defun article-strip-headers-in-body ()
3206   "Strip offensive headers from bodies."
3207   (interactive)
3208   (save-excursion
3209     (article-goto-body)
3210     (let ((case-fold-search t))
3211       (when (looking-at "x-no-archive:")
3212         (gnus-delete-line)))))
3213
3214 (defun article-strip-leading-blank-lines ()
3215   "Remove all blank lines from the beginning of the article."
3216   (interactive)
3217   (save-excursion
3218     (let ((inhibit-point-motion-hooks t)
3219           (inhibit-read-only t))
3220       (when (article-goto-body)
3221         (while (and (not (eobp))
3222                     (looking-at "[ \t]*$"))
3223           (gnus-delete-line))))))
3224
3225 (defun article-narrow-to-head ()
3226   "Narrow the buffer to the head of the message.
3227 Point is left at the beginning of the narrowed-to region."
3228   (narrow-to-region
3229    (goto-char (point-min))
3230    (cond
3231     ;; Absolutely no headers displayed.
3232     ((looking-at "\n")
3233      (point))
3234     ;; Normal headers.
3235     ((search-forward "\n\n" nil 1)
3236      (1- (point)))
3237     ;; Nothing but headers.
3238     (t
3239      (point-max))))
3240   (goto-char (point-min)))
3241
3242 (defun article-goto-body ()
3243   "Place point at the start of the body."
3244   (goto-char (point-min))
3245   (cond
3246    ;; This variable is only bound when dealing with separate
3247    ;; MIME body parts.
3248    (article-goto-body-goes-to-point-min-p
3249     t)
3250    ((search-forward "\n\n" nil t)
3251     t)
3252    (t
3253     (goto-char (point-max))
3254     nil)))
3255
3256 (defun article-strip-multiple-blank-lines ()
3257   "Replace consecutive blank lines with one empty line."
3258   (interactive)
3259   (save-excursion
3260     (let ((inhibit-point-motion-hooks t)
3261           (inhibit-read-only t))
3262       ;; First make all blank lines empty.
3263       (article-goto-body)
3264       (while (re-search-forward "^[ \t]+$" nil t)
3265         (unless (gnus-annotation-in-region-p
3266                  (match-beginning 0) (match-end 0))
3267           (replace-match "" nil t)))
3268       ;; Then replace multiple empty lines with a single empty line.
3269       (article-goto-body)
3270       (while (re-search-forward "\n\n\\(\n+\\)" nil t)
3271         (unless (gnus-annotation-in-region-p
3272                  (match-beginning 0) (match-end 0))
3273           (delete-region (match-beginning 1) (match-end 1)))))))
3274
3275 (defun article-strip-leading-space ()
3276   "Remove all white space from the beginning of the lines in the article."
3277   (interactive)
3278   (save-excursion
3279     (let ((inhibit-point-motion-hooks t)
3280           (inhibit-read-only t))
3281       (article-goto-body)
3282       (while (re-search-forward "^[ \t]+" nil t)
3283         (replace-match "" t t)))))
3284
3285 (defun article-strip-trailing-space ()
3286   "Remove all white space from the end of the lines in the article."
3287   (interactive)
3288   (save-excursion
3289     (let ((inhibit-point-motion-hooks t)
3290           (inhibit-read-only t))
3291       (article-goto-body)
3292       (while (re-search-forward "[ \t]+$" nil t)
3293         (replace-match "" t t)))))
3294
3295 (defun article-strip-blank-lines ()
3296   "Strip leading, trailing and multiple blank lines."
3297   (interactive)
3298   (article-strip-leading-blank-lines)
3299   (article-remove-trailing-blank-lines)
3300   (article-strip-multiple-blank-lines))
3301
3302 (defun article-strip-all-blank-lines ()
3303   "Strip all blank lines."
3304   (interactive)
3305   (save-excursion
3306     (let ((inhibit-point-motion-hooks t)
3307           (inhibit-read-only t))
3308       (article-goto-body)
3309       (while (re-search-forward "^[ \t]*\n" nil t)
3310         (replace-match "" t t)))))
3311
3312 (defun gnus-article-narrow-to-signature ()
3313   "Narrow to the signature; return t if a signature is found, else nil."
3314   (let ((inhibit-point-motion-hooks t))
3315     (when (gnus-article-search-signature)
3316       (forward-line 1)
3317       ;; Check whether we have some limits to what we consider
3318       ;; to be a signature.
3319       (let ((limits (if (listp gnus-signature-limit) gnus-signature-limit
3320                       (list gnus-signature-limit)))
3321             limit limited)
3322         (while (setq limit (pop limits))
3323           (if (or (and (integerp limit)
3324                        (< (- (point-max) (point)) limit))
3325                   (and (floatp limit)
3326                        (< (count-lines (point) (point-max)) limit))
3327                   (and (functionp limit)
3328                        (funcall limit))
3329                   (and (stringp limit)
3330                        (not (re-search-forward limit nil t))))
3331               ()                        ; This limit did not succeed.
3332             (setq limited t
3333                   limits nil)))
3334         (unless limited
3335           (narrow-to-region (point) (point-max))
3336           t)))))
3337
3338 (defun gnus-article-search-signature ()
3339   "Search the current buffer for the signature separator.
3340 Put point at the beginning of the signature separator."
3341   (let ((cur (point)))
3342     (goto-char (point-max))
3343     (if (if (stringp gnus-signature-separator)
3344             (re-search-backward gnus-signature-separator nil t)
3345           (let ((seps gnus-signature-separator))
3346             (while (and seps
3347                         (not (re-search-backward (car seps) nil t)))
3348               (pop seps))
3349             seps))
3350         t
3351       (goto-char cur)
3352       nil)))
3353
3354 (defun gnus-article-hidden-arg ()
3355   "Return the current prefix arg as a number, or 0 if no prefix."
3356   (list (if current-prefix-arg
3357             (prefix-numeric-value current-prefix-arg)
3358           0)))
3359
3360 (defun gnus-article-check-hidden-text (type arg)
3361   "Return nil if hiding is necessary.
3362 Arg can be nil or a number.  nil and positive means hide, negative
3363 means show, 0 means toggle."
3364   (save-excursion
3365     (save-restriction
3366       (let ((hide (gnus-article-hidden-text-p type)))
3367         (cond
3368          ((or (null arg)
3369               (> arg 0))
3370           nil)
3371          ((< arg 0)
3372           (gnus-article-show-hidden-text type)
3373           t)
3374          (t
3375           (if (eq hide 'hidden)
3376               (progn
3377                 (gnus-article-show-hidden-text type)
3378                 t)
3379             nil)))))))
3380
3381 (defun gnus-article-hidden-text-p (type)
3382   "Say whether the current buffer contains hidden text of type TYPE."
3383   (let ((pos (text-property-any (point-min) (point-max) 'article-type type)))
3384     (while (and pos
3385                 (not (get-text-property pos 'invisible))
3386                 (not (get-text-property pos 'dummy-invisible)))
3387       (setq pos
3388             (text-property-any (1+ pos) (point-max) 'article-type type)))
3389     (if pos
3390         'hidden
3391       nil)))
3392
3393 (defun gnus-article-show-hidden-text (type &optional dummy)
3394   "Show all hidden text of type TYPE.
3395 Originally it is hide instead of DUMMY."
3396   (let ((inhibit-read-only t)
3397         (inhibit-point-motion-hooks t))
3398     (gnus-remove-text-properties-when
3399      'article-type type
3400      (point-min) (point-max)
3401      (cons 'article-type (cons type
3402                                gnus-hidden-properties)))
3403     (gnus-delete-wash-type type)))
3404
3405 (defconst article-time-units
3406   `((year . ,(* 365.25 24 60 60))
3407     (week . ,(* 7 24 60 60))
3408     (day . ,(* 24 60 60))
3409     (hour . ,(* 60 60))
3410     (minute . 60)
3411     (second . 1))
3412   "Mapping from time units to seconds.")
3413
3414 (defun gnus-article-forward-header ()
3415   "Move point to the start of the next header.
3416 If the current header is a continuation header, this can be several
3417 lines forward."
3418   (let ((ended nil))
3419     (while (not ended)
3420       (forward-line 1)
3421       (if (looking-at "[ \t]+[^ \t]")
3422           (forward-line 1)
3423         (setq ended t)))))
3424
3425 (defun article-treat-date ()
3426   (article-date-ut (if (gnus-buffer-live-p gnus-summary-buffer)
3427                        (with-current-buffer gnus-summary-buffer
3428                          gnus-article-date-headers)
3429                      gnus-article-date-headers)
3430                    t))
3431
3432 (defun article-date-ut (&optional type highlight date-position)
3433   "Convert DATE date to TYPE in the current article.
3434 The default type is `ut'.  See `gnus-article-date-headers' for
3435 possible values."
3436   (interactive (list 'ut t))
3437   (let* ((case-fold-search t)
3438          (inhibit-read-only t)
3439          (inhibit-point-motion-hooks t)
3440          (first t)
3441          (visible-date (mail-fetch-field "Date"))
3442          pos date bface eface)
3443     (save-excursion
3444       (if date-position
3445           (progn
3446             (goto-char date-position)
3447             (setq date (get-text-property (point) 'original-date))
3448             (when (looking-at "[^:]+:[\t ]*")
3449               (setq bface (get-text-property (match-beginning 0) 'face)
3450                     eface (get-text-property (match-end 0) 'face)))
3451             (delete-region (point)
3452                            (progn
3453                              (gnus-article-forward-header)
3454                              (point)))
3455             (article-transform-date date type bface eface))
3456         (save-restriction
3457           (widen)
3458           (goto-char (point-min))
3459           (while (or (get-text-property (setq pos (point)) 'original-date)
3460                      (and (setq pos (next-single-property-change
3461                                      (point) 'original-date))
3462                           (goto-char pos)))
3463             (narrow-to-region pos (if (search-forward "\n\n" nil t)
3464                                       (1+ (match-beginning 0))
3465                                     (point-max)))
3466             (while (setq pos (text-property-not-all pos (point-max)
3467                                                     'gnus-date-type nil))
3468               (setq date (get-text-property pos 'original-date))
3469               (goto-char pos)
3470               (when (looking-at "[^:]+:[\t ]*")
3471                 (setq bface (get-text-property (match-beginning 0) 'face)
3472                       eface (get-text-property (match-end 0) 'face)))
3473               (delete-region pos (or (text-property-any pos (point-max)
3474                                                         'gnus-date-type nil)
3475                                      (point-max))))
3476             (unless date ;; the 1st time
3477               (goto-char (point-min))
3478               (while (re-search-forward "^Date:[\t ]*" nil t)
3479                 (setq date (get-text-property (match-beginning 0)
3480                                               'original-date)
3481                       bface (get-text-property (match-beginning 0) 'face)
3482                       eface (get-text-property (match-end 0) 'face))
3483                 (delete-region (point-at-bol) (progn
3484                                                 (gnus-article-forward-header)
3485                                                 (point)))))
3486             (when (and (not date)
3487                        visible-date)
3488               (setq date visible-date))
3489             (when date
3490               (article-transform-date date type bface eface))
3491             (goto-char (point-max))
3492             (widen)))))))
3493
3494 (defun article-transform-date (date type bface eface)
3495   (dolist (this-type (cond
3496                       ((null type)
3497                        (list 'ut))
3498                       ((atom type)
3499                        (list type))
3500                       (t
3501                        type)))
3502     (goto-char
3503      (prog1
3504          (point)
3505        (add-text-properties
3506         (point)
3507         (progn
3508           (insert (article-make-date-line date (or this-type 'ut)) "\n")
3509           (point))
3510         (list 'original-date date 'gnus-date-type this-type))))
3511     ;; Do highlighting.
3512     (when (looking-at
3513            "\\([^:]+:\\)[\t ]*\\(\\(?:[^\t\n ]+[\t ]+\\)*[^\t\n ]+\\)?")
3514       (put-text-property (match-beginning 1) (match-end 1) 'face bface)
3515       (when (match-beginning 2)
3516         (put-text-property (match-beginning 2) (match-end 2) 'face eface))
3517       (while (and (zerop (forward-line 1))
3518                   (looking-at "[\t ]+\\(\\(?:[^\t\n ]+[\t ]+\\)*[^\t\n ]+\\)?"))
3519         (when (match-beginning 1)
3520           (put-text-property (match-beginning 1) (match-end 1) 'face eface))))))
3521
3522 (defun article-make-date-line (date type)
3523   "Return a DATE line of TYPE."
3524   (unless (memq type '(local ut original user-defined iso8601 lapsed english
3525                              combined-lapsed))
3526     (error "Unknown conversion type: %s" type))
3527   (condition-case ()
3528       (let ((time (ignore-errors (date-to-time date))))
3529         (cond
3530          ;; Convert to the local timezone.
3531          ((eq type 'local)
3532           (concat "Date: " (message-make-date time)))
3533          ;; Convert to Universal Time.
3534          ((eq type 'ut)
3535           (concat "Date: "
3536                   (substring
3537                    (message-make-date
3538                     (let* ((e (parse-time-string date))
3539                            (tm (apply 'encode-time e))
3540                            (ms (car tm))
3541                            (ls (- (cadr tm) (car (current-time-zone time)))))
3542                       (cond ((< ls 0) (list (1- ms) (+ ls 65536)))
3543                             ((> ls 65535) (list (1+ ms) (- ls 65536)))
3544                             (t (list ms ls)))))
3545                    0 -5)
3546                   "UT"))
3547          ;; Get the original date from the article.
3548          ((eq type 'original)
3549           (concat "Date: " (if (string-match "\n+$" date)
3550                                (substring date 0 (match-beginning 0))
3551                              date)))
3552          ;; Let the user define the format.
3553          ((eq type 'user-defined)
3554           (let ((format (or (condition-case nil
3555                                 (with-current-buffer gnus-summary-buffer
3556                                   gnus-article-time-format)
3557                               (error nil))
3558                             gnus-article-time-format)))
3559             (if (functionp format)
3560                 (funcall format time)
3561               (concat "Date: " (format-time-string format time)))))
3562          ;; ISO 8601.
3563          ((eq type 'iso8601)
3564           (let ((tz (car (current-time-zone time))))
3565             (concat
3566              "Date: "
3567              (format-time-string "%Y%m%dT%H%M%S" time)
3568              (format "%s%02d%02d"
3569                      (if (> tz 0) "+" "-") (/ (abs tz) 3600)
3570                      (/ (% (abs tz) 3600) 60)))))
3571          ;; Do a lapsed format.
3572          ((eq type 'lapsed)
3573           (concat "Date: " (article-lapsed-string time)))
3574          ;; A combined date/lapsed format.
3575          ((eq type 'combined-lapsed)
3576           (let ((date-string (article-make-date-line date 'original))
3577                 (segments 3)
3578                 lapsed-string)
3579             (while (and
3580