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