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