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