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