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