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