2001-06-13 Katsumi Yamaoka <yamaoka@jpl.org>
[gnus] / lisp / gnus-art.el
1 ;;; gnus-art.el --- article mode commands for Gnus
2 ;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001
3 ;;        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 2, or (at your option)
13 ;; 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; see the file COPYING.  If not, write to the
22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
23 ;; Boston, MA 02111-1307, USA.
24
25 ;;; Commentary:
26
27 ;;; Code:
28
29 (eval-when-compile (require 'cl))
30
31 (require 'gnus)
32 (require 'gnus-sum)
33 (require 'gnus-spec)
34 (require 'gnus-int)
35 (require 'mm-bodies)
36 (require 'mail-parse)
37 (require 'mm-decode)
38 (require 'mm-view)
39 (require 'wid-edit)
40 (require 'mm-uu)
41
42 (autoload 'gnus-msg-mail "gnus-msg" nil t)
43 (autoload 'gnus-button-mailto "gnus-msg")
44 (autoload 'gnus-button-reply "gnus-msg" nil t)
45
46 (defgroup gnus-article nil
47   "Article display."
48   :link '(custom-manual "(gnus)The Article Buffer")
49   :group 'gnus)
50
51 (defgroup gnus-article-treat nil
52   "Treating article parts."
53   :link '(custom-manual "(gnus)Article Hiding")
54   :group 'gnus-article)
55
56 (defgroup gnus-article-hiding nil
57   "Hiding article parts."
58   :link '(custom-manual "(gnus)Article Hiding")
59   :group 'gnus-article)
60
61 (defgroup gnus-article-highlight nil
62   "Article highlighting."
63   :link '(custom-manual "(gnus)Article Highlighting")
64   :group 'gnus-article
65   :group 'gnus-visual)
66
67 (defgroup gnus-article-signature nil
68   "Article signatures."
69   :link '(custom-manual "(gnus)Article Signature")
70   :group 'gnus-article)
71
72 (defgroup gnus-article-headers nil
73   "Article headers."
74   :link '(custom-manual "(gnus)Hiding Headers")
75   :group 'gnus-article)
76
77 (defgroup gnus-article-washing nil
78   "Special commands on articles."
79   :link '(custom-manual "(gnus)Article Washing")
80   :group 'gnus-article)
81
82 (defgroup gnus-article-emphasis nil
83   "Fontisizing articles."
84   :link '(custom-manual "(gnus)Article Fontisizing")
85   :group 'gnus-article)
86
87 (defgroup gnus-article-saving nil
88   "Saving articles."
89   :link '(custom-manual "(gnus)Saving Articles")
90   :group 'gnus-article)
91
92 (defgroup gnus-article-mime nil
93   "Worshiping the MIME wonder."
94   :link '(custom-manual "(gnus)Using MIME")
95   :group 'gnus-article)
96
97 (defgroup gnus-article-buttons nil
98   "Pushable buttons in the article buffer."
99   :link '(custom-manual "(gnus)Article Buttons")
100   :group 'gnus-article)
101
102 (defgroup gnus-article-various nil
103   "Other article options."
104   :link '(custom-manual "(gnus)Misc Article")
105   :group 'gnus-article)
106
107 (defcustom gnus-ignored-headers
108   '("^Path:" "^Expires:" "^Date-Received:" "^References:" "^Xref:" "^Lines:"
109     "^Relay-Version:" "^Message-ID:" "^Approved:" "^Sender:" "^Received:"
110     "^X-UIDL:" "^MIME-Version:" "^Return-Path:" "^In-Reply-To:"
111     "^Content-Type:" "^Content-Transfer-Encoding:" "^X-WebTV-Signature:"
112     "^X-MimeOLE:" "^X-MSMail-Priority:" "^X-Priority:" "^X-Loop:"
113     "^X-Authentication-Warning:" "^X-MIME-Autoconverted:" "^X-Face:"
114     "^X-Attribution:" "^X-Originating-IP:" "^Delivered-To:"
115     "^NNTP-[-A-Za-z]+:" "^Distribution:" "^X-no-archive:" "^X-Trace:"
116     "^X-Complaints-To:" "^X-NNTP-Posting-Host:" "^X-Orig.*:"
117     "^Abuse-Reports-To:" "^Cache-Post-Path:" "^X-Article-Creation-Date:"
118     "^X-Poster:" "^X-Mail2News-Path:" "^X-Server-Date:" "^X-Cache:"
119     "^Originator:" "^X-Problems-To:" "^X-Auth-User:" "^X-Post-Time:"
120     "^X-Admin:" "^X-UID:" "^Resent-[-A-Za-z]+:" "^X-Mailing-List:"
121     "^Precedence:" "^Original-[-A-Za-z]+:" "^X-filename:" "^X-Orcpt:"
122     "^Old-Received:" "^X-Pgp" "^X-Auth:" "^X-From-Line:"
123     "^X-Gnus-Article-Number:" "^X-Majordomo:" "^X-Url:" "^X-Sender:"
124     "^MBOX-Line" "^Priority:" "^X400-[-A-Za-z]+:"
125     "^Status:" "^X-Gnus-Mail-Source:" "^Cancel-Lock:"
126     "^X-FTN" "^X-EXP32-SerialNo:" "^Encoding:" "^Importance:"
127     "^Autoforwarded:" "^Original-Encoded-Information-Types:" "^X-Ya-Pop3:"
128     "^X-Face-Version:" "^X-Vms-To:" "^X-ML-NAME:" "^X-ML-COUNT:"
129     "^Mailing-List:" "^X-finfo:" "^X-md5sum:" "^X-md5sum-Origin:"
130     "^X-Sun-Charset:" "^X-Accept-Language:" "^X-Envelope-Sender:"
131     "^List-[A-Za-z]+:" "^X-Listprocessor-Version:"
132     "^X-Received:" "^X-Distribute:" "^X-Sequence:" "^X-Juno-Line-Breaks:"
133     "^X-Notes-Item:" "^X-MS-TNEF-Correlator:" "^x-uunet-gateway:"
134     "^X-Received:" "^Content-length:" "X-precedence:"
135     "^X-Authenticated-User:" "^X-Comment" "^X-Report:" "^X-Abuse-Info:"
136     "^X-HTTP-Proxy:" "^X-Mydeja-Info:" "^X-Copyright" "^X-No-Markup:"
137     "^X-Abuse-Info:")
138   "*All headers that start with this regexp will be hidden.
139 This variable can also be a list of regexps of headers to be ignored.
140 If `gnus-visible-headers' is non-nil, this variable will be ignored."
141   :type '(choice :custom-show nil
142                  regexp
143                  (repeat regexp))
144   :group 'gnus-article-hiding)
145
146 (defcustom gnus-visible-headers
147   "^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:\\|^X-Sent:"
148   "*All headers that do not match this regexp will be hidden.
149 This variable can also be a list of regexp of headers to remain visible.
150 If this variable is non-nil, `gnus-ignored-headers' will be ignored."
151   :type '(repeat :value-to-internal (lambda (widget value)
152                                       (custom-split-regexp-maybe value))
153                  :match (lambda (widget value)
154                           (or (stringp value)
155                               (widget-editable-list-match widget value)))
156                  regexp)
157   :group 'gnus-article-hiding)
158
159 (defcustom gnus-sorted-header-list
160   '("^From:" "^Subject:" "^Summary:" "^Keywords:" "^Newsgroups:"
161     "^Followup-To:" "^To:" "^Cc:" "^Date:" "^Organization:")
162   "*This variable is a list of regular expressions.
163 If it is non-nil, headers that match the regular expressions will
164 be placed first in the article buffer in the sequence specified by
165 this list."
166   :type '(repeat regexp)
167   :group 'gnus-article-hiding)
168
169 (defcustom gnus-boring-article-headers '(empty followup-to reply-to)
170   "Headers that are only to be displayed if they have interesting data.
171 Possible values in this list are `empty', `newsgroups', `followup-to',
172 `to-address', `reply-to', `date', `long-to', and `many-to'."
173   :type '(set (const :tag "Headers with no content." empty)
174               (const :tag "Newsgroups with only one group." newsgroups)
175               (const :tag "To identical to to-address." to-address)
176               (const :tag "Followup-to identical to newsgroups." followup-to)
177               (const :tag "Reply-to identical to from." reply-to)
178               (const :tag "Date less than four days old." date)
179               (const :tag "Very long To and/or Cc header." long-to)
180               (const :tag "Multiple To and/or Cc headers." many-to))
181   :group 'gnus-article-hiding)
182
183 (defcustom gnus-signature-separator '("^-- $" "^-- *$")
184   "Regexp matching signature separator.
185 This can also be a list of regexps.  In that case, it will be checked
186 from head to tail looking for a separator.  Searches will be done from
187 the end of the buffer."
188   :type '(repeat string)
189   :group 'gnus-article-signature)
190
191 (defcustom gnus-signature-limit nil
192   "Provide a limit to what is considered a signature.
193 If it is a number, no signature may not be longer (in characters) than
194 that number.  If it is a floating point number, no signature may be
195 longer (in lines) than that number.  If it is a function, the function
196 will be called without any parameters, and if it returns nil, there is
197 no signature in the buffer.  If it is a string, it will be used as a
198 regexp.  If it matches, the text in question is not a signature."
199   :type '(choice (integer :value 200)
200                  (number :value 4.0)
201                  (function :value fun)
202                  (regexp :value ".*"))
203   :group 'gnus-article-signature)
204
205 (defcustom gnus-hidden-properties '(invisible t intangible t)
206   "Property list to use for hiding text."
207   :type 'sexp
208   :group 'gnus-article-hiding)
209
210 ;; Fixme: This isn't the right thing for mixed graphical and and
211 ;; non-graphical frames in a session.
212 ;; gnus-xmas.el overrides this for XEmacs.
213 (defcustom gnus-article-x-face-command
214   (if (and (fboundp 'image-type-available-p)
215            (image-type-available-p 'xbm))
216       'gnus-article-display-xface
217     (if gnus-article-compface-xbm
218         "{ echo '/* Width=48, Height=48 */'; uncompface; } | display -"
219       "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | \
220 display -"))
221   "*String or function to be executed to display an X-Face header.
222 If it is a string, the command will be executed in a sub-shell
223 asynchronously.  The compressed face will be piped to this command."
224   :type '(choice string
225                  (function-item gnus-article-display-xface)
226                  function)
227   :version "21.1"
228   :group 'gnus-article-washing)
229
230 (defcustom gnus-article-x-face-too-ugly nil
231   "Regexp matching posters whose face shouldn't be shown automatically."
232   :type '(choice regexp (const nil))
233   :group 'gnus-article-washing)
234
235 (defcustom gnus-article-banner-alist nil
236   "Banner alist for stripping.
237 For example,
238      ((egroups . \"^[ \\t\\n]*-------------------+\\\\( \\\\(e\\\\|Yahoo! \\\\)Groups Sponsor -+\\\\)?....\\n\\\\(.+\\n\\\\)+\"))"
239   :version "21.1"
240   :type '(repeat (cons symbol regexp))
241   :group 'gnus-article-washing)
242
243 (gnus-define-group-parameter
244  banner
245  :variable-document
246  "Alist of regexps (to match group names) and banner."
247  :variable-group gnus-article-washing
248  :parameter-type
249  '(choice :tag "Banner"
250           :value nil
251           (const :tag "Remove signature" signature)
252           (symbol :tag "Item in `gnus-article-banner-alist'" none)
253           regexp
254           (const :tag "None" nil))
255  :parameter-document
256  "If non-nil, specify how to remove `banners' from articles.
257
258 Symbol `signature' means to remove signatures delimited by
259 `gnus-signature-separator'.  Any other symbol is used to look up a
260 regular expression to match the banner in `gnus-article-banner-alist'.
261 A string is used as a regular expression to match the banner
262 directly.")
263
264 (defcustom gnus-emphasis-alist
265   (let ((format
266          "\\(\\s-\\|^\\|[-\"]\\|\\s(\\)\\(%s\\(\\w+\\(\\s-+\\w+\\)*[.,]?\\)%s\\)\\(\\s-\\|[-,;:\"]\\s-\\|[?!.]+\\s-\\|\\s)\\)")
267         (types
268          '(("_" "_" underline)
269            ("/" "/" italic)
270            ("\\*" "\\*" bold)
271            ("_/" "/_" underline-italic)
272            ("_\\*" "\\*_" underline-bold)
273            ("\\*/" "/\\*" bold-italic)
274            ("_\\*/" "/\\*_" underline-bold-italic))))
275     `(("\\(\\s-\\|^\\)\\(_\\(\\(\\w\\|_[^_]\\)+\\)_\\)\\(\\s-\\|[?!.,;]\\)"
276        2 3 gnus-emphasis-underline)
277       ,@(mapcar
278          (lambda (spec)
279            (list
280             (format format (car spec) (cadr spec))
281             2 3 (intern (format "gnus-emphasis-%s" (nth 2 spec)))))
282          types)))
283   "*Alist that says how to fontify certain phrases.
284 Each item looks like this:
285
286   (\"_\\\\(\\\\w+\\\\)_\" 0 1 'underline)
287
288 The first element is a regular expression to be matched.  The second
289 is a number that says what regular expression grouping used to find
290 the entire emphasized word.  The third is a number that says what
291 regexp grouping should be displayed and highlighted.  The fourth
292 is the face used for highlighting."
293   :type '(repeat (list :value ("" 0 0 default)
294                        regexp
295                        (integer :tag "Match group")
296                        (integer :tag "Emphasize group")
297                        face))
298   :group 'gnus-article-emphasis)
299
300 (defcustom gnus-emphasize-whitespace-regexp "^[ \t]+\\|[ \t]*\n"
301   "A regexp to describe whitespace which should not be emphasized.
302 Typical values are \"^[ \\t]+\\\\|[ \\t]*\\n\" and \"[ \\t]+\\\\|[ \\t]*\\n\".
303 The former avoids underlining of leading and trailing whitespace,
304 and the latter avoids underlining any whitespace at all."
305   :version "21.1"
306   :group 'gnus-article-emphasis
307   :type 'regexp)
308
309 (defface gnus-emphasis-bold '((t (:bold t)))
310   "Face used for displaying strong emphasized text (*word*)."
311   :group 'gnus-article-emphasis)
312
313 (defface gnus-emphasis-italic '((t (:italic t)))
314   "Face used for displaying italic emphasized text (/word/)."
315   :group 'gnus-article-emphasis)
316
317 (defface gnus-emphasis-underline '((t (:underline t)))
318   "Face used for displaying underlined emphasized text (_word_)."
319   :group 'gnus-article-emphasis)
320
321 (defface gnus-emphasis-underline-bold '((t (:bold t :underline t)))
322   "Face used for displaying underlined bold emphasized text (_*word*_)."
323   :group 'gnus-article-emphasis)
324
325 (defface gnus-emphasis-underline-italic '((t (:italic t :underline t)))
326   "Face used for displaying underlined italic emphasized text (_/word/_)."
327   :group 'gnus-article-emphasis)
328
329 (defface gnus-emphasis-bold-italic '((t (:bold t :italic t)))
330   "Face used for displaying bold italic emphasized text (/*word*/)."
331   :group 'gnus-article-emphasis)
332
333 (defface gnus-emphasis-underline-bold-italic
334   '((t (:bold t :italic t :underline t)))
335   "Face used for displaying underlined bold italic emphasized text.
336 Esample: (_/*word*/_)."
337   :group 'gnus-article-emphasis)
338
339 (defface gnus-emphasis-highlight-words
340   '((t (:background "black" :foreground "yellow")))
341   "Face used for displaying highlighted words."
342   :group 'gnus-article-emphasis)
343
344 (defcustom gnus-article-time-format "%a, %b %d %Y %T %Z"
345   "Format for display of Date headers in article bodies.
346 See `format-time-string' for the possible values.
347
348 The variable can also be function, which should return a complete Date
349 header.  The function is called with one argument, the time, which can
350 be fed to `format-time-string'."
351   :type '(choice string symbol)
352   :link '(custom-manual "(gnus)Article Date")
353   :group 'gnus-article-washing)
354
355 (eval-and-compile
356   (autoload 'mail-extract-address-components "mail-extr"))
357
358 (defcustom gnus-save-all-headers t
359   "*If non-nil, don't remove any headers before saving."
360   :group 'gnus-article-saving
361   :type 'boolean)
362
363 (defcustom gnus-prompt-before-saving 'always
364   "*This variable says how much prompting is to be done when saving articles.
365 If it is nil, no prompting will be done, and the articles will be
366 saved to the default files.  If this variable is `always', each and
367 every article that is saved will be preceded by a prompt, even when
368 saving large batches of articles.  If this variable is neither nil not
369 `always', there the user will be prompted once for a file name for
370 each invocation of the saving commands."
371   :group 'gnus-article-saving
372   :type '(choice (item always)
373                  (item :tag "never" nil)
374                  (sexp :tag "once" :format "%t\n" :value t)))
375
376 (defcustom gnus-saved-headers gnus-visible-headers
377   "Headers to keep if `gnus-save-all-headers' is nil.
378 If `gnus-save-all-headers' is non-nil, this variable will be ignored.
379 If that variable is nil, however, all headers that match this regexp
380 will be kept while the rest will be deleted before saving."
381   :group 'gnus-article-saving
382   :type 'regexp)
383
384 (defcustom gnus-default-article-saver 'gnus-summary-save-in-rmail
385   "A function to save articles in your favourite format.
386 The function must be interactively callable (in other words, it must
387 be an Emacs command).
388
389 Gnus provides the following functions:
390
391 * gnus-summary-save-in-rmail (Rmail format)
392 * gnus-summary-save-in-mail (Unix mail format)
393 * gnus-summary-save-in-folder (MH folder)
394 * gnus-summary-save-in-file (article format)
395 * gnus-summary-save-in-vm (use VM's folder format)
396 * gnus-summary-write-to-file (article format -- overwrite)."
397   :group 'gnus-article-saving
398   :type '(radio (function-item gnus-summary-save-in-rmail)
399                 (function-item gnus-summary-save-in-mail)
400                 (function-item gnus-summary-save-in-folder)
401                 (function-item gnus-summary-save-in-file)
402                 (function-item gnus-summary-save-in-vm)
403                 (function-item gnus-summary-write-to-file)))
404
405 (defcustom gnus-rmail-save-name 'gnus-plain-save-name
406   "A function generating a file name to save articles in Rmail format.
407 The function is called with NEWSGROUP, HEADERS, and optional LAST-FILE."
408   :group 'gnus-article-saving
409   :type 'function)
410
411 (defcustom gnus-mail-save-name 'gnus-plain-save-name
412   "A function generating a file name to save articles in Unix mail format.
413 The function is called with NEWSGROUP, HEADERS, and optional LAST-FILE."
414   :group 'gnus-article-saving
415   :type 'function)
416
417 (defcustom gnus-folder-save-name 'gnus-folder-save-name
418   "A function generating a file name to save articles in MH folder.
419 The function is called with NEWSGROUP, HEADERS, and optional LAST-FOLDER."
420   :group 'gnus-article-saving
421   :type 'function)
422
423 (defcustom gnus-file-save-name 'gnus-numeric-save-name
424   "A function generating a file name to save articles in article format.
425 The function is called with NEWSGROUP, HEADERS, and optional
426 LAST-FILE."
427   :group 'gnus-article-saving
428   :type 'function)
429
430 (defcustom gnus-split-methods
431   '((gnus-article-archive-name)
432     (gnus-article-nndoc-name))
433   "*Variable used to suggest where articles are to be saved.
434 For instance, if you would like to save articles related to Gnus in
435 the file \"gnus-stuff\", and articles related to VM in \"vm-stuff\",
436 you could set this variable to something like:
437
438  '((\"^Subject:.*gnus\\|^Newsgroups:.*gnus\" \"gnus-stuff\")
439    (\"^Subject:.*vm\\|^Xref:.*vm\" \"vm-stuff\"))
440
441 This variable is an alist where the where the key is the match and the
442 value is a list of possible files to save in if the match is non-nil.
443
444 If the match is a string, it is used as a regexp match on the
445 article.  If the match is a symbol, that symbol will be funcalled
446 from the buffer of the article to be saved with the newsgroup as the
447 parameter.  If it is a list, it will be evaled in the same buffer.
448
449 If this form or function returns a string, this string will be used as
450 a possible file name; and if it returns a non-nil list, that list will
451 be used as possible file names."
452   :group 'gnus-article-saving
453   :type '(repeat (choice (list :value (fun) function)
454                          (cons :value ("" "") regexp (repeat string))
455                          (sexp :value nil))))
456
457 (defcustom gnus-page-delimiter "^\^L"
458   "*Regexp describing what to use as article page delimiters.
459 The default value is \"^\^L\", which is a form linefeed at the
460 beginning of a line."
461   :type 'regexp
462   :group 'gnus-article-various)
463
464 (defcustom gnus-article-mode-line-format "Gnus: %g [%w] %S%m"
465   "*The format specification for the article mode line.
466 See `gnus-summary-mode-line-format' for a closer description.
467
468 The following additional specs are available:
469
470 %w  The article washing status.
471 %m  The number of MIME parts in the article."
472   :type 'string
473   :group 'gnus-article-various)
474
475 (defcustom gnus-article-mode-hook nil
476   "*A hook for Gnus article mode."
477   :type 'hook
478   :group 'gnus-article-various)
479
480 (when (featurep 'xemacs)
481   ;; Extracted from gnus-xmas-define in order to preserve user settings
482   (when (fboundp 'turn-off-scroll-in-place)
483     (add-hook 'gnus-article-mode-hook 'turn-off-scroll-in-place))
484   ;; Extracted from gnus-xmas-redefine in order to preserve user settings
485   (add-hook 'gnus-article-mode-hook 'gnus-xmas-article-menu-add))
486
487 (defcustom gnus-article-menu-hook nil
488   "*Hook run after the creation of the article mode menu."
489   :type 'hook
490   :group 'gnus-article-various)
491
492 (defcustom gnus-article-prepare-hook nil
493   "*A hook called after an article has been prepared in the article buffer."
494   :type 'hook
495   :group 'gnus-article-various)
496
497 (defcustom gnus-article-hide-pgp-hook nil
498   "*A hook called after successfully hiding a PGP signature."
499   :type 'hook
500   :group 'gnus-article-various)
501
502 (defcustom gnus-article-button-face 'bold
503   "Face used for highlighting buttons in the article buffer.
504
505 An article button is a piece of text that you can activate by pressing
506 `RET' or `mouse-2' above it."
507   :type 'face
508   :group 'gnus-article-buttons)
509
510 (defcustom gnus-article-mouse-face 'highlight
511   "Face used for mouse highlighting in the article buffer.
512
513 Article buttons will be displayed in this face when the cursor is
514 above them."
515   :type 'face
516   :group 'gnus-article-buttons)
517
518 (defcustom gnus-signature-face 'gnus-signature-face
519   "Face used for highlighting a signature in the article buffer.
520 Obsolete; use the face `gnus-signature-face' for customizations instead."
521   :type 'face
522   :group 'gnus-article-highlight
523   :group 'gnus-article-signature)
524
525 (defface gnus-signature-face
526   '((t
527      (:italic t)))
528   "Face used for highlighting a signature in the article buffer."
529   :group 'gnus-article-highlight
530   :group 'gnus-article-signature)
531
532 (defface gnus-header-from-face
533   '((((class color)
534       (background dark))
535      (:foreground "spring green"))
536     (((class color)
537       (background light))
538      (:foreground "red3"))
539     (t
540      (:italic t)))
541   "Face used for displaying from headers."
542   :group 'gnus-article-headers
543   :group 'gnus-article-highlight)
544
545 (defface gnus-header-subject-face
546   '((((class color)
547       (background dark))
548      (:foreground "SeaGreen3"))
549     (((class color)
550       (background light))
551      (:foreground "red4"))
552     (t
553      (:bold t :italic t)))
554   "Face used for displaying subject headers."
555   :group 'gnus-article-headers
556   :group 'gnus-article-highlight)
557
558 (defface gnus-header-newsgroups-face
559   '((((class color)
560       (background dark))
561      (:foreground "yellow" :italic t))
562     (((class color)
563       (background light))
564      (:foreground "MidnightBlue" :italic t))
565     (t
566      (:italic t)))
567   "Face used for displaying newsgroups headers."
568   :group 'gnus-article-headers
569   :group 'gnus-article-highlight)
570
571 (defface gnus-header-name-face
572   '((((class color)
573       (background dark))
574      (:foreground "SeaGreen"))
575     (((class color)
576       (background light))
577      (:foreground "maroon"))
578     (t
579      (:bold t)))
580   "Face used for displaying header names."
581   :group 'gnus-article-headers
582   :group 'gnus-article-highlight)
583
584 (defface gnus-header-content-face
585   '((((class color)
586       (background dark))
587      (:foreground "forest green" :italic t))
588     (((class color)
589       (background light))
590      (:foreground "indianred4" :italic t))
591     (t
592      (:italic t)))  "Face used for displaying header content."
593   :group 'gnus-article-headers
594   :group 'gnus-article-highlight)
595
596 (defcustom gnus-header-face-alist
597   '(("From" nil gnus-header-from-face)
598     ("Subject" nil gnus-header-subject-face)
599     ("Newsgroups:.*," nil gnus-header-newsgroups-face)
600     ("" gnus-header-name-face gnus-header-content-face))
601   "*Controls highlighting of article header.
602
603 An alist of the form (HEADER NAME CONTENT).
604
605 HEADER is a regular expression which should match the name of an
606 header header and NAME and CONTENT are either face names or nil.
607
608 The name of each header field will be displayed using the face
609 specified by the first element in the list where HEADER match the
610 header name and NAME is non-nil.  Similarly, the content will be
611 displayed by the first non-nil matching CONTENT face."
612   :group 'gnus-article-headers
613   :group 'gnus-article-highlight
614   :type '(repeat (list (regexp :tag "Header")
615                        (choice :tag "Name"
616                                (item :tag "skip" nil)
617                                (face :value default))
618                        (choice :tag "Content"
619                                (item :tag "skip" nil)
620                                (face :value default)))))
621
622 (defcustom gnus-article-decode-hook
623   '(article-decode-charset article-decode-encoded-words)
624   "*Hook run to decode charsets in articles."
625   :group 'gnus-article-headers
626   :type 'hook)
627
628 (defcustom gnus-display-mime-function 'gnus-display-mime
629   "Function to display MIME articles."
630   :group 'gnus-article-mime
631   :type 'function)
632
633 (defvar gnus-decode-header-function 'mail-decode-encoded-word-region
634   "Function used to decode headers.")
635
636 (defvar gnus-article-dumbquotes-map
637   '(("\200" "EUR")
638     ("\202" ",")
639     ("\203" "f")
640     ("\204" ",,")
641     ("\205" "...")
642     ("\213" "<")
643     ("\214" "OE")
644     ("\221" "`")
645     ("\222" "'")
646     ("\223" "``")
647     ("\224" "\"")
648     ("\225" "*")
649     ("\226" "-")
650     ("\227" "--")
651     ("\231" "(TM)")
652     ("\233" ">")
653     ("\234" "oe")
654     ("\264" "'"))
655   "Table for MS-to-Latin1 translation.")
656
657 (defcustom gnus-ignored-mime-types nil
658   "List of MIME types that should be ignored by Gnus."
659   :version "21.1"
660   :group 'gnus-article-mime
661   :type '(repeat regexp))
662
663 (defcustom gnus-unbuttonized-mime-types '(".*/.*")
664   "List of MIME types that should not be given buttons when rendered inline."
665   :version "21.1"
666   :group 'gnus-article-mime
667   :type '(repeat regexp))
668
669 (defcustom gnus-article-mime-part-function nil
670   "Function called with a MIME handle as the argument.
671 This is meant for people who want to do something automatic based
672 on parts -- for instance, adding Vcard info to a database."
673   :group 'gnus-article-mime
674   :type 'function)
675
676 (defcustom gnus-mime-multipart-functions nil
677   "An alist of MIME types to functions to display them."
678   :version "21.1"
679   :group 'gnus-article-mime
680   :type 'alist)
681
682 (defcustom gnus-article-date-lapsed-new-header nil
683   "Whether the X-Sent and Date headers can coexist.
684 When using `gnus-treat-date-lapsed', the \"X-Sent:\" header will
685 either replace the old \"Date:\" header (if this variable is nil), or
686 be added below it (otherwise)."
687   :version "21.1"
688   :group 'gnus-article-headers
689   :type 'boolean)
690
691 (defcustom gnus-article-mime-match-handle-function 'undisplayed-alternative
692   "Function called with a MIME handle as the argument.
693 This is meant for people who want to view first matched part.
694 For `undisplayed-alternative' (default), the first undisplayed
695 part or alternative part is used.  For `undisplayed', the first
696 undisplayed part is used.  For a function, the first part which
697 the function return `t' is used.  For `nil', the first part is
698 used."
699   :version "21.1"
700   :group 'gnus-article-mime
701   :type '(choice
702           (item :tag "first" :value nil)
703           (item :tag "undisplayed" :value undisplayed)
704           (item :tag "undisplayed or alternative"
705                 :value undisplayed-alternative)
706           (function)))
707
708 (defcustom gnus-mime-action-alist
709   '(("save to file" . gnus-mime-save-part)
710     ("save and strip" . gnus-mime-save-part-and-strip)
711     ("display as text" . gnus-mime-inline-part)
712     ("view the part" . gnus-mime-view-part)
713     ("pipe to command" . gnus-mime-pipe-part)
714     ("toggle display" . gnus-article-press-button)
715     ("toggle display" . gnus-article-view-part-as-charset)
716     ("view as type" . gnus-mime-view-part-as-type)
717     ("internalize type" . gnus-mime-internalize-part)
718     ("externalize type" . gnus-mime-externalize-part))
719   "An alist of actions that run on the MIME attachment."
720   :group 'gnus-article-mime
721   :type '(repeat (cons (string :tag "name")
722                        (function))))
723
724 (defcustom gnus-mime-action-alist
725   '(("save to file" . gnus-mime-save-part)
726     ("display as text" . gnus-mime-inline-part)
727     ("view the part" . gnus-mime-view-part)
728     ("pipe to command" . gnus-mime-pipe-part)
729     ("toggle display" . gnus-article-press-button)
730     ("view as type" . gnus-mime-view-part-as-type)
731     ("internalize type" . gnus-mime-internalize-part)
732     ("externalize type" . gnus-mime-externalize-part))
733   "An alist of actions that run on the MIME attachment."
734   :version "21.1"
735   :group 'gnus-article-mime
736   :type '(repeat (cons (string :tag "name")
737                        (function))))
738
739 ;;;
740 ;;; The treatment variables
741 ;;;
742
743 (defvar gnus-part-display-hook nil
744   "Hook called on parts that are to receive treatment.")
745
746 (defvar gnus-article-treat-custom
747   '(choice (const :tag "Off" nil)
748            (const :tag "On" t)
749            (const :tag "Header" head)
750            (const :tag "Last" last)
751            (integer :tag "Less")
752            (repeat :tag "Groups" regexp)
753            (sexp :tag "Predicate")))
754
755 (defvar gnus-article-treat-head-custom
756   '(choice (const :tag "Off" nil)
757            (const :tag "Header" head)))
758
759 (defvar gnus-article-treat-types '("text/plain")
760   "Parts to treat.")
761
762 (defvar gnus-inhibit-treatment nil
763   "Whether to inhibit treatment.")
764
765 (defcustom gnus-treat-highlight-signature '(or last (typep "text/x-vcard"))
766   "Highlight the signature.
767 Valid values are nil, t, `head', `last', an integer or a predicate.
768 See the manual for details."
769   :group 'gnus-article-treat
770   :type gnus-article-treat-custom)
771 (put 'gnus-treat-highlight-signature 'highlight t)
772
773 (defcustom gnus-treat-buttonize 100000
774   "Add buttons.
775 Valid values are nil, t, `head', `last', an integer or a predicate.
776 See the manual for details."
777   :group 'gnus-article-treat
778   :type gnus-article-treat-custom)
779 (put 'gnus-treat-buttonize 'highlight t)
780
781 (defcustom gnus-treat-buttonize-head 'head
782   "Add buttons to the head.
783 Valid values are nil, t, `head', `last', an integer or a predicate.
784 See the manual for details."
785   :group 'gnus-article-treat
786   :type gnus-article-treat-head-custom)
787 (put 'gnus-treat-buttonize-head 'highlight t)
788
789 (defcustom gnus-treat-emphasize
790   (and (or window-system
791            (featurep 'xemacs)
792            (>= (string-to-number emacs-version) 21))
793        50000)
794   "Emphasize text.
795 Valid values are nil, t, `head', `last', an integer or a predicate.
796 See the manual for details."
797   :group 'gnus-article-treat
798   :type gnus-article-treat-custom)
799 (put 'gnus-treat-emphasize 'highlight t)
800
801 (defcustom gnus-treat-strip-cr nil
802   "Remove carriage returns.
803 Valid values are nil, t, `head', `last', an integer or a predicate.
804 See the manual for details."
805   :group 'gnus-article-treat
806   :type gnus-article-treat-custom)
807
808 (defcustom gnus-treat-leading-whitespace nil
809   "Remove leading whitespace in headers.
810 Valid values are nil, t, `head', `last', an integer or a predicate.
811 See the manual for details."
812   :group 'gnus-article-treat
813   :type gnus-article-treat-custom)
814
815 (defcustom gnus-treat-hide-headers 'head
816   "Hide headers.
817 Valid values are nil, t, `head', `last', an integer or a predicate.
818 See the manual for details."
819   :group 'gnus-article-treat
820   :type gnus-article-treat-head-custom)
821
822 (defcustom gnus-treat-hide-boring-headers nil
823   "Hide boring headers.
824 Valid values are nil, t, `head', `last', an integer or a predicate.
825 See the manual for details."
826   :group 'gnus-article-treat
827   :type gnus-article-treat-head-custom)
828
829 (defcustom gnus-treat-hide-signature nil
830   "Hide the signature.
831 Valid values are nil, t, `head', `last', an integer or a predicate.
832 See the manual for details."
833   :group 'gnus-article-treat
834   :type gnus-article-treat-custom)
835
836 (defcustom gnus-treat-fill-article nil
837   "Fill the article.
838 Valid values are nil, t, `head', `last', an integer or a predicate.
839 See the manual for details."
840   :group 'gnus-article-treat
841   :type gnus-article-treat-custom)
842
843 (defcustom gnus-treat-hide-citation nil
844   "Hide cited text.
845 Valid values are nil, t, `head', `last', an integer or a predicate.
846 See the manual for details."
847   :group 'gnus-article-treat
848   :type gnus-article-treat-custom)
849
850 (defcustom gnus-treat-hide-citation-maybe nil
851   "Hide cited text.
852 Valid values are nil, t, `head', `last', an integer or a predicate.
853 See the manual for details."
854   :group 'gnus-article-treat
855   :type gnus-article-treat-custom)
856
857 (defcustom gnus-treat-hide-citation-maybe nil
858   "Hide cited text.
859 Valid values are nil, t, `head', `last', an integer or a predicate.
860 See the manual for details."
861   :group 'gnus-article-treat
862   :type gnus-article-treat-custom)
863
864 (defcustom gnus-treat-strip-list-identifiers 'head
865   "Strip list identifiers from `gnus-list-identifiers`.
866 Valid values are nil, t, `head', `last', an integer or a predicate.
867 See the manual for details."
868   :version "21.1"
869   :group 'gnus-article-treat
870   :type gnus-article-treat-custom)
871
872 (defcustom gnus-treat-strip-pgp t
873   "Strip PGP signatures.
874 Valid values are nil, t, `head', `last', an integer or a predicate.
875 See the manual for details."
876   :group 'gnus-article-treat
877   :type gnus-article-treat-custom)
878
879 (defcustom gnus-treat-strip-pem nil
880   "Strip PEM signatures.
881 Valid values are nil, t, `head', `last', an integer or a predicate.
882 See the manual for details."
883   :group 'gnus-article-treat
884   :type gnus-article-treat-custom)
885
886 (defcustom gnus-treat-strip-banner t
887   "Strip banners from articles.
888 The banner to be stripped is specified in the `banner' group parameter.
889 Valid values are nil, t, `head', `last', an integer or a predicate.
890 See the manual for details."
891   :group 'gnus-article-treat
892   :type gnus-article-treat-custom)
893
894 (defcustom gnus-treat-highlight-headers 'head
895   "Highlight the headers.
896 Valid values are nil, t, `head', `last', an integer or a predicate.
897 See the manual for details."
898   :group 'gnus-article-treat
899   :type gnus-article-treat-head-custom)
900 (put 'gnus-treat-highlight-headers 'highlight t)
901
902 (defcustom gnus-treat-highlight-citation t
903   "Highlight cited text.
904 Valid values are nil, t, `head', `last', an integer or a predicate.
905 See the manual for details."
906   :group 'gnus-article-treat
907   :type gnus-article-treat-custom)
908 (put 'gnus-treat-highlight-citation 'highlight t)
909
910 (defcustom gnus-treat-date-ut nil
911   "Display the Date in UT (GMT).
912 Valid values are nil, t, `head', `last', an integer or a predicate.
913 See the manual for details."
914   :group 'gnus-article-treat
915   :type gnus-article-treat-head-custom)
916
917 (defcustom gnus-treat-date-local nil
918   "Display the Date in the local timezone.
919 Valid values are nil, t, `head', `last', an integer or a predicate.
920 See the manual for details."
921   :group 'gnus-article-treat
922   :type gnus-article-treat-head-custom)
923
924 (defcustom gnus-treat-date-english nil
925   "Display the Date in a format that can be read aloud in English.
926 Valid values are nil, t, `head', `last', an integer or a predicate.
927 See the manual for details."
928   :group 'gnus-article-treat
929   :type gnus-article-treat-head-custom)
930
931 (defcustom gnus-treat-date-lapsed nil
932   "Display the Date header in a way that says how much time has elapsed.
933 Valid values are nil, t, `head', `last', an integer or a predicate.
934 See the manual for details."
935   :group 'gnus-article-treat
936   :type gnus-article-treat-head-custom)
937
938 (defcustom gnus-treat-date-original nil
939   "Display the date in the original timezone.
940 Valid values are nil, t, `head', `last', an integer or a predicate.
941 See the manual for details."
942   :group 'gnus-article-treat
943   :type gnus-article-treat-head-custom)
944
945 (defcustom gnus-treat-date-iso8601 nil
946   "Display the date in the ISO8601 format.
947 Valid values are nil, t, `head', `last', an integer or a predicate.
948 See the manual for details."
949   :version "21.1"
950   :group 'gnus-article-treat
951   :type gnus-article-treat-head-custom)
952
953 (defcustom gnus-treat-date-user-defined nil
954   "Display the date in a user-defined format.
955 The format is defined by the `gnus-article-time-format' variable.
956 Valid values are nil, t, `head', `last', an integer or a predicate.
957 See the manual for details."
958   :group 'gnus-article-treat
959   :type gnus-article-treat-head-custom)
960
961 (defcustom gnus-treat-strip-headers-in-body t
962   "Strip the X-No-Archive header line from the beginning of the body.
963 Valid values are nil, t, `head', `last', an integer or a predicate.
964 See the manual for details."
965   :version "21.1"
966   :group 'gnus-article-treat
967   :type gnus-article-treat-custom)
968
969 (defcustom gnus-treat-strip-trailing-blank-lines nil
970   "Strip trailing blank lines.
971 Valid values are nil, t, `head', `last', an integer or a predicate.
972 See the manual for details."
973   :group 'gnus-article-treat
974   :type gnus-article-treat-custom)
975
976 (defcustom gnus-treat-strip-leading-blank-lines nil
977   "Strip leading blank lines.
978 Valid values are nil, t, `head', `last', an integer or a predicate.
979 See the manual for details."
980   :group 'gnus-article-treat
981   :type gnus-article-treat-custom)
982
983 (defcustom gnus-treat-strip-multiple-blank-lines nil
984   "Strip multiple blank lines.
985 Valid values are nil, t, `head', `last', an integer or a predicate.
986 See the manual for details."
987   :group 'gnus-article-treat
988   :type gnus-article-treat-custom)
989
990 (defcustom gnus-treat-overstrike t
991   "Treat overstrike highlighting.
992 Valid values are nil, t, `head', `last', an integer or a predicate.
993 See the manual for details."
994   :group 'gnus-article-treat
995   :type gnus-article-treat-custom)
996 (put 'gnus-treat-overstrike 'highlight t)
997
998 (defcustom gnus-treat-display-xface
999   (and (or (and (fboundp 'image-type-available-p)
1000                 (image-type-available-p 'xbm)
1001                 (string-match "^0x" (shell-command-to-string "uncompface")))
1002            (and (featurep 'xemacs) (featurep 'xface)))
1003        'head)
1004   "Display X-Face headers.
1005 Valid values are nil, t, `head', `last', an integer or a predicate.
1006 See the manual for details."
1007   :group 'gnus-article-treat
1008   :version "21.1"
1009   :type gnus-article-treat-head-custom)
1010 (put 'gnus-treat-display-xface 'highlight t)
1011
1012 (defcustom gnus-treat-display-smileys
1013   (if (or (and (featurep 'xemacs)
1014                (featurep 'xpm))
1015           (and (fboundp 'image-type-available-p)
1016                (image-type-available-p 'pbm)))
1017       t nil)
1018   "Display smileys.
1019 Valid values are nil, t, `head', `last', an integer or a predicate.
1020 See the manual for details."
1021   :group 'gnus-article-treat
1022   :version "21.1"
1023   :type gnus-article-treat-custom)
1024 (put 'gnus-treat-display-smileys 'highlight t)
1025
1026 (defcustom gnus-treat-display-picons (if (featurep 'xemacs) 'head nil)
1027   "Display picons.
1028 Valid values are nil, t, `head', `last', an integer or a predicate.
1029 See the manual for details."
1030   :group 'gnus-article-treat
1031   :type gnus-article-treat-head-custom)
1032 (put 'gnus-treat-display-picons 'highlight t)
1033
1034 (defcustom gnus-treat-capitalize-sentences nil
1035   "Capitalize sentence-starting words.
1036 Valid values are nil, t, `head', `last', an integer or a predicate.
1037 See the manual for details."
1038   :version "21.1"
1039   :group 'gnus-article-treat
1040   :type gnus-article-treat-custom)
1041
1042 (defcustom gnus-treat-fill-long-lines nil
1043   "Fill long lines.
1044 Valid values are nil, t, `head', `last', an integer or a predicate.
1045 See the manual for details."
1046   :group 'gnus-article-treat
1047   :type gnus-article-treat-custom)
1048
1049 (defcustom gnus-treat-play-sounds nil
1050   "Play sounds.
1051 Valid values are nil, t, `head', `last', an integer or a predicate.
1052 See the manual for details."
1053   :version "21.1"
1054   :group 'gnus-article-treat
1055   :type gnus-article-treat-custom)
1056
1057 (defcustom gnus-treat-translate nil
1058   "Translate articles from one language to another.
1059 Valid values are nil, t, `head', `last', an integer or a predicate.
1060 See the manual for details."
1061   :version "21.1"
1062   :group 'gnus-article-treat
1063   :type gnus-article-treat-custom)
1064
1065 (defcustom gnus-treat-x-pgp-sig nil
1066   "Verify X-PGP-Sig.
1067 To automatically treat X-PGP-Sig, set it to head.
1068 Valid values are nil, t, `head', `last', an integer or a predicate.
1069 See the manual for details."
1070   :group 'gnus-article-treat
1071   :group 'mime-security
1072   :type gnus-article-treat-custom)
1073
1074 (defvar gnus-article-encrypt-protocol-alist
1075   '(("PGP" . mml2015-self-encrypt)))
1076
1077 ;; Set to nil if more than one protocol added to
1078 ;; gnus-article-encrypt-protocol-alist.
1079 (defcustom gnus-article-encrypt-protocol "PGP"
1080   "The protocol used for encrypt articles.
1081 It is a string, such as \"PGP\". If nil, ask user."
1082   :type 'string
1083   :group 'mime-security)
1084
1085 ;;; Internal variables
1086
1087 (defvar gnus-english-month-names
1088   '("January" "February" "March" "April" "May" "June" "July" "August"
1089     "September" "October" "November" "December"))
1090
1091 (defvar article-goto-body-goes-to-point-min-p nil)
1092 (defvar gnus-article-wash-types nil)
1093 (defvar gnus-article-emphasis-alist nil)
1094
1095 (defvar gnus-article-mime-handle-alist-1 nil)
1096 (defvar gnus-treatment-function-alist
1097   '((gnus-treat-x-pgp-sig gnus-article-verify-x-pgp-sig)
1098     (gnus-treat-strip-banner gnus-article-strip-banner)
1099     (gnus-treat-strip-headers-in-body gnus-article-strip-headers-in-body)
1100     (gnus-treat-highlight-signature gnus-article-highlight-signature)
1101     (gnus-treat-buttonize gnus-article-add-buttons)
1102     (gnus-treat-fill-article gnus-article-fill-cited-article)
1103     (gnus-treat-fill-long-lines gnus-article-fill-long-lines)
1104     (gnus-treat-strip-cr gnus-article-remove-cr)
1105     (gnus-treat-emphasize gnus-article-emphasize)
1106     (gnus-treat-display-xface gnus-article-display-x-face)
1107     (gnus-treat-date-ut gnus-article-date-ut)
1108     (gnus-treat-date-local gnus-article-date-local)
1109     (gnus-treat-date-english gnus-article-date-english)
1110     (gnus-treat-date-lapsed gnus-article-date-lapsed)
1111     (gnus-treat-date-original gnus-article-date-original)
1112     (gnus-treat-date-user-defined gnus-article-date-user)
1113     (gnus-treat-date-iso8601 gnus-article-date-iso8601)
1114     (gnus-treat-hide-headers gnus-article-maybe-hide-headers)
1115     (gnus-treat-hide-boring-headers gnus-article-hide-boring-headers)
1116     (gnus-treat-hide-signature gnus-article-hide-signature)
1117     (gnus-treat-hide-citation gnus-article-hide-citation)
1118     (gnus-treat-hide-citation-maybe gnus-article-hide-citation-maybe)
1119     (gnus-treat-strip-list-identifiers gnus-article-hide-list-identifiers)
1120     (gnus-treat-leading-whitespace gnus-article-remove-leading-whitespace)
1121     (gnus-treat-strip-pgp gnus-article-hide-pgp)
1122     (gnus-treat-strip-pem gnus-article-hide-pem)
1123     (gnus-treat-highlight-headers gnus-article-highlight-headers)
1124     (gnus-treat-highlight-citation gnus-article-highlight-citation)
1125     (gnus-treat-highlight-signature gnus-article-highlight-signature)
1126     (gnus-treat-strip-trailing-blank-lines
1127      gnus-article-remove-trailing-blank-lines)
1128     (gnus-treat-strip-leading-blank-lines
1129      gnus-article-strip-leading-blank-lines)
1130     (gnus-treat-strip-multiple-blank-lines
1131      gnus-article-strip-multiple-blank-lines)
1132     (gnus-treat-overstrike gnus-article-treat-overstrike)
1133     (gnus-treat-buttonize-head gnus-article-add-buttons-to-head)
1134     (gnus-treat-display-smileys gnus-smiley-display)
1135     (gnus-treat-capitalize-sentences gnus-article-capitalize-sentences)
1136     (gnus-treat-display-picons gnus-article-display-picons)
1137     (gnus-treat-play-sounds gnus-earcon-display)))
1138
1139 (defvar gnus-article-mime-handle-alist nil)
1140 (defvar article-lapsed-timer nil)
1141 (defvar gnus-article-current-summary nil)
1142
1143 (defvar gnus-article-mode-syntax-table
1144   (let ((table (copy-syntax-table text-mode-syntax-table)))
1145     ;; This causes the citation match run O(2^n).
1146     ;; (modify-syntax-entry ?- "w" table)
1147     (modify-syntax-entry ?> ")" table)
1148     (modify-syntax-entry ?< "(" table)
1149     table)
1150   "Syntax table used in article mode buffers.
1151 Initialized from `text-mode-syntax-table.")
1152
1153 (defvar gnus-save-article-buffer nil)
1154
1155 (defvar gnus-article-mode-line-format-alist
1156   (nconc '((?w (gnus-article-wash-status) ?s)
1157            (?m (gnus-article-mime-part-status) ?s))
1158          gnus-summary-mode-line-format-alist))
1159
1160 (defvar gnus-number-of-articles-to-be-saved nil)
1161
1162 (defvar gnus-inhibit-hiding nil)
1163
1164 (defsubst gnus-article-hide-text (b e props)
1165   "Set text PROPS on the B to E region, extending `intangible' 1 past B."
1166   (gnus-add-text-properties-when 'article-type nil b e props)
1167   (when (memq 'intangible props)
1168     (put-text-property
1169      (max (1- b) (point-min))
1170      b 'intangible (cddr (memq 'intangible props)))))
1171
1172 (defsubst gnus-article-unhide-text (b e)
1173   "Remove hidden text properties from region between B and E."
1174   (remove-text-properties b e gnus-hidden-properties)
1175   (when (memq 'intangible gnus-hidden-properties)
1176     (put-text-property (max (1- b) (point-min))
1177                        b 'intangible nil)))
1178
1179 (defun gnus-article-hide-text-type (b e type)
1180   "Hide text of TYPE between B and E."
1181   (push type gnus-article-wash-types)
1182   (gnus-article-hide-text
1183    b e (cons 'article-type (cons type gnus-hidden-properties))))
1184
1185 (defun gnus-article-unhide-text-type (b e type)
1186   "Unhide text of TYPE between B and E."
1187   (setq gnus-article-wash-types
1188         (delq type gnus-article-wash-types))
1189   (remove-text-properties
1190    b e (cons 'article-type (cons type gnus-hidden-properties)))
1191   (when (memq 'intangible gnus-hidden-properties)
1192     (put-text-property (max (1- b) (point-min))
1193                        b 'intangible nil)))
1194
1195 (defun gnus-article-hide-text-of-type (type)
1196   "Hide text of TYPE in the current buffer."
1197   (save-excursion
1198     (let ((b (point-min))
1199           (e (point-max)))
1200       (while (setq b (text-property-any b e 'article-type type))
1201         (add-text-properties b (incf b) gnus-hidden-properties)))))
1202
1203 (defun gnus-article-delete-text-of-type (type)
1204   "Delete text of TYPE in the current buffer."
1205   (save-excursion
1206     (let ((b (point-min)))
1207       (while (setq b (text-property-any b (point-max) 'article-type type))
1208         (delete-region
1209          b (or (text-property-not-all b (point-max) 'article-type type)
1210                (point-max)))))))
1211
1212 (defun gnus-article-delete-invisible-text ()
1213   "Delete all invisible text in the current buffer."
1214   (save-excursion
1215     (let ((b (point-min)))
1216       (while (setq b (text-property-any b (point-max) 'invisible t))
1217         (delete-region
1218          b (or (text-property-not-all b (point-max) 'invisible t)
1219                (point-max)))))))
1220
1221 (defun gnus-article-text-type-exists-p (type)
1222   "Say whether any text of type TYPE exists in the buffer."
1223   (text-property-any (point-min) (point-max) 'article-type type))
1224
1225 (defsubst gnus-article-header-rank ()
1226   "Give the rank of the string HEADER as given by `gnus-sorted-header-list'."
1227   (let ((list gnus-sorted-header-list)
1228         (i 0))
1229     (while list
1230       (when (looking-at (car list))
1231         (setq list nil))
1232       (setq list (cdr list))
1233       (incf i))
1234     i))
1235
1236 (defun article-hide-headers (&optional arg delete)
1237   "Hide unwanted headers and possibly sort them as well."
1238   (interactive)
1239   ;; This function might be inhibited.
1240   (unless gnus-inhibit-hiding
1241     (save-excursion
1242       (save-restriction
1243         (let ((buffer-read-only nil)
1244               (case-fold-search t)
1245               (max (1+ (length gnus-sorted-header-list)))
1246               (ignored (when (not gnus-visible-headers)
1247                          (cond ((stringp gnus-ignored-headers)
1248                                 gnus-ignored-headers)
1249                                ((listp gnus-ignored-headers)
1250                                 (mapconcat 'identity gnus-ignored-headers
1251                                            "\\|")))))
1252               (visible
1253                (cond ((stringp gnus-visible-headers)
1254                       gnus-visible-headers)
1255                      ((and gnus-visible-headers
1256                            (listp gnus-visible-headers))
1257                       (mapconcat 'identity gnus-visible-headers "\\|"))))
1258               (inhibit-point-motion-hooks t)
1259               beg)
1260           ;; First we narrow to just the headers.
1261           (article-narrow-to-head)
1262           ;; Hide any "From " lines at the beginning of (mail) articles.
1263           (while (looking-at "From ")
1264             (forward-line 1))
1265           (unless (bobp)
1266             (delete-region (point-min) (point)))
1267           ;; Then treat the rest of the header lines.
1268           ;; Then we use the two regular expressions
1269           ;; `gnus-ignored-headers' and `gnus-visible-headers' to
1270           ;; select which header lines is to remain visible in the
1271           ;; article buffer.
1272           (while (re-search-forward "^[^ \t]*:" nil t)
1273             (beginning-of-line)
1274             ;; Mark the rank of the header.
1275             (put-text-property
1276              (point) (1+ (point)) 'message-rank
1277              (if (or (and visible (looking-at visible))
1278                      (and ignored
1279                           (not (looking-at ignored))))
1280                  (gnus-article-header-rank)
1281                (+ 2 max)))
1282             (forward-line 1))
1283           (message-sort-headers-1)
1284           (when (setq beg (text-property-any
1285                            (point-min) (point-max) 'message-rank (+ 2 max)))
1286             ;; We delete the unwanted headers.
1287             (push 'headers gnus-article-wash-types)
1288             (add-text-properties (point-min) (+ 5 (point-min))
1289                                  '(article-type headers dummy-invisible t))
1290             (delete-region beg (point-max))))))))
1291
1292 (defun article-hide-boring-headers (&optional arg)
1293   "Toggle hiding of headers that aren't very interesting.
1294 If given a negative prefix, always show; if given a positive prefix,
1295 always hide."
1296   (interactive (gnus-article-hidden-arg))
1297   (when (and (not (gnus-article-check-hidden-text 'boring-headers arg))
1298              (not gnus-show-all-headers))
1299     (save-excursion
1300       (save-restriction
1301         (let ((buffer-read-only nil)
1302               (list gnus-boring-article-headers)
1303               (inhibit-point-motion-hooks t)
1304               elem)
1305           (article-narrow-to-head)
1306           (while list
1307             (setq elem (pop list))
1308             (goto-char (point-min))
1309             (cond
1310              ;; Hide empty headers.
1311              ((eq elem 'empty)
1312               (while (re-search-forward "^[^: \t]+:[ \t]*\n[^ \t]" nil t)
1313                 (forward-line -1)
1314                 (gnus-article-hide-text-type
1315                  (progn (beginning-of-line) (point))
1316                  (progn
1317                    (end-of-line)
1318                    (if (re-search-forward "^[^ \t]" nil t)
1319                        (match-beginning 0)
1320                      (point-max)))
1321                  'boring-headers)))
1322              ;; Hide boring Newsgroups header.
1323              ((eq elem 'newsgroups)
1324               (when (gnus-string-equal
1325                      (gnus-fetch-field "newsgroups")
1326                      (gnus-group-real-name
1327                       (if (boundp 'gnus-newsgroup-name)
1328                           gnus-newsgroup-name
1329                         "")))
1330                 (gnus-article-hide-header "newsgroups")))
1331              ((eq elem 'to-address)
1332               (let ((to (message-fetch-field "to"))
1333                     (to-address
1334                      (gnus-parameter-to-address
1335                       (if (boundp 'gnus-newsgroup-name)
1336                           gnus-newsgroup-name ""))))
1337                 (when (and to to-address
1338                            (ignore-errors
1339                              (gnus-string-equal
1340                               ;; only one address in To
1341                               (nth 1 (mail-extract-address-components to))
1342                               to-address)))
1343                   (gnus-article-hide-header "to"))))
1344              ((eq elem 'followup-to)
1345               (when (gnus-string-equal
1346                      (message-fetch-field "followup-to")
1347                      (message-fetch-field "newsgroups"))
1348                 (gnus-article-hide-header "followup-to")))
1349              ((eq elem 'reply-to)
1350               (let ((from (message-fetch-field "from"))
1351                     (reply-to (message-fetch-field "reply-to")))
1352                 (when (and
1353                        from reply-to
1354                        (ignore-errors
1355                          (gnus-string-equal
1356                           (nth 1 (mail-extract-address-components from))
1357                           (nth 1 (mail-extract-address-components reply-to)))))
1358                   (gnus-article-hide-header "reply-to"))))
1359              ((eq elem 'date)
1360               (let ((date (message-fetch-field "date")))
1361                 (when (and date
1362                            (< (days-between (current-time-string) date)
1363                               4))
1364                   (gnus-article-hide-header "date"))))
1365              ((eq elem 'long-to)
1366               (let ((to (message-fetch-field "to"))
1367                     (cc (message-fetch-field "cc")))
1368                 (when (> (length to) 1024)
1369                   (gnus-article-hide-header "to"))
1370                 (when (> (length cc) 1024)
1371                   (gnus-article-hide-header "cc"))))
1372              ((eq elem 'many-to)
1373               (let ((to-count 0)
1374                     (cc-count 0))
1375                 (goto-char (point-min))
1376                 (while (re-search-forward "^to:" nil t)
1377                   (setq to-count (1+ to-count)))
1378                 (when (> to-count 1)
1379                   (while (> to-count 0)
1380                     (goto-char (point-min))
1381                     (save-restriction
1382                       (re-search-forward "^to:" nil nil to-count)
1383                       (forward-line -1)
1384                       (narrow-to-region (point) (point-max))
1385                       (gnus-article-hide-header "to"))
1386                     (setq to-count (1- to-count))))
1387                 (goto-char (point-min))
1388                 (while (re-search-forward "^cc:" nil t)
1389                   (setq cc-count (1+ cc-count)))
1390                 (when (> cc-count 1)
1391                   (while (> cc-count 0)
1392                     (goto-char (point-min))
1393                     (save-restriction
1394                       (re-search-forward "^cc:" nil nil cc-count)
1395                       (forward-line -1)
1396                       (narrow-to-region (point) (point-max))
1397                       (gnus-article-hide-header "cc"))
1398                     (setq cc-count (1- cc-count)))))))))))))
1399
1400 (defun gnus-article-hide-header (header)
1401   (save-excursion
1402     (goto-char (point-min))
1403     (when (re-search-forward (concat "^" header ":") nil t)
1404       (gnus-article-hide-text-type
1405        (progn (beginning-of-line) (point))
1406        (progn
1407          (end-of-line)
1408          (if (re-search-forward "^[^ \t]" nil t)
1409              (match-beginning 0)
1410            (point-max)))
1411        'boring-headers))))
1412
1413 (defvar gnus-article-normalized-header-length 40
1414   "Length of normalized headers.")
1415
1416 (defun article-normalize-headers ()
1417   "Make all header lines 40 characters long."
1418   (interactive)
1419   (let ((buffer-read-only nil)
1420         column)
1421     (save-excursion
1422       (save-restriction
1423         (article-narrow-to-head)
1424         (while (not (eobp))
1425           (cond
1426            ((< (setq column (- (gnus-point-at-eol) (point)))
1427                gnus-article-normalized-header-length)
1428             (end-of-line)
1429             (insert (make-string
1430                      (- gnus-article-normalized-header-length column)
1431                      ? )))
1432            ((> column gnus-article-normalized-header-length)
1433             (gnus-put-text-property
1434              (progn
1435                (forward-char gnus-article-normalized-header-length)
1436                (point))
1437              (gnus-point-at-eol)
1438              'invisible t))
1439            (t
1440             ;; Do nothing.
1441             ))
1442           (forward-line 1))))))
1443
1444 (defun article-treat-dumbquotes ()
1445   "Translate M****s*** sm*rtq**t*s into proper text.
1446 Note that this function guesses whether a character is a sm*rtq**t* or
1447 not, so it should only be used interactively.
1448
1449 Sm*rtq**t*s are M****s***'s unilateral extension to the character map
1450 in an attempt to provide more quoting characters.  If you see
1451 something like \\222 or \\264 where you're expecting some kind of
1452 apostrophe or quotation mark, then try this wash."
1453   (interactive)
1454   (article-translate-strings gnus-article-dumbquotes-map))
1455
1456 (defun article-translate-characters (from to)
1457   "Translate all characters in the body of the article according to FROM and TO.
1458 FROM is a string of characters to translate from; to is a string of
1459 characters to translate to."
1460   (save-excursion
1461     (when (article-goto-body)
1462       (let ((buffer-read-only nil)
1463             (x (make-string 225 ?x))
1464             (i -1))
1465         (while (< (incf i) (length x))
1466           (aset x i i))
1467         (setq i 0)
1468         (while (< i (length from))
1469           (aset x (aref from i) (aref to i))
1470           (incf i))
1471         (translate-region (point) (point-max) x)))))
1472
1473 (defun article-translate-strings (map)
1474   "Translate all string in the body of the article according to MAP.
1475 MAP is an alist where the elements are on the form (\"from\" \"to\")."
1476   (save-excursion
1477     (when (article-goto-body)
1478       (let ((buffer-read-only nil)
1479             elem)
1480         (while (setq elem (pop map))
1481           (save-excursion
1482             (while (search-forward (car elem) nil t)
1483               (replace-match (cadr elem)))))))))
1484
1485 (defun article-treat-overstrike ()
1486   "Translate overstrikes into bold text."
1487   (interactive)
1488   (save-excursion
1489     (when (article-goto-body)
1490       (let ((buffer-read-only nil))
1491         (while (search-forward "\b" nil t)
1492           (let ((next (char-after))
1493                 (previous (char-after (- (point) 2))))
1494             ;; We do the boldification/underlining by hiding the
1495             ;; overstrikes and putting the proper text property
1496             ;; on the letters.
1497             (cond
1498              ((eq next previous)
1499               (gnus-article-hide-text-type (- (point) 2) (point) 'overstrike)
1500               (put-text-property (point) (1+ (point)) 'face 'bold))
1501              ((eq next ?_)
1502               (gnus-article-hide-text-type
1503                (1- (point)) (1+ (point)) 'overstrike)
1504               (put-text-property
1505                (- (point) 2) (1- (point)) 'face 'underline))
1506              ((eq previous ?_)
1507               (gnus-article-hide-text-type (- (point) 2) (point) 'overstrike)
1508               (put-text-property
1509                (point) (1+ (point)) 'face 'underline)))))))))
1510
1511 (defun article-fill-long-lines ()
1512   "Fill lines that are wider than the window width."
1513   (interactive)
1514   (save-excursion
1515     (let ((buffer-read-only nil)
1516           (width (window-width (get-buffer-window (current-buffer)))))
1517       (save-restriction
1518         (article-goto-body)
1519         (let ((adaptive-fill-mode nil))
1520           (while (not (eobp))
1521             (end-of-line)
1522             (when (>= (current-column) (min fill-column width))
1523               (narrow-to-region (point) (gnus-point-at-bol))
1524               (fill-paragraph nil)
1525               (goto-char (point-max))
1526               (widen))
1527             (forward-line 1)))))))
1528
1529 (defun article-capitalize-sentences ()
1530   "Capitalize the first word in each sentence."
1531   (interactive)
1532   (save-excursion
1533     (let ((buffer-read-only nil)
1534           (paragraph-start "^[\n\^L]"))
1535       (article-goto-body)
1536       (while (not (eobp))
1537         (capitalize-word 1)
1538         (forward-sentence)))))
1539
1540 (defun article-remove-cr ()
1541   "Remove trailing CRs and then translate remaining CRs into LFs."
1542   (interactive)
1543   (save-excursion
1544     (let ((buffer-read-only nil))
1545       (goto-char (point-min))
1546       (while (re-search-forward "\r+$" nil t)
1547         (replace-match "" t t))
1548       (goto-char (point-min))
1549       (while (search-forward "\r" nil t)
1550         (replace-match "\n" t t)))))
1551
1552 (defun article-remove-trailing-blank-lines ()
1553   "Remove all trailing blank lines from the article."
1554   (interactive)
1555   (save-excursion
1556     (let ((buffer-read-only nil))
1557       (goto-char (point-max))
1558       (delete-region
1559        (point)
1560        (progn
1561          (while (and (not (bobp))
1562                      (looking-at "^[ \t]*$")
1563                      (not (gnus-annotation-in-region-p
1564                            (point) (gnus-point-at-eol))))
1565            (forward-line -1))
1566          (forward-line 1)
1567          (point))))))
1568
1569 (defun article-display-x-face (&optional force)
1570   "Look for an X-Face header and display it if present."
1571   (interactive (list 'force))
1572   (save-excursion
1573     ;; Delete the old process, if any.
1574     (when (process-status "article-x-face")
1575       (delete-process "article-x-face"))
1576     (let ((inhibit-point-motion-hooks t)
1577           x-faces
1578           (case-fold-search t)
1579           from last)
1580       (save-restriction
1581         (article-narrow-to-head)
1582         (when (and buffer-read-only ;; When type `W f'
1583                    (progn
1584                      (goto-char (point-min))
1585                      (not (re-search-forward "^X-Face:[\t ]*" nil t)))
1586                    (gnus-buffer-live-p gnus-original-article-buffer))
1587           (with-current-buffer gnus-original-article-buffer
1588             (save-restriction
1589               (article-narrow-to-head)
1590               (while (re-search-forward "^X-Face:" nil t)
1591                 (setq x-faces
1592                       (concat
1593                        (or x-faces "")
1594                        (buffer-substring
1595                         (match-beginning 0)
1596                         (1- (re-search-forward
1597                              "^\\($\\|[^ \t]\\)" nil t))))))))
1598           (if x-faces
1599               (let (point start bface eface buffer-read-only)
1600                 (goto-char (point-max))
1601                 (forward-line -1)
1602                 (setq bface (get-text-property (gnus-point-at-bol) 'face)
1603                       eface (get-text-property (1- (gnus-point-at-eol)) 'face))
1604                 (goto-char (point-max))
1605                 (setq point (point))
1606                 (insert x-faces)
1607                 (goto-char point)
1608                 (while (looking-at "\\([^:]+\\): *")
1609                   (put-text-property (match-beginning 1) (1+ (match-end 1))
1610                                      'face bface)
1611                   (setq start (match-end 0))
1612                   (forward-line 1)
1613                   (while (looking-at "[\t ]")
1614                     (forward-line 1))
1615                   (put-text-property start (point)
1616                                      'face eface)))))
1617         (goto-char (point-min))
1618         (setq from (message-fetch-field "from"))
1619         (goto-char (point-min))
1620         (while (and gnus-article-x-face-command
1621                     (not last)
1622                     (or force
1623                         ;; Check whether this face is censored.
1624                         (not gnus-article-x-face-too-ugly)
1625                         (and gnus-article-x-face-too-ugly from
1626                              (not (string-match gnus-article-x-face-too-ugly
1627                                                 from))))
1628                     ;; Has to be present.
1629                     (re-search-forward "^X-Face:[\t ]*" nil t))
1630           ;; This used to try to do multiple faces (`while' instead of
1631           ;; `when' above), but (a) sending multiple EOFs to xv doesn't
1632           ;; work (b) it can crash some versions of Emacs (c) are
1633           ;; multiple faces really something to encourage?
1634           (when (stringp gnus-article-x-face-command)
1635             (setq last t))
1636           ;; We now have the area of the buffer where the X-Face is stored.
1637           (save-excursion
1638             (let ((beg (point))
1639                   (end (1- (re-search-forward "^\\($\\|[^ \t]\\)" nil t))))
1640               ;; We display the face.
1641               (if (symbolp gnus-article-x-face-command)
1642                   ;; The command is a lisp function, so we call it.
1643                   (if (gnus-functionp gnus-article-x-face-command)
1644                       (funcall gnus-article-x-face-command beg end)
1645                     (error "%s is not a function" gnus-article-x-face-command))
1646                 ;; The command is a string, so we interpret the command
1647                 ;; as a, well, command, and fork it off.
1648                 (let ((process-connection-type nil))
1649                   (process-kill-without-query
1650                    (start-process
1651                     "article-x-face" nil shell-file-name shell-command-switch
1652                     gnus-article-x-face-command))
1653                   (process-send-region "article-x-face" beg end)
1654                   (process-send-eof "article-x-face"))))))))))
1655
1656 (defun article-decode-mime-words ()
1657   "Decode all MIME-encoded words in the article."
1658   (interactive)
1659   (save-excursion
1660     (set-buffer gnus-article-buffer)
1661     (let ((inhibit-point-motion-hooks t)
1662           buffer-read-only
1663           (mail-parse-charset gnus-newsgroup-charset)
1664           (mail-parse-ignored-charsets
1665            (save-excursion (set-buffer gnus-summary-buffer)
1666                            gnus-newsgroup-ignored-charsets)))
1667       (mail-decode-encoded-word-region (point-min) (point-max)))))
1668
1669 (defun article-decode-charset (&optional prompt)
1670   "Decode charset-encoded text in the article.
1671 If PROMPT (the prefix), prompt for a coding system to use."
1672   (interactive "P")
1673   (let ((inhibit-point-motion-hooks t) (case-fold-search t)
1674         buffer-read-only
1675         (mail-parse-charset gnus-newsgroup-charset)
1676         (mail-parse-ignored-charsets
1677          (save-excursion (condition-case nil
1678                              (set-buffer gnus-summary-buffer)
1679                            (error))
1680                          gnus-newsgroup-ignored-charsets))
1681         ct cte ctl charset format)
1682   (save-excursion
1683     (save-restriction
1684       (article-narrow-to-head)
1685       (setq ct (message-fetch-field "Content-Type" t)
1686             cte (message-fetch-field "Content-Transfer-Encoding" t)
1687             ctl (and ct (ignore-errors
1688                           (mail-header-parse-content-type ct)))
1689             charset (cond
1690                      (prompt
1691                       (mm-read-coding-system "Charset to decode: "))
1692                      (ctl
1693                       (mail-content-type-get ctl 'charset)))
1694             format (and ctl (mail-content-type-get ctl 'format)))
1695       (when cte
1696         (setq cte (mail-header-strip cte)))
1697       (if (and ctl (not (string-match "/" (car ctl))))
1698           (setq ctl nil))
1699       (goto-char (point-max)))
1700     (forward-line 1)
1701     (save-restriction
1702       (narrow-to-region (point) (point-max))
1703       (when (and (eq mail-parse-charset 'gnus-decoded)
1704                  (eq (mm-body-7-or-8) '8bit))
1705         ;; The text code could have been decoded.
1706         (setq charset mail-parse-charset))
1707       (when (and (or (not ctl)
1708                      (equal (car ctl) "text/plain"))
1709                  (not format)) ;; article with format will decode later.
1710         (mm-decode-body
1711          charset (and cte (intern (downcase
1712                                    (gnus-strip-whitespace cte))))
1713          (car ctl)))))))
1714
1715 (defun article-decode-encoded-words ()
1716   "Remove encoded-word encoding from headers."
1717   (let ((inhibit-point-motion-hooks t)
1718         (mail-parse-charset gnus-newsgroup-charset)
1719         (mail-parse-ignored-charsets
1720          (save-excursion (condition-case nil
1721                              (set-buffer gnus-summary-buffer)
1722                            (error))
1723                          gnus-newsgroup-ignored-charsets))
1724         buffer-read-only)
1725     (save-restriction
1726       (article-narrow-to-head)
1727       (funcall gnus-decode-header-function (point-min) (point-max)))))
1728
1729 (defun article-de-quoted-unreadable (&optional force read-charset)
1730   "Translate a quoted-printable-encoded article.
1731 If FORCE, decode the article whether it is marked as quoted-printable
1732 or not.
1733 If READ-CHARSET, ask for a coding system."
1734   (interactive (list 'force current-prefix-arg))
1735   (save-excursion
1736     (let ((buffer-read-only nil) type charset)
1737       (if (gnus-buffer-live-p gnus-original-article-buffer)
1738           (with-current-buffer gnus-original-article-buffer
1739             (setq type
1740                   (gnus-fetch-field "content-transfer-encoding"))
1741             (let* ((ct (gnus-fetch-field "content-type"))
1742                    (ctl (and ct
1743                              (ignore-errors
1744                                (mail-header-parse-content-type ct)))))
1745               (setq charset (and ctl
1746                                  (mail-content-type-get ctl 'charset)))
1747               (if (stringp charset)
1748                   (setq charset (intern (downcase charset)))))))
1749       (if read-charset
1750           (setq charset (read-coding-system "Charset: " charset)))
1751       (unless charset
1752         (setq charset gnus-newsgroup-charset))
1753       (when (or force
1754                 (and type (let ((case-fold-search t))
1755                             (string-match "quoted-printable" type))))
1756         (article-goto-body)
1757         (quoted-printable-decode-region
1758          (point) (point-max) (mm-charset-to-coding-system charset))))))
1759
1760 (defun article-de-base64-unreadable (&optional force read-charset)
1761   "Translate a base64 article.
1762 If FORCE, decode the article whether it is marked as base64 not.
1763 If READ-CHARSET, ask for a coding system."
1764   (interactive (list 'force current-prefix-arg))
1765   (save-excursion
1766     (let ((buffer-read-only nil) type charset)
1767       (if (gnus-buffer-live-p gnus-original-article-buffer)
1768           (with-current-buffer gnus-original-article-buffer
1769             (setq type
1770                   (gnus-fetch-field "content-transfer-encoding"))
1771             (let* ((ct (gnus-fetch-field "content-type"))
1772                    (ctl (and ct
1773                              (ignore-errors
1774                                (mail-header-parse-content-type ct)))))
1775               (setq charset (and ctl
1776                                  (mail-content-type-get ctl 'charset)))
1777               (if (stringp charset)
1778                   (setq charset (intern (downcase charset)))))))
1779       (if read-charset
1780           (setq charset (read-coding-system "Charset: " charset)))
1781       (unless charset
1782         (setq charset gnus-newsgroup-charset))
1783       (when (or force
1784                 (and type (let ((case-fold-search t))
1785                             (string-match "base64" type))))
1786         (article-goto-body)
1787         (save-restriction
1788           (narrow-to-region (point) (point-max))
1789           (base64-decode-region (point-min) (point-max))
1790           (mm-decode-coding-region
1791            (point-min) (point-max) (mm-charset-to-coding-system charset)))))))
1792
1793 (eval-when-compile
1794   (require 'rfc1843))
1795
1796 (defun article-decode-HZ ()
1797   "Translate a HZ-encoded article."
1798   (interactive)
1799   (require 'rfc1843)
1800   (save-excursion
1801     (let ((buffer-read-only nil))
1802       (rfc1843-decode-region (point-min) (point-max)))))
1803
1804 (defun article-wash-html (&optional read-charset)
1805   "Format an html article.
1806 If READ-CHARSET, ask for a coding system."
1807   (interactive "P")
1808   (save-excursion
1809     (let ((buffer-read-only nil)
1810           charset)
1811       (if (gnus-buffer-live-p gnus-original-article-buffer)
1812           (with-current-buffer gnus-original-article-buffer
1813             (let* ((ct (gnus-fetch-field "content-type"))
1814                    (ctl (and ct
1815                              (ignore-errors
1816                                (mail-header-parse-content-type ct)))))
1817               (setq charset (and ctl
1818                                  (mail-content-type-get ctl 'charset)))
1819               (if (stringp charset)
1820                   (setq charset (intern (downcase charset)))))))
1821       (if read-charset
1822           (setq charset (read-coding-system "Charset: " charset)))
1823       (unless charset
1824         (setq charset gnus-newsgroup-charset))
1825       (article-goto-body)
1826       (save-window-excursion
1827         (save-restriction
1828           (narrow-to-region (point) (point-max))
1829           (mm-setup-w3)
1830           (let ((w3-strict-width (window-width))
1831                 (url-standalone-mode t))
1832             (condition-case var
1833                 (w3-region (point-min) (point-max))
1834               (error))))))))
1835
1836 (defun article-hide-list-identifiers ()
1837   "Remove list identifies from the Subject header.
1838 The `gnus-list-identifiers' variable specifies what to do."
1839   (interactive)
1840   (let ((inhibit-point-motion-hooks t)
1841         (regexp (if (consp gnus-list-identifiers)
1842                     (mapconcat 'identity gnus-list-identifiers " *\\|")
1843                   gnus-list-identifiers))
1844         buffer-read-only)
1845     (when regexp
1846       (save-excursion
1847         (save-restriction
1848           (article-narrow-to-head)
1849           (goto-char (point-min))
1850           (while (re-search-forward
1851                   (concat "^Subject: +\\(R[Ee]: +\\)*\\(" regexp " *\\)")
1852                   nil t)
1853             (delete-region (match-beginning 2) (match-end 0))
1854             (beginning-of-line))
1855           (when (re-search-forward
1856                  "^Subject: +\\(\\(R[Ee]: +\\)+\\)R[Ee]: +" nil t)
1857             (delete-region (match-beginning 1) (match-end 1))))))))
1858
1859 (defun article-hide-pgp ()
1860   "Remove any PGP headers and signatures in the current article."
1861   (interactive)
1862   (save-excursion
1863     (save-restriction
1864       (let ((inhibit-point-motion-hooks t)
1865             buffer-read-only beg end)
1866         (article-goto-body)
1867         ;; Hide the "header".
1868         (when (re-search-forward "^-----BEGIN PGP SIGNED MESSAGE-----\n" nil t)
1869           (push 'pgp gnus-article-wash-types)
1870           (delete-region (match-beginning 0) (match-end 0))
1871           ;; Remove armor headers (rfc2440 6.2)
1872           (delete-region (point) (or (re-search-forward "^[ \t]*\n" nil t)
1873                                      (point)))
1874           (setq beg (point))
1875           ;; Hide the actual signature.
1876           (and (search-forward "\n-----BEGIN PGP SIGNATURE-----\n" nil t)
1877                (setq end (1+ (match-beginning 0)))
1878                (delete-region
1879                 end
1880                 (if (search-forward "\n-----END PGP SIGNATURE-----\n" nil t)
1881                     (match-end 0)
1882                   ;; Perhaps we shouldn't hide to the end of the buffer
1883                   ;; if there is no end to the signature?
1884                   (point-max))))
1885           ;; Hide "- " PGP quotation markers.
1886           (when (and beg end)
1887             (narrow-to-region beg end)
1888             (goto-char (point-min))
1889             (while (re-search-forward "^- " nil t)
1890               (delete-region
1891                (match-beginning 0) (match-end 0)))
1892             (widen))
1893           (gnus-run-hooks 'gnus-article-hide-pgp-hook))))))
1894
1895 (defun article-hide-pem (&optional arg)
1896   "Toggle hiding of any PEM headers and signatures in the current article.
1897 If given a negative prefix, always show; if given a positive prefix,
1898 always hide."
1899   (interactive (gnus-article-hidden-arg))
1900   (unless (gnus-article-check-hidden-text 'pem arg)
1901     (save-excursion
1902       (let (buffer-read-only end)
1903         (goto-char (point-min))
1904         ;; Hide the horrendously ugly "header".
1905         (when (and (search-forward
1906                     "\n-----BEGIN PRIVACY-ENHANCED MESSAGE-----\n"
1907                     nil t)
1908                    (setq end (1+ (match-beginning 0))))
1909           (push 'pem gnus-article-wash-types)
1910           (gnus-article-hide-text-type
1911            end
1912            (if (search-forward "\n\n" nil t)
1913                (match-end 0)
1914              (point-max))
1915            'pem)
1916           ;; Hide the trailer as well
1917           (when (search-forward "\n-----END PRIVACY-ENHANCED MESSAGE-----\n"
1918                                 nil t)
1919             (gnus-article-hide-text-type
1920              (match-beginning 0) (match-end 0) 'pem)))))))
1921
1922 (defun article-strip-banner ()
1923   "Strip the banner specified by the `banner' group parameter."
1924   (interactive)
1925   (save-excursion
1926     (save-restriction
1927       (let ((inhibit-point-motion-hooks t)
1928             (banner (gnus-parameter-banner gnus-newsgroup-name))
1929             (gnus-signature-limit nil)
1930             buffer-read-only beg end)
1931         (when banner
1932           (article-goto-body)
1933           (cond
1934            ((eq banner 'signature)
1935             (when (gnus-article-narrow-to-signature)
1936               (widen)
1937               (forward-line -1)
1938               (delete-region (point) (point-max))))
1939            ((symbolp banner)
1940             (if (setq banner (cdr (assq banner gnus-article-banner-alist)))
1941                 (while (re-search-forward banner nil t)
1942                   (delete-region (match-beginning 0) (match-end 0)))))
1943            ((stringp banner)
1944             (while (re-search-forward banner nil t)
1945               (delete-region (match-beginning 0) (match-end 0))))))))))
1946
1947 (defun article-babel ()
1948   "Translate article using an online translation service."
1949   (interactive)
1950   (require 'babel)
1951   (save-excursion
1952     (set-buffer gnus-article-buffer)
1953     (when (article-goto-body)
1954       (let* ((buffer-read-only nil)
1955              (start (point))
1956              (end (point-max))
1957              (orig (buffer-substring start end))
1958              (trans (babel-as-string orig)))
1959         (save-restriction
1960           (narrow-to-region start end)
1961           (delete-region start end)
1962           (insert trans))))))
1963
1964 (defun article-hide-signature (&optional arg)
1965   "Hide the signature in the current article.
1966 If given a negative prefix, always show; if given a positive prefix,
1967 always hide."
1968   (interactive (gnus-article-hidden-arg))
1969   (unless (gnus-article-check-hidden-text 'signature arg)
1970     (save-excursion
1971       (save-restriction
1972         (let ((buffer-read-only nil))
1973           (when (gnus-article-narrow-to-signature)
1974             (gnus-article-hide-text-type
1975              (point-min) (point-max) 'signature)))))))
1976
1977 (defun article-strip-headers-in-body ()
1978   "Strip offensive headers from bodies."
1979   (interactive)
1980   (save-excursion
1981     (article-goto-body)
1982     (let ((case-fold-search t))
1983       (when (looking-at "x-no-archive:")
1984         (gnus-delete-line)))))
1985
1986 (defun article-strip-leading-blank-lines ()
1987   "Remove all blank lines from the beginning of the article."
1988   (interactive)
1989   (save-excursion
1990     (let ((inhibit-point-motion-hooks t)
1991           buffer-read-only)
1992       (when (article-goto-body)
1993         (while (and (not (eobp))
1994                     (looking-at "[ \t]*$"))
1995           (gnus-delete-line))))))
1996
1997 (defun article-narrow-to-head ()
1998   "Narrow the buffer to the head of the message.
1999 Point is left at the beginning of the narrowed-to region."
2000   (narrow-to-region
2001    (goto-char (point-min))
2002    (if (search-forward "\n\n" nil 1)
2003        (1- (point))
2004      (point-max)))
2005   (goto-char (point-min)))
2006
2007 (defun article-goto-body ()
2008   "Place point at the start of the body."
2009   (goto-char (point-min))
2010   (cond
2011    ;; This variable is only bound when dealing with separate
2012    ;; MIME body parts.
2013    (article-goto-body-goes-to-point-min-p
2014     t)
2015    ((search-forward "\n\n" nil t)
2016     t)
2017    (t
2018     (goto-char (point-max))
2019     nil)))
2020
2021 (defun article-strip-multiple-blank-lines ()
2022   "Replace consecutive blank lines with one empty line."
2023   (interactive)
2024   (save-excursion
2025     (let ((inhibit-point-motion-hooks t)
2026           buffer-read-only)
2027       ;; First make all blank lines empty.
2028       (article-goto-body)
2029       (while (re-search-forward "^[ \t]+$" nil t)
2030         (unless (gnus-annotation-in-region-p
2031                  (match-beginning 0) (match-end 0))
2032           (replace-match "" nil t)))
2033       ;; Then replace multiple empty lines with a single empty line.
2034       (article-goto-body)
2035       (while (re-search-forward "\n\n\n+" nil t)
2036         (unless (gnus-annotation-in-region-p
2037                  (match-beginning 0) (match-end 0))
2038           (replace-match "\n\n" t t))))))
2039
2040 (defun article-strip-leading-space ()
2041   "Remove all white space from the beginning of the lines in the article."
2042   (interactive)
2043   (save-excursion
2044     (let ((inhibit-point-motion-hooks t)
2045           buffer-read-only)
2046       (article-goto-body)
2047       (while (re-search-forward "^[ \t]+" nil t)
2048         (replace-match "" t t)))))
2049
2050 (defun article-strip-trailing-space ()
2051   "Remove all white space from the end of the lines in the article."
2052   (interactive)
2053   (save-excursion
2054     (let ((inhibit-point-motion-hooks t)
2055           buffer-read-only)
2056       (article-goto-body)
2057       (while (re-search-forward "[ \t]+$" nil t)
2058         (replace-match "" t t)))))
2059
2060 (defun article-strip-blank-lines ()
2061   "Strip leading, trailing and multiple blank lines."
2062   (interactive)
2063   (article-strip-leading-blank-lines)
2064   (article-remove-trailing-blank-lines)
2065   (article-strip-multiple-blank-lines))
2066
2067 (defun article-strip-all-blank-lines ()
2068   "Strip all blank lines."
2069   (interactive)
2070   (save-excursion
2071     (let ((inhibit-point-motion-hooks t)
2072           buffer-read-only)
2073       (article-goto-body)
2074       (while (re-search-forward "^[ \t]*\n" nil t)
2075         (replace-match "" t t)))))
2076
2077 (defun gnus-article-narrow-to-signature ()
2078   "Narrow to the signature; return t if a signature is found, else nil."
2079   (let ((inhibit-point-motion-hooks t))
2080     (when (gnus-article-search-signature)
2081       (forward-line 1)
2082       ;; Check whether we have some limits to what we consider
2083       ;; to be a signature.
2084       (let ((limits (if (listp gnus-signature-limit) gnus-signature-limit
2085                       (list gnus-signature-limit)))
2086             limit limited)
2087         (while (setq limit (pop limits))
2088           (if (or (and (integerp limit)
2089                        (< (- (point-max) (point)) limit))
2090                   (and (floatp limit)
2091                        (< (count-lines (point) (point-max)) limit))
2092                   (and (gnus-functionp limit)
2093                        (funcall limit))
2094                   (and (stringp limit)
2095                        (not (re-search-forward limit nil t))))
2096               ()                        ; This limit did not succeed.
2097             (setq limited t
2098                   limits nil)))
2099         (unless limited
2100           (narrow-to-region (point) (point-max))
2101           t)))))
2102
2103 (defun gnus-article-search-signature ()
2104   "Search the current buffer for the signature separator.
2105 Put point at the beginning of the signature separator."
2106   (let ((cur (point)))
2107     (goto-char (point-max))
2108     (if (if (stringp gnus-signature-separator)
2109             (re-search-backward gnus-signature-separator nil t)
2110           (let ((seps gnus-signature-separator))
2111             (while (and seps
2112                         (not (re-search-backward (car seps) nil t)))
2113               (pop seps))
2114             seps))
2115         t
2116       (goto-char cur)
2117       nil)))
2118
2119 (defun gnus-article-hidden-arg ()
2120   "Return the current prefix arg as a number, or 0 if no prefix."
2121   (list (if current-prefix-arg
2122             (prefix-numeric-value current-prefix-arg)
2123           0)))
2124
2125 (defun gnus-article-check-hidden-text (type arg)
2126   "Return nil if hiding is necessary.
2127 Arg can be nil or a number.  Nil and positive means hide, negative
2128 means show, 0 means toggle."
2129   (save-excursion
2130     (save-restriction
2131       (let ((hide (gnus-article-hidden-text-p type)))
2132         (cond
2133          ((or (null arg)
2134               (> arg 0))
2135           nil)
2136          ((< arg 0)
2137           (gnus-article-show-hidden-text type)
2138           t)
2139          (t
2140           (if (eq hide 'hidden)
2141               (progn
2142                 (gnus-article-show-hidden-text type)
2143                 t)
2144             nil)))))))
2145
2146 (defun gnus-article-hidden-text-p (type)
2147   "Say whether the current buffer contains hidden text of type TYPE."
2148   (let ((pos (text-property-any (point-min) (point-max) 'article-type type)))
2149     (while (and pos
2150                 (not (get-text-property pos 'invisible))
2151                 (not (get-text-property pos 'dummy-invisible)))
2152       (setq pos
2153             (text-property-any (1+ pos) (point-max) 'article-type type)))
2154     (if pos
2155         'hidden
2156       nil)))
2157
2158 (defun gnus-article-show-hidden-text (type &optional dummy)
2159   "Show all hidden text of type TYPE.
2160 Originally it is hide instead of DUMMY."
2161   (let ((buffer-read-only nil)
2162         (inhibit-point-motion-hooks t))
2163     (gnus-remove-text-properties-when
2164      'article-type type
2165      (point-min) (point-max)
2166      (cons 'article-type (cons type
2167                                gnus-hidden-properties)))))
2168
2169 (defconst article-time-units
2170   `((year . ,(* 365.25 24 60 60))
2171     (week . ,(* 7 24 60 60))
2172     (day . ,(* 24 60 60))
2173     (hour . ,(* 60 60))
2174     (minute . 60)
2175     (second . 1))
2176   "Mapping from time units to seconds.")
2177
2178 (defun article-date-ut (&optional type highlight header)
2179   "Convert DATE date to universal time in the current article.
2180 If TYPE is `local', convert to local time; if it is `lapsed', output
2181 how much time has lapsed since DATE.  For `lapsed', the value of
2182 `gnus-article-date-lapsed-new-header' says whether the \"X-Sent:\" header
2183 should replace the \"Date:\" one, or should be added below it."
2184   (interactive (list 'ut t))
2185   (let* ((header (or header
2186                      (message-fetch-field "date")
2187                      ""))
2188          (tdate-regexp "^Date:[ \t]\\|^X-Sent:[ \t]")
2189          (date-regexp
2190           (cond
2191            ((not gnus-article-date-lapsed-new-header)
2192             tdate-regexp)
2193            ((eq type 'lapsed)
2194             "^X-Sent:[ \t]")
2195            (t
2196             "^Date:[ \t]")))
2197          (date (if (vectorp header) (mail-header-date header)
2198                  header))
2199          (inhibit-point-motion-hooks t)
2200          pos
2201          bface eface)
2202     (save-excursion
2203       (save-restriction
2204         (article-narrow-to-head)
2205         (when (re-search-forward tdate-regexp nil t)
2206           (setq bface (get-text-property (gnus-point-at-bol) 'face)
2207                 date (or (get-text-property (gnus-point-at-bol)
2208                                             'original-date)
2209                          date)
2210                 eface (get-text-property (1- (gnus-point-at-eol)) 'face))
2211           (forward-line 1))
2212         (when (and date (not (string= date "")))
2213           (goto-char (point-min))
2214           (let ((buffer-read-only nil))
2215             ;; Delete any old Date headers.
2216             (while (re-search-forward date-regexp nil t)
2217               (if pos
2218                   (delete-region (progn (beginning-of-line) (point))
2219                                  (progn (forward-line 1) (point)))
2220                 (delete-region (progn (beginning-of-line) (point))
2221                                (progn (end-of-line) (point)))
2222                 (setq pos (point))))
2223             (when (and (not pos) (re-search-forward tdate-regexp nil t))
2224               (forward-line 1))
2225             (if pos (goto-char pos))
2226             (insert (article-make-date-line date (or type 'ut)))
2227             (when (not pos)
2228               (insert "\n")
2229               (forward-line -1))
2230             ;; Do highlighting.
2231             (beginning-of-line)
2232             (when (looking-at "\\([^:]+\\): *\\(.*\\)$")
2233               (put-text-property (match-beginning 1) (1+ (match-end 1))
2234                                  'original-date date)
2235               (put-text-property (match-beginning 1) (1+ (match-end 1))
2236                                  'face bface)
2237               (put-text-property (match-beginning 2) (match-end 2)
2238                                  'face eface))))))))
2239
2240 (defun article-make-date-line (date type)
2241   "Return a DATE line of TYPE."
2242   (unless (memq type '(local ut original user iso8601 lapsed english))
2243     (error "Unknown conversion type: %s" type))
2244   (condition-case ()
2245       (let ((time (date-to-time date)))
2246         (cond
2247          ;; Convert to the local timezone.  
2248          ((eq type 'local)
2249           (let ((tz (car (current-time-zone time))))
2250             (format "Date: %s %s%02d%02d" (current-time-string time)
2251                     (if (> tz 0) "+" "-") (/ (abs tz) 3600)
2252                     (/ (% (abs tz) 3600) 60))))
2253          ;; Convert to Universal Time.
2254          ((eq type 'ut)
2255           (concat "Date: "
2256                   (current-time-string
2257                    (let* ((e (parse-time-string date))
2258                           (tm (apply 'encode-time e))
2259                           (ms (car tm))
2260                           (ls (- (cadr tm) (car (current-time-zone time)))))
2261                      (cond ((< ls 0) (list (1- ms) (+ ls 65536)))
2262                            ((> ls 65535) (list (1+ ms) (- ls 65536)))
2263                            (t (list ms ls)))))
2264                   " UT"))
2265          ;; Get the original date from the article.
2266          ((eq type 'original)
2267           (concat "Date: " (if (string-match "\n+$" date)
2268                                (substring date 0 (match-beginning 0))
2269                              date)))
2270          ;; Let the user define the format.
2271          ((eq type 'user)
2272           (if (gnus-functionp gnus-article-time-format)
2273               (funcall gnus-article-time-format time)
2274             (concat
2275              "Date: "
2276              (format-time-string gnus-article-time-format time))))
2277          ;; ISO 8601.
2278          ((eq type 'iso8601)
2279           (let ((tz (car (current-time-zone time))))
2280             (concat
2281              "Date: "
2282              (format-time-string "%Y%m%dT%H%M%S" time)
2283              (format "%s%02d%02d"
2284                      (if (> tz 0) "+" "-") (/ (abs tz) 3600)
2285                      (/ (% (abs tz) 3600) 60)))))
2286          ;; Do an X-Sent lapsed format.
2287          ((eq type 'lapsed)
2288           ;; If the date is seriously mangled, the timezone functions are
2289           ;; liable to bug out, so we ignore all errors.
2290           (let* ((now (current-time))
2291                  (real-time (subtract-time now time))
2292                  (real-sec (and real-time
2293                                 (+ (* (float (car real-time)) 65536)
2294                                    (cadr real-time))))
2295                  (sec (and real-time (abs real-sec)))
2296                  num prev)
2297             (cond
2298              ((null real-time)
2299               "X-Sent: Unknown")
2300              ((zerop sec)
2301               "X-Sent: Now")
2302              (t
2303               (concat
2304                "X-Sent: "
2305                ;; This is a bit convoluted, but basically we go
2306                ;; through the time units for years, weeks, etc,
2307                ;; and divide things to see whether that results
2308                ;; in positive answers.
2309                (mapconcat
2310                 (lambda (unit)
2311                   (if (zerop (setq num (ffloor (/ sec (cdr unit)))))
2312                       ;; The (remaining) seconds are too few to
2313                       ;; be divided into this time unit.
2314                       ""
2315                     ;; It's big enough, so we output it.
2316                     (setq sec (- sec (* num (cdr unit))))
2317                     (prog1
2318                         (concat (if prev ", " "") (int-to-string
2319                                                    (floor num))
2320                                 " " (symbol-name (car unit))
2321                                 (if (> num 1) "s" ""))
2322                       (setq prev t))))
2323                 article-time-units "")
2324                ;; If dates are odd, then it might appear like the
2325                ;; article was sent in the future.
2326                (if (> real-sec 0)
2327                    " ago"
2328                  " in the future"))))))
2329          ;; Display the date in proper English
2330          ((eq type 'english)
2331           (let ((dtime (decode-time time)))
2332             (concat
2333              "Date: the "
2334              (number-to-string (nth 3 dtime))
2335              (let ((digit (% (nth 3 dtime) 10)))
2336                (cond
2337                 ((memq (nth 3 dtime) '(11 12 13)) "th")
2338                 ((= digit 1) "st")
2339                 ((= digit 2) "nd")
2340                 ((= digit 3) "rd")
2341                 (t "th")))
2342              " of "
2343              (nth (1- (nth 4 dtime)) gnus-english-month-names)
2344              " "
2345              (number-to-string (nth 5 dtime))
2346              " at "
2347              (format "%02d" (nth 2 dtime))
2348              ":"
2349              (format "%02d" (nth 1 dtime)))))))
2350         (error
2351          (format "Date: %s (from Oort)" date))))
2352
2353 (defun article-date-local (&optional highlight)
2354   "Convert the current article date to the local timezone."
2355   (interactive (list t))
2356   (article-date-ut 'local highlight))
2357
2358 (defun article-date-english (&optional highlight)
2359   "Convert the current article date to something that is proper English."
2360   (interactive (list t))
2361   (article-date-ut 'english highlight))
2362
2363 (defun article-date-original (&optional highlight)
2364   "Convert the current article date to what it was originally.
2365 This is only useful if you have used some other date conversion
2366 function and want to see what the date was before converting."
2367   (interactive (list t))
2368   (article-date-ut 'original highlight))
2369
2370 (defun article-date-lapsed (&optional highlight)
2371   "Convert the current article date to time lapsed since it was sent."
2372   (interactive (list t))
2373   (article-date-ut 'lapsed highlight))
2374
2375 (defun article-update-date-lapsed ()
2376   "Function to be run from a timer to update the lapsed time line."
2377   (let (deactivate-mark)
2378     (save-excursion
2379       (ignore-errors
2380         (walk-windows
2381          (lambda (w)
2382            (set-buffer (window-buffer w))
2383            (when (eq major-mode 'gnus-article-mode)
2384              (goto-char (point-min))
2385              (when (re-search-forward "^X-Sent:" nil t)
2386                (article-date-lapsed t))))
2387          nil 'visible)))))
2388
2389 (defun gnus-start-date-timer (&optional n)
2390   "Start a timer to update the X-Sent header in the article buffers.
2391 The numerical prefix says how frequently (in seconds) the function
2392 is to run."
2393   (interactive "p")
2394   (unless n
2395     (setq n 1))
2396   (gnus-stop-date-timer)
2397   (setq article-lapsed-timer
2398         (nnheader-run-at-time 1 n 'article-update-date-lapsed)))
2399
2400 (defun gnus-stop-date-timer ()
2401   "Stop the X-Sent timer."
2402   (interactive)
2403   (when article-lapsed-timer
2404     (nnheader-cancel-timer article-lapsed-timer)
2405     (setq article-lapsed-timer nil)))
2406
2407 (defun article-date-user (&optional highlight)
2408   "Convert the current article date to the user-defined format.
2409 This format is defined by the `gnus-article-time-format' variable."
2410   (interactive (list t))
2411   (article-date-ut 'user highlight))
2412
2413 (defun article-date-iso8601 (&optional highlight)
2414   "Convert the current article date to ISO8601."
2415   (interactive (list t))
2416   (article-date-ut 'iso8601 highlight))
2417
2418 (defun article-show-all ()
2419   "Show all hidden text in the article buffer."
2420   (interactive)
2421   (save-excursion
2422     (let ((buffer-read-only nil))
2423       (gnus-article-unhide-text (point-min) (point-max)))))
2424
2425 (defun article-remove-leading-whitespace ()
2426   "Remove excessive whitespace from all headers."
2427   (interactive)
2428   (save-excursion
2429     (save-restriction
2430       (let ((buffer-read-only nil))
2431         (article-narrow-to-head)
2432         (goto-char (point-min))
2433         (while (re-search-forward "^[^ :]+: \\([ \t]+\\)" nil t)
2434           (delete-region (match-beginning 1) (match-end 1)))))))
2435
2436 (defun article-emphasize (&optional arg)
2437   "Emphasize text according to `gnus-emphasis-alist'."
2438   (interactive (gnus-article-hidden-arg))
2439   (unless (gnus-article-check-hidden-text 'emphasis arg)
2440     (save-excursion
2441       (let ((alist (or
2442                     (condition-case nil
2443                         (with-current-buffer gnus-summary-buffer
2444                           gnus-article-emphasis-alist)
2445                       (error))
2446                     gnus-emphasis-alist))
2447             (buffer-read-only nil)
2448             (props (append '(article-type emphasis)
2449                            gnus-hidden-properties))
2450             regexp elem beg invisible visible face)
2451         (article-goto-body)
2452         (setq beg (point))
2453         (while (setq elem (pop alist))
2454           (goto-char beg)
2455           (setq regexp (car elem)
2456                 invisible (nth 1 elem)
2457                 visible (nth 2 elem)
2458                 face (nth 3 elem))
2459           (while (re-search-forward regexp nil t)
2460             (when (and (match-beginning visible) (match-beginning invisible))
2461               (push 'emphasis gnus-article-wash-types)
2462               (gnus-article-hide-text
2463                (match-beginning invisible) (match-end invisible) props)
2464               (gnus-article-unhide-text-type
2465                (match-beginning visible) (match-end visible) 'emphasis)
2466               (gnus-put-text-property-excluding-newlines
2467                (match-beginning visible) (match-end visible) 'face face)
2468               (goto-char (match-end invisible)))))))))
2469
2470 (defun gnus-article-setup-highlight-words (&optional highlight-words)
2471   "Setup newsgroup emphasis alist."
2472   (unless gnus-article-emphasis-alist
2473     (let ((name (and gnus-newsgroup-name
2474                      (gnus-group-real-name gnus-newsgroup-name))))
2475       (make-local-variable 'gnus-article-emphasis-alist)
2476       (setq gnus-article-emphasis-alist
2477             (nconc
2478              (let ((alist gnus-group-highlight-words-alist) elem highlight)
2479                (while (setq elem (pop alist))
2480                  (when (and name (string-match (car elem) name))
2481                    (setq alist nil
2482                          highlight (copy-sequence (cdr elem)))))
2483                highlight)
2484              (copy-sequence highlight-words)
2485              (if gnus-newsgroup-name
2486                  (copy-sequence (gnus-group-find-parameter
2487                                  gnus-newsgroup-name 'highlight-words t)))
2488              gnus-emphasis-alist)))))
2489
2490 (eval-when-compile
2491   (defvar gnus-summary-article-menu)
2492   (defvar gnus-summary-post-menu))
2493
2494 ;;; Saving functions.
2495
2496 (defun gnus-article-save (save-buffer file &optional num)
2497   "Save the currently selected article."
2498   (unless gnus-save-all-headers
2499     ;; Remove headers according to `gnus-saved-headers'.
2500     (let ((gnus-visible-headers
2501            (or gnus-saved-headers gnus-visible-headers))
2502           (gnus-article-buffer save-buffer))
2503       (save-excursion
2504         (set-buffer save-buffer)
2505         (article-hide-headers 1 t))))
2506   (save-window-excursion
2507     (if (not gnus-default-article-saver)
2508         (error "No default saver is defined")
2509       ;; !!! Magic!  The saving functions all save
2510       ;; `gnus-save-article-buffer' (or so they think), but we
2511       ;; bind that variable to our save-buffer.
2512       (set-buffer gnus-article-buffer)
2513       (let* ((gnus-save-article-buffer save-buffer)
2514              (filename
2515               (cond
2516                ((not gnus-prompt-before-saving) 'default)
2517                ((eq gnus-prompt-before-saving 'always) nil)
2518                (t file)))
2519              (gnus-number-of-articles-to-be-saved
2520               (when (eq gnus-prompt-before-saving t)
2521                 num)))                  ; Magic
2522         (set-buffer gnus-article-current-summary)
2523         (funcall gnus-default-article-saver filename)))))
2524
2525 (defun gnus-read-save-file-name (prompt &optional filename
2526                                         function group headers variable)
2527   (let ((default-name
2528           (funcall function group headers (symbol-value variable)))
2529         result)
2530     (setq result
2531           (expand-file-name
2532            (cond
2533             ((eq filename 'default)
2534              default-name)
2535             ((eq filename t)
2536              default-name)
2537             (filename filename)
2538             (t
2539              (let* ((split-name (gnus-get-split-value gnus-split-methods))
2540                     (prompt
2541                      (format prompt
2542                              (if (and gnus-number-of-articles-to-be-saved
2543                                       (> gnus-number-of-articles-to-be-saved 1))
2544                                  (format "these %d articles"
2545                                          gnus-number-of-articles-to-be-saved)
2546                                "this article")))
2547                     (file
2548                      ;; Let the split methods have their say.
2549                      (cond
2550                       ;; No split name was found.
2551                       ((null split-name)
2552                        (read-file-name
2553                         (concat prompt " (default "
2554                                 (file-name-nondirectory default-name) ") ")
2555                         (file-name-directory default-name)
2556                         default-name))
2557                       ;; A single group name is returned.
2558                       ((stringp split-name)
2559                        (setq default-name
2560                              (funcall function split-name headers
2561                                       (symbol-value variable)))
2562                        (read-file-name
2563                         (concat prompt " (default "
2564                                 (file-name-nondirectory default-name) ") ")
2565                         (file-name-directory default-name)
2566                         default-name))
2567                       ;; A single split name was found
2568                       ((= 1 (length split-name))
2569                        (let* ((name (expand-file-name
2570                                      (car split-name)
2571                                      gnus-article-save-directory))
2572                               (dir (cond ((file-directory-p name)
2573                                           (file-name-as-directory name))
2574                                          ((file-exists-p name) name)
2575                                          (t gnus-article-save-directory))))
2576                          (read-file-name
2577                           (concat prompt " (default " name ") ")
2578                           dir name)))
2579                       ;; A list of splits was found.
2580                       (t
2581                        (setq split-name (nreverse split-name))
2582                        (let (result)
2583                          (let ((file-name-history
2584                                 (nconc split-name file-name-history)))
2585                            (setq result
2586                                  (expand-file-name
2587                                   (read-file-name
2588                                    (concat prompt " (`M-p' for defaults) ")
2589                                    gnus-article-save-directory
2590                                    (car split-name))
2591                                   gnus-article-save-directory)))
2592                          (car (push result file-name-history)))))))
2593                ;; Create the directory.
2594                (gnus-make-directory (file-name-directory file))
2595       ;; If we have read a directory, we append the default file name.
2596                (when (file-directory-p file)
2597                  (setq file (expand-file-name (file-name-nondirectory
2598                                                default-name)
2599                                               (file-name-as-directory file))))
2600                ;; Possibly translate some characters.
2601                (nnheader-translate-file-chars file))))))
2602     (gnus-make-directory (file-name-directory result))
2603     (set variable result)))
2604
2605 (defun gnus-article-archive-name (group)
2606   "Return the first instance of an \"Archive-name\" in the current buffer."
2607   (let ((case-fold-search t))
2608     (when (re-search-forward "archive-name: *\\([^ \n\t]+\\)[ \t]*$" nil t)
2609       (nnheader-concat gnus-article-save-directory
2610                        (match-string 1)))))
2611
2612 (defun gnus-article-nndoc-name (group)
2613   "If GROUP is an nndoc group, return the name of the parent group."
2614   (when (eq (car (gnus-find-method-for-group group)) 'nndoc)
2615     (gnus-group-get-parameter group 'save-article-group)))
2616
2617 (defun gnus-summary-save-in-rmail (&optional filename)
2618   "Append this article to Rmail file.
2619 Optional argument FILENAME specifies file name.
2620 Directory to save to is default to `gnus-article-save-directory'."
2621   (setq filename (gnus-read-save-file-name
2622                   "Save %s in rmail file:" filename
2623                   gnus-rmail-save-name gnus-newsgroup-name
2624                   gnus-current-headers 'gnus-newsgroup-last-rmail))
2625   (gnus-eval-in-buffer-window gnus-save-article-buffer
2626     (save-excursion
2627       (save-restriction
2628         (widen)
2629         (gnus-output-to-rmail filename))))
2630   filename)
2631
2632 (defun gnus-summary-save-in-mail (&optional filename)
2633   "Append this article to Unix mail file.
2634 Optional argument FILENAME specifies file name.
2635 Directory to save to is default to `gnus-article-save-directory'."
2636   (setq filename (gnus-read-save-file-name
2637                   "Save %s in Unix mail file:" filename
2638                   gnus-mail-save-name gnus-newsgroup-name
2639                   gnus-current-headers 'gnus-newsgroup-last-mail))
2640   (gnus-eval-in-buffer-window gnus-save-article-buffer
2641     (save-excursion
2642       (save-restriction
2643         (widen)
2644         (if (and (file-readable-p filename)
2645                  (mail-file-babyl-p filename))
2646             (rmail-output-to-rmail-file filename t)
2647           (gnus-output-to-mail filename)))))
2648   filename)
2649
2650 (defun gnus-summary-save-in-file (&optional filename overwrite)
2651   "Append this article to file.
2652 Optional argument FILENAME specifies file name.
2653 Directory to save to is default to `gnus-article-save-directory'."
2654   (setq filename (gnus-read-save-file-name
2655                   "Save %s in file:" filename
2656                   gnus-file-save-name gnus-newsgroup-name
2657                   gnus-current-headers 'gnus-newsgroup-last-file))
2658   (gnus-eval-in-buffer-window gnus-save-article-buffer
2659     (save-excursion
2660       (save-restriction
2661         (widen)
2662         (when (and overwrite
2663                    (file-exists-p filename))
2664           (delete-file filename))
2665         (gnus-output-to-file filename))))
2666   filename)
2667
2668 (defun gnus-summary-write-to-file (&optional filename)
2669   "Write this article to a file.
2670 Optional argument FILENAME specifies file name.
2671 The directory to save in defaults to `gnus-article-save-directory'."
2672   (gnus-summary-save-in-file nil t))
2673
2674 (defun gnus-summary-save-body-in-file (&optional filename)
2675   "Append this article body to a file.
2676 Optional argument FILENAME specifies file name.
2677 The directory to save in defaults to `gnus-article-save-directory'."
2678   (setq filename (gnus-read-save-file-name
2679                   "Save %s body in file:" filename
2680                   gnus-file-save-name gnus-newsgroup-name
2681                   gnus-current-headers 'gnus-newsgroup-last-file))
2682   (gnus-eval-in-buffer-window gnus-save-article-buffer
2683     (save-excursion
2684       (save-restriction
2685         (widen)
2686         (when (article-goto-body)
2687           (narrow-to-region (point) (point-max)))
2688         (gnus-output-to-file filename))))
2689   filename)
2690
2691 (defun gnus-summary-save-in-pipe (&optional command)
2692   "Pipe this article to subprocess."
2693   (setq command
2694         (cond ((and (eq command 'default)
2695                     gnus-last-shell-command)
2696                gnus-last-shell-command)
2697               ((stringp command)
2698                command)
2699               (t (read-string
2700                   (format
2701                    "Shell command on %s: "
2702                    (if (and gnus-number-of-articles-to-be-saved
2703                             (> gnus-number-of-articles-to-be-saved 1))
2704                        (format "these %d articles"
2705                                gnus-number-of-articles-to-be-saved)
2706                      "this article"))
2707                   gnus-last-shell-command))))
2708   (when (string-equal command "")
2709     (if gnus-last-shell-command
2710         (setq command gnus-last-shell-command)
2711       (error "A command is required.")))
2712   (gnus-eval-in-buffer-window gnus-article-buffer
2713     (save-restriction
2714       (widen)
2715       (shell-command-on-region (point-min) (point-max) command nil)))
2716   (setq gnus-last-shell-command command))
2717
2718 ;;; Article file names when saving.
2719
2720 (defun gnus-capitalize-newsgroup (newsgroup)
2721   "Capitalize NEWSGROUP name."
2722   (when (not (zerop (length newsgroup)))
2723     (concat (char-to-string (upcase (aref newsgroup 0)))
2724             (substring newsgroup 1))))
2725
2726 (defun gnus-Numeric-save-name (newsgroup headers &optional last-file)
2727   "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE.
2728 If variable `gnus-use-long-file-name' is non-nil, it is ~/News/News.group/num.
2729 Otherwise, it is like ~/News/news/group/num."
2730   (let ((default
2731           (expand-file-name
2732            (concat (if (gnus-use-long-file-name 'not-save)
2733                        (gnus-capitalize-newsgroup newsgroup)
2734                      (gnus-newsgroup-directory-form newsgroup))
2735                    "/" (int-to-string (mail-header-number headers)))
2736            gnus-article-save-directory)))
2737     (if (and last-file
2738              (string-equal (file-name-directory default)
2739                            (file-name-directory last-file))
2740              (string-match "^[0-9]+$" (file-name-nondirectory last-file)))
2741         default
2742       (or last-file default))))
2743
2744 (defun gnus-numeric-save-name (newsgroup headers &optional last-file)
2745   "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE.
2746 If variable `gnus-use-long-file-name' is non-nil, it is
2747 ~/News/news.group/num.  Otherwise, it is like ~/News/news/group/num."
2748   (let ((default
2749           (expand-file-name
2750            (concat (if (gnus-use-long-file-name 'not-save)
2751                        newsgroup
2752                      (gnus-newsgroup-directory-form newsgroup))
2753                    "/" (int-to-string (mail-header-number headers)))
2754            gnus-article-save-directory)))
2755     (if (and last-file
2756              (string-equal (file-name-directory default)
2757                            (file-name-directory last-file))
2758              (string-match "^[0-9]+$" (file-name-nondirectory last-file)))
2759         default
2760       (or last-file default))))
2761
2762 (defun gnus-plain-save-name (newsgroup headers &optional last-file)
2763   "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE.
2764 If variable `gnus-use-long-file-name' is non-nil, it is
2765 ~/News/news.group.  Otherwise, it is like ~/News/news/group/news."
2766   (or last-file
2767       (expand-file-name
2768        (if (gnus-use-long-file-name 'not-save)
2769            newsgroup
2770          (file-relative-name
2771           (expand-file-name "news" (gnus-newsgroup-directory-form newsgroup))
2772           default-directory))
2773        gnus-article-save-directory)))
2774
2775 (defun gnus-sender-save-name (newsgroup headers &optional last-file)
2776   "Generate file name from sender."
2777   (let ((from (mail-header-from headers)))
2778     (expand-file-name
2779      (if (and from (string-match "\\([^ <]+\\)@" from))
2780          (match-string 1 from)
2781        "nobody")
2782      gnus-article-save-directory)))
2783
2784 (defun article-verify-x-pgp-sig ()
2785   "Verify X-PGP-Sig."
2786   (interactive)
2787   (if (gnus-buffer-live-p gnus-original-article-buffer)
2788       (let ((sig (with-current-buffer gnus-original-article-buffer
2789                    (gnus-fetch-field "X-PGP-Sig")))
2790             items info headers)
2791         (when (and sig
2792                    mml2015-use
2793                    (mml2015-clear-verify-function))
2794           (with-temp-buffer
2795             (insert-buffer gnus-original-article-buffer)
2796             (setq items (split-string sig))
2797             (message-narrow-to-head)
2798             (let ((inhibit-point-motion-hooks t)
2799                   (case-fold-search t))
2800               ;; Don't verify multiple headers.
2801               (setq headers (mapconcat (lambda (header)
2802                                          (concat header ": "
2803                                                  (mail-fetch-field header) "\n"))
2804                                        (split-string (nth 1 items) ",") "")))
2805             (delete-region (point-min) (point-max))
2806             (insert "-----BEGIN PGP SIGNED MESSAGE-----\n\n")
2807             (insert "X-Signed-Headers: " (nth 1 items) "\n")
2808             (insert headers)
2809             (widen)
2810             (forward-line)
2811             (while (not (eobp))
2812               (if (looking-at "^-")
2813                   (insert "- "))
2814               (forward-line))
2815             (insert "\n-----BEGIN PGP SIGNATURE-----\n")
2816             (insert "Version: " (car items) "\n\n")
2817             (insert (mapconcat 'identity (cddr items) "\n"))
2818             (insert "\n-----END PGP SIGNATURE-----\n")
2819             (let ((mm-security-handle (list (format "multipart/signed"))))
2820               (mml2015-clean-buffer)
2821               (let ((coding-system-for-write (or gnus-newsgroup-charset
2822                                                  'iso-8859-1)))
2823                 (funcall (mml2015-clear-verify-function)))
2824               (setq info
2825                     (or (mm-handle-multipart-ctl-parameter
2826                          mm-security-handle 'gnus-details)
2827                         (mm-handle-multipart-ctl-parameter
2828                          mm-security-handle 'gnus-info)))))
2829           (when info
2830             (let (buffer-read-only bface eface)
2831               (save-restriction
2832                 (message-narrow-to-head)
2833                 (goto-char (point-max))
2834                 (forward-line -1)
2835                 (setq bface (get-text-property (gnus-point-at-bol) 'face)
2836                       eface (get-text-property (1- (gnus-point-at-eol)) 'face))
2837                 (message-remove-header "X-Gnus-PGP-Verify")
2838                 (if (re-search-forward "^X-PGP-Sig:" nil t)
2839                     (forward-line)
2840                   (goto-char (point-max)))
2841                 (narrow-to-region (point) (point))
2842                 (insert "X-Gnus-PGP-Verify: " info "\n")
2843                 (goto-char (point-min))
2844                 (forward-line)
2845                 (while (not (eobp))
2846                   (if (not (looking-at "^[ \t]"))
2847                       (insert " "))
2848                   (forward-line))
2849                 ;; Do highlighting.
2850                 (goto-char (point-min))
2851                 (when (looking-at "\\([^:]+\\): *")
2852                   (put-text-property (match-beginning 1) (1+ (match-end 1))
2853                                      'face bface)
2854                   (put-text-property (match-end 0) (point-max)
2855                                      'face eface)))))))))
2856
2857 (eval-and-compile
2858   (mapcar
2859    (lambda (func)
2860      (let (afunc gfunc)
2861        (if (consp func)
2862            (setq afunc (car func)
2863                  gfunc (cdr func))
2864          (setq afunc func
2865                gfunc (intern (format "gnus-%s" func))))
2866        (defalias gfunc
2867          (if (fboundp afunc)
2868            `(lambda (&optional interactive &rest args)
2869               ,(documentation afunc t)
2870               (interactive (list t))
2871               (save-excursion
2872                 (set-buffer gnus-article-buffer)
2873                 (if interactive
2874                     (call-interactively ',afunc)
2875                   (apply ',afunc args))))))))
2876    '(article-hide-headers
2877      article-verify-x-pgp-sig
2878      article-hide-boring-headers
2879      article-treat-overstrike
2880      article-fill-long-lines
2881      article-capitalize-sentences
2882      article-remove-cr
2883      article-remove-leading-whitespace
2884      article-display-x-face
2885      article-de-quoted-unreadable
2886      article-de-base64-unreadable
2887      article-decode-HZ
2888      article-wash-html
2889      article-hide-list-identifiers
2890      article-hide-pgp
2891      article-strip-banner
2892      article-babel
2893      article-hide-pem
2894      article-hide-signature
2895      article-strip-headers-in-body
2896      article-remove-trailing-blank-lines
2897      article-strip-leading-blank-lines
2898      article-strip-multiple-blank-lines
2899      article-strip-leading-space
2900      article-strip-trailing-space
2901      article-strip-blank-lines
2902      article-strip-all-blank-lines
2903      article-replace-with-quoted-text
2904      article-date-local
2905      article-date-english
2906      article-date-iso8601
2907      article-date-original
2908      article-date-ut
2909      article-decode-mime-words
2910      article-decode-charset
2911      article-decode-encoded-words
2912      article-date-user
2913      article-date-lapsed
2914      article-emphasize
2915      article-treat-dumbquotes
2916      article-normalize-headers
2917      (article-show-all . gnus-article-show-all-headers))))
2918 \f
2919 ;;;
2920 ;;; Gnus article mode
2921 ;;;
2922
2923 (put 'gnus-article-mode 'mode-class 'special)
2924
2925 (set-keymap-parent gnus-article-mode-map widget-keymap)
2926
2927 (gnus-define-keys gnus-article-mode-map
2928   " " gnus-article-goto-next-page
2929   "\177" gnus-article-goto-prev-page
2930   [delete] gnus-article-goto-prev-page
2931   [backspace] gnus-article-goto-prev-page
2932   "\C-c^" gnus-article-refer-article
2933   "h" gnus-article-show-summary
2934   "s" gnus-article-show-summary
2935   "\C-c\C-m" gnus-article-mail
2936   "?" gnus-article-describe-briefly
2937   "e" gnus-summary-edit-article
2938   "<" beginning-of-buffer
2939   ">" end-of-buffer
2940   "\C-c\C-i" gnus-info-find-node
2941   "\C-c\C-b" gnus-bug
2942   "\C-hk" gnus-article-describe-key
2943   "\C-hc" gnus-article-describe-key-briefly
2944
2945   "\C-d" gnus-article-read-summary-keys
2946   "\M-*" gnus-article-read-summary-keys
2947   "\M-#" gnus-article-read-summary-keys
2948   "\M-^" gnus-article-read-summary-keys
2949   "\M-g" gnus-article-read-summary-keys)
2950
2951 (substitute-key-definition
2952  'undefined 'gnus-article-read-summary-keys gnus-article-mode-map)
2953
2954 (defun gnus-article-make-menu-bar ()
2955   (unless (boundp 'gnus-article-commands-menu)
2956     (gnus-summary-make-menu-bar))
2957   (gnus-turn-off-edit-menu 'article)
2958   (unless (boundp 'gnus-article-article-menu)
2959     (easy-menu-define
2960      gnus-article-article-menu gnus-article-mode-map ""
2961      '("Article"
2962        ["Scroll forwards" gnus-article-goto-next-page t]
2963        ["Scroll backwards" gnus-article-goto-prev-page t]
2964        ["Show summary" gnus-article-show-summary t]
2965        ["Fetch Message-ID at point" gnus-article-refer-article t]
2966        ["Mail to address at point" gnus-article-mail t]
2967        ["Send a bug report" gnus-bug t]))
2968
2969     (easy-menu-define
2970      gnus-article-treatment-menu gnus-article-mode-map ""
2971      ;; Fixme: this should use :active (and maybe :visible).
2972      '("Treatment"
2973        ["Hide headers" gnus-article-hide-headers t]
2974        ["Hide signature" gnus-article-hide-signature t]
2975        ["Hide citation" gnus-article-hide-citation t]
2976        ["Treat overstrike" gnus-article-treat-overstrike t]
2977        ["Remove carriage return" gnus-article-remove-cr t]
2978        ["Remove leading whitespace" gnus-article-remove-leading-whitespace t]
2979        ["Remove quoted-unreadable" gnus-article-de-quoted-unreadable t]
2980        ["Remove base64" gnus-article-de-base64-unreadable t]
2981        ["Treat html" gnus-article-wash-html t]
2982        ["Decode HZ" gnus-article-decode-HZ t]))
2983
2984     ;; Note "Commands" menu is defined in gnus-sum.el for consistency
2985
2986     ;; Note "Post" menu is defined in gnus-sum.el for consistency
2987     
2988     (gnus-run-hooks 'gnus-article-menu-hook)))
2989
2990 ;; Fixme: do something for the Emacs tool bar in Article mode a la
2991 ;; Summary.
2992
2993 (defun gnus-article-mode ()
2994   "Major mode for displaying an article.
2995
2996 All normal editing commands are switched off.
2997
2998 The following commands are available in addition to all summary mode
2999 commands:
3000 \\<gnus-article-mode-map>
3001 \\[gnus-article-next-page]\t Scroll the article one page forwards
3002 \\[gnus-article-prev-page]\t Scroll the article one page backwards
3003 \\[gnus-article-refer-article]\t Go to the article referred to by an article id near point
3004 \\[gnus-article-show-summary]\t Display the summary buffer
3005 \\[gnus-article-mail]\t Send a reply to the address near point
3006 \\[gnus-article-describe-briefly]\t Describe the current mode briefly
3007 \\[gnus-info-find-node]\t Go to the Gnus info node"
3008   (interactive)
3009   (gnus-simplify-mode-line)
3010   (setq mode-name "Article")
3011   (setq major-mode 'gnus-article-mode)
3012   (make-local-variable 'minor-mode-alist)
3013   (use-local-map gnus-article-mode-map)
3014   (when (gnus-visual-p 'article-menu 'menu)
3015     (gnus-article-make-menu-bar))
3016   (gnus-update-format-specifications nil 'article-mode)
3017   (set (make-local-variable 'page-delimiter) gnus-page-delimiter)
3018   (make-local-variable 'gnus-page-broken)
3019   (make-local-variable 'gnus-button-marker-list)
3020   (make-local-variable 'gnus-article-current-summary)
3021   (make-local-variable 'gnus-article-mime-handles)
3022   (make-local-variable 'gnus-article-decoded-p)
3023   (make-local-variable 'gnus-article-mime-handle-alist)
3024   (make-local-variable 'gnus-article-wash-types)
3025   (make-local-variable 'gnus-article-charset)
3026   (make-local-variable 'gnus-article-ignored-charsets)
3027   (gnus-set-default-directory)
3028   (buffer-disable-undo)
3029   (setq buffer-read-only t)
3030   (set-syntax-table gnus-article-mode-syntax-table)
3031   (mm-enable-multibyte)
3032   (gnus-run-hooks 'gnus-article-mode-hook))
3033
3034 (defun gnus-article-setup-buffer ()
3035   "Initialize the article buffer."
3036   (let* ((name (if gnus-single-article-buffer "*Article*"
3037                  (concat "*Article " gnus-newsgroup-name "*")))
3038          (original
3039           (progn (string-match "\\*Article" name)
3040                  (concat " *Original Article"
3041                          (substring name (match-end 0))))))
3042     (setq gnus-article-buffer name)
3043     (setq gnus-original-article-buffer original)
3044     (setq gnus-article-mime-handle-alist nil)
3045     ;; This might be a variable local to the summary buffer.
3046     (unless gnus-single-article-buffer
3047       (save-excursion
3048         (set-buffer gnus-summary-buffer)
3049         (setq gnus-article-buffer name)
3050         (setq gnus-original-article-buffer original)
3051         (gnus-set-global-variables)))
3052     (gnus-article-setup-highlight-words)
3053     ;; Init original article buffer.
3054     (save-excursion
3055       (set-buffer (gnus-get-buffer-create gnus-original-article-buffer))
3056       (mm-enable-multibyte)
3057       (setq major-mode 'gnus-original-article-mode)
3058       (make-local-variable 'gnus-original-article))
3059     (if (get-buffer name)
3060         (save-excursion
3061           (set-buffer name)
3062           (when gnus-article-mime-handles
3063             (mm-destroy-parts gnus-article-mime-handles)
3064             (setq gnus-article-mime-handles nil))
3065           ;; Set it to nil in article-buffer!
3066           (setq gnus-article-mime-handle-alist nil)
3067           (buffer-disable-undo)
3068           (setq buffer-read-only t)
3069           (unless (eq major-mode 'gnus-article-mode)
3070             (gnus-article-mode))
3071           (current-buffer))
3072       (save-excursion
3073         (set-buffer (gnus-get-buffer-create name))
3074         (gnus-article-mode)
3075         (make-local-variable 'gnus-summary-buffer)
3076         (gnus-summary-set-local-parameters gnus-newsgroup-name)
3077         (current-buffer)))))
3078
3079 ;; Set article window start at LINE, where LINE is the number of lines
3080 ;; from the head of the article.
3081 (defun gnus-article-set-window-start (&optional line)
3082   (set-window-start
3083    (get-buffer-window gnus-article-buffer t)
3084    (save-excursion
3085      (set-buffer gnus-article-buffer)
3086      (goto-char (point-min))
3087      (if (not line)
3088          (point-min)
3089        (gnus-message 6 "Moved to bookmark")
3090        (search-forward "\n\n" nil t)
3091        (forward-line line)
3092        (point)))))
3093
3094 (defun gnus-article-prepare (article &optional all-headers header)
3095   "Prepare ARTICLE in article mode buffer.
3096 ARTICLE should either be an article number or a Message-ID.
3097 If ARTICLE is an id, HEADER should be the article headers.
3098 If ALL-HEADERS is non-nil, no headers are hidden."
3099   (save-excursion
3100     ;; Make sure we start in a summary buffer.
3101     (unless (eq major-mode 'gnus-summary-mode)
3102       (set-buffer gnus-summary-buffer))
3103     (setq gnus-summary-buffer (current-buffer))
3104     (let* ((gnus-article (if header (mail-header-number header) article))
3105            (summary-buffer (current-buffer))
3106            (gnus-tmp-internal-hook gnus-article-internal-prepare-hook)
3107            (group gnus-newsgroup-name)
3108            result)
3109       (save-excursion
3110         (gnus-article-setup-buffer)
3111         (set-buffer gnus-article-buffer)
3112         ;; Deactivate active regions.
3113         (when (and (boundp 'transient-mark-mode)
3114                    transient-mark-mode)
3115           (setq mark-active nil))
3116         (if (not (setq result (let ((buffer-read-only nil))
3117                                 (gnus-request-article-this-buffer
3118                                  article group))))
3119             ;; There is no such article.
3120             (save-excursion
3121               (when (and (numberp article)
3122                          (not (memq article gnus-newsgroup-sparse)))
3123                 (setq gnus-article-current
3124                       (cons gnus-newsgroup-name article))
3125                 (set-buffer gnus-summary-buffer)
3126                 (setq gnus-current-article article)
3127                 (if (eq (gnus-article-mark article) gnus-undownloaded-mark)
3128                     (progn
3129                       (gnus-summary-set-agent-mark article)
3130                       (message "Message marked for downloading"))
3131                   (gnus-summary-mark-article article gnus-canceled-mark)
3132                   (unless (memq article gnus-newsgroup-sparse)
3133                     (gnus-error 1 "No such article (may have expired or been canceled)")))))
3134           (if (or (eq result 'pseudo)
3135                   (eq result 'nneething))
3136               (progn
3137                 (save-excursion
3138                   (set-buffer summary-buffer)
3139                   (push article gnus-newsgroup-history)
3140                   (setq gnus-last-article gnus-current-article
3141                         gnus-current-article 0
3142                         gnus-current-headers nil
3143                         gnus-article-current nil)
3144                   (if (eq result 'nneething)
3145                       (gnus-configure-windows 'summary)
3146                     (gnus-configure-windows 'article))
3147                   (gnus-set-global-variables))
3148                 (let ((gnus-article-mime-handle-alist-1
3149                        gnus-article-mime-handle-alist))
3150                   (gnus-set-mode-line 'article)))
3151             ;; The result from the `request' was an actual article -
3152             ;; or at least some text that is now displayed in the
3153             ;; article buffer.
3154             (when (and (numberp article)
3155                        (not (eq article gnus-current-article)))
3156               ;; Seems like a new article has been selected.
3157               ;; `gnus-current-article' must be an article number.
3158               (save-excursion
3159                 (set-buffer summary-buffer)
3160                 (push article gnus-newsgroup-history)
3161                 (setq gnus-last-article gnus-current-article
3162                       gnus-current-article article
3163                       gnus-current-headers
3164                       (gnus-summary-article-header gnus-current-article)
3165                       gnus-article-current
3166                       (cons gnus-newsgroup-name gnus-current-article))
3167                 (unless (vectorp gnus-current-headers)
3168                   (setq gnus-current-headers nil))
3169                 (gnus-summary-goto-subject gnus-current-article)
3170                 (when (gnus-summary-show-thread)
3171                   ;; If the summary buffer really was folded, the
3172                   ;; previous goto may not actually have gone to
3173                   ;; the right article, but the thread root instead.
3174                   ;; So we go again.
3175                   (gnus-summary-goto-subject gnus-current-article))
3176                 (gnus-run-hooks 'gnus-mark-article-hook)
3177                 (gnus-set-mode-line 'summary)
3178                 (when (gnus-visual-p 'article-highlight 'highlight)
3179                   (gnus-run-hooks 'gnus-visual-mark-article-hook))
3180                 ;; Set the global newsgroup variables here.
3181                 (gnus-set-global-variables)
3182                 (setq gnus-have-all-headers
3183                       (or all-headers gnus-show-all-headers))))
3184             (save-excursion
3185               (gnus-configure-windows 'article))
3186             (when (or (numberp article)
3187                       (stringp article))
3188               (gnus-article-prepare-display)
3189               ;; Do page break.
3190               (goto-char (point-min))
3191               (setq gnus-page-broken
3192                     (when gnus-break-pages
3193                       (gnus-narrow-to-page)
3194                       t)))
3195             (let ((gnus-article-mime-handle-alist-1
3196                    gnus-article-mime-handle-alist))
3197               (gnus-set-mode-line 'article))
3198             (article-goto-body)
3199             (set-window-point (get-buffer-window (current-buffer)) (point))
3200             (gnus-configure-windows 'article)
3201             t))))))
3202
3203 ;;;###autoload
3204 (defun gnus-article-prepare-display ()
3205   "Make the current buffer look like a nice article."
3206   ;; Hooks for getting information from the article.
3207   ;; This hook must be called before being narrowed.
3208   (let ((gnus-article-buffer (current-buffer))
3209         buffer-read-only)
3210     (unless (eq major-mode 'gnus-article-mode)
3211       (gnus-article-mode))
3212     (setq buffer-read-only nil
3213           gnus-article-wash-types nil)
3214     (gnus-run-hooks 'gnus-tmp-internal-hook)
3215     (when gnus-display-mime-function
3216       (funcall gnus-display-mime-function))
3217     (gnus-run-hooks 'gnus-article-prepare-hook)))
3218
3219 ;;;
3220 ;;; Gnus MIME viewing functions
3221 ;;;
3222
3223 (defvar gnus-mime-button-line-format "%{%([%p. %d%T]%)%}%e\n"
3224   "The following specs can be used:
3225 %t  The MIME type
3226 %T  MIME type, along with additional info
3227 %n  The `name' parameter
3228 %d  The description, if any
3229 %l  The length of the encoded part
3230 %p  The part identifier number
3231 %e  Dots if the part isn't displayed")
3232
3233 (defvar gnus-mime-button-line-format-alist
3234   '((?t gnus-tmp-type ?s)
3235     (?T gnus-tmp-type-long ?s)
3236     (?n gnus-tmp-name ?s)
3237     (?d gnus-tmp-description ?s)
3238     (?p gnus-tmp-id ?s)
3239     (?l gnus-tmp-length ?d)
3240     (?e gnus-tmp-dots ?s)))
3241
3242 (defvar gnus-mime-button-commands
3243   '((gnus-article-press-button "\r" "Toggle Display")
3244     (gnus-mime-view-part "v" "View Interactively...")
3245     (gnus-mime-view-part-as-type "t" "View As Type...")
3246     (gnus-mime-view-part-as-charset "C" "View As charset...")
3247     (gnus-mime-save-part "o" "Save...")
3248     (gnus-mime-save-part-and-strip "\C-o" "Save and Strip")
3249     (gnus-mime-copy-part "c" "View As Text, In Other Buffer")
3250     (gnus-mime-inline-part "i" "View As Text, In This Buffer")
3251     (gnus-mime-internalize-part "E" "View Internally")
3252     (gnus-mime-externalize-part "e" "View Externally")
3253     (gnus-mime-pipe-part "|" "Pipe To Command...")
3254     (gnus-mime-action-on-part "." "Take action on the part")))
3255
3256 (defun gnus-article-mime-part-status ()
3257   (if gnus-article-mime-handle-alist-1
3258       (if (eq 1 (length gnus-article-mime-handle-alist-1))
3259           " (1 part)"
3260         (format " (%d parts)" (length gnus-article-mime-handle-alist-1)))
3261     ""))
3262
3263 (defvar gnus-mime-button-map
3264   (let ((map (make-sparse-keymap)))
3265     (unless (>= (string-to-number emacs-version) 21)
3266       ;; XEmacs doesn't care.
3267       (set-keymap-parent map gnus-article-mode-map))
3268     (define-key map gnus-mouse-2 'gnus-article-push-button)
3269     (define-key map gnus-down-mouse-3 'gnus-mime-button-menu)
3270     (dolist (c gnus-mime-button-commands)
3271       (define-key map (cadr c) (car c)))
3272     map))
3273
3274 (defun gnus-mime-button-menu (event)
3275   "Construct a context-sensitive menu of MIME commands."
3276   (interactive "e")
3277   (save-window-excursion
3278     (let ((pos (event-start event)))
3279       (select-window (posn-window pos))
3280       (goto-char (posn-point pos))
3281       (gnus-article-check-buffer)
3282       (let ((response (x-popup-menu
3283                        t `("MIME Part"
3284                            ("" ,@(mapcar (lambda (c)
3285                                            (cons (caddr c) (car c)))
3286                                          gnus-mime-button-commands))))))
3287         (if response
3288             (call-interactively response))))))
3289
3290 (defun gnus-mime-view-all-parts (&optional handles)
3291   "View all the MIME parts."
3292   (interactive)
3293   (save-current-buffer
3294     (set-buffer gnus-article-buffer)
3295     (let ((handles (or handles gnus-article-mime-handles))
3296           (mail-parse-charset gnus-newsgroup-charset)
3297           (mail-parse-ignored-charsets
3298            (with-current-buffer gnus-summary-buffer
3299              gnus-newsgroup-ignored-charsets)))
3300       (when handles
3301         (mm-remove-parts handles)
3302         (goto-char (point-min))
3303         (or (search-forward "\n\n") (goto-char (point-max)))
3304         (let (buffer-read-only)
3305           (delete-region (point) (point-max)))
3306         (mm-display-parts handles)))))
3307
3308 (defun gnus-mime-save-part-and-strip ()
3309   "Save the MIME part under point then replace it with an external body."
3310   (interactive)
3311   (gnus-article-check-buffer)
3312   (let* ((data (get-text-property (point) 'gnus-data))
3313          file param)
3314     (if (mm-multiple-handles gnus-article-mime-handles)
3315         (error "This function is not implemented."))
3316     (setq file (and data (mm-save-part data)))
3317     (when file
3318       (with-current-buffer (mm-handle-buffer data)
3319         (erase-buffer)
3320         (insert "Content-Type: " (mm-handle-media-type data))
3321         (mml-insert-parameter-string (cdr (mm-handle-type data))
3322                                      '(charset))
3323         (insert "\n")
3324         (insert "Content-ID: " (message-make-message-id) "\n")
3325         (insert "Content-Transfer-Encoding: binary\n")
3326         (insert "\n"))
3327       (setcdr data
3328               (cdr (mm-make-handle nil
3329                                    `("message/external-body"
3330                                      (access-type . "LOCAL-FILE")
3331                                      (name . ,file)))))
3332       (set-buffer gnus-summary-buffer)
3333       (gnus-article-edit-article
3334        `(lambda ()
3335            (erase-buffer)
3336            (let ((mail-parse-charset (or gnus-article-charset
3337                                          ',gnus-newsgroup-charset))
3338                  (mail-parse-ignored-charsets
3339                   (or gnus-article-ignored-charsets
3340                       ',gnus-newsgroup-ignored-charsets))
3341                  (mbl mml-buffer-list))
3342              (setq mml-buffer-list nil)
3343              (insert-buffer gnus-original-article-buffer)
3344              (mime-to-mml gnus-article-mime-handles)
3345              (setq gnus-article-mime-handles nil)
3346              (make-local-hook 'kill-buffer-hook)
3347              (let ((mbl1 mml-buffer-list))
3348                (setq mml-buffer-list mbl)
3349                (set (make-local-variable 'mml-buffer-list) mbl1))
3350              (add-hook 'kill-buffer-hook 'mml-destroy-buffers t t)))
3351        `(lambda (no-highlight)
3352           (let ((mail-parse-charset (or gnus-article-charset
3353                                         ',gnus-newsgroup-charset))
3354                 (message-options message-options)
3355                 (message-options-set-recipient)
3356                 (mail-parse-ignored-charsets
3357                  (or gnus-article-ignored-charsets
3358                      ',gnus-newsgroup-ignored-charsets)))
3359            (mml-to-mime)
3360            (mml-destroy-buffers)
3361            (remove-hook 'kill-buffer-hook
3362                         'mml-destroy-buffers t)
3363            (kill-local-variable 'mml-buffer-list))
3364           (gnus-summary-edit-article-done
3365            ,(or (mail-header-references gnus-current-headers) "")
3366            ,(gnus-group-read-only-p)
3367            ,gnus-summary-buffer no-highlight))))))
3368
3369 (defun gnus-mime-save-part ()
3370   "Save the MIME part under point."
3371   (interactive)
3372   (gnus-article-check-buffer)
3373   (let ((data (get-text-property (point) 'gnus-data)))
3374     (when data
3375       (mm-save-part data))))
3376
3377 (defun gnus-mime-pipe-part ()
3378   "Pipe the MIME part under point to a process."
3379   (interactive)
3380   (gnus-article-check-buffer)
3381   (let ((data (get-text-property (point) 'gnus-data)))
3382     (when data
3383       (mm-pipe-part data))))
3384
3385 (defun gnus-mime-view-part ()
3386   "Interactively choose a viewing method for the MIME part under point."
3387   (interactive)
3388   (gnus-article-check-buffer)
3389   (let ((data (get-text-property (point) 'gnus-data)))
3390     (when data
3391       (setq gnus-article-mime-handles
3392             (mm-merge-handles
3393              gnus-article-mime-handles (setq data (copy-sequence data))))
3394       (mm-interactively-view-part data))))
3395
3396 (defun gnus-mime-view-part-as-type-internal ()
3397   (gnus-article-check-buffer)
3398   (let* ((name (mail-content-type-get
3399                 (mm-handle-type (get-text-property (point) 'gnus-data))
3400                 'name))
3401          (def-type (and name (mm-default-file-encoding name))))
3402     (and def-type (cons def-type 0))))
3403
3404 (defun gnus-mime-view-part-as-type (&optional mime-type)
3405   "Choose a MIME media type, and view the part as such."
3406   (interactive)
3407   (unless mime-type
3408     (setq mime-type (completing-read
3409                      "View as MIME type: "
3410                      (mapcar #'list (mailcap-mime-types))
3411                      nil nil
3412                      (gnus-mime-view-part-as-type-internal))))
3413   (gnus-article-check-buffer)
3414   (let ((handle (get-text-property (point) 'gnus-data)))
3415     (when handle
3416       (setq handle
3417             (mm-make-handle (mm-handle-buffer handle)
3418                             (cons mime-type (cdr (mm-handle-type handle)))
3419                             (mm-handle-encoding handle)
3420                             (mm-handle-undisplayer handle)
3421                             (mm-handle-disposition handle)
3422                             (mm-handle-description handle)
3423                             (mm-handle-cache handle)
3424                             (mm-handle-id handle)))
3425       (setq gnus-article-mime-handles
3426             (mm-merge-handles gnus-article-mime-handles handle))
3427       (gnus-mm-display-part handle))))
3428
3429 (defun gnus-mime-copy-part (&optional handle)
3430   "Put the the MIME part under point into a new buffer."
3431   (interactive)
3432   (gnus-article-check-buffer)
3433   (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
3434          (contents (and handle (mm-get-part handle)))
3435          (base (and handle
3436                     (file-name-nondirectory
3437                      (or
3438                       (mail-content-type-get (mm-handle-type handle) 'name)
3439                       (mail-content-type-get (mm-handle-type handle)
3440                                              'filename)
3441                       "*decoded*"))))
3442          (buffer (and base (generate-new-buffer base))))
3443     (when contents
3444       (switch-to-buffer buffer)
3445       (insert contents)
3446       ;; We do it this way to make `normal-mode' set the appropriate mode.
3447       (unwind-protect
3448           (progn
3449             (setq buffer-file-name (expand-file-name base))
3450             (normal-mode))
3451         (setq buffer-file-name nil))
3452       (goto-char (point-min)))))
3453
3454 (defun gnus-mime-inline-part (&optional handle arg)
3455   "Insert the MIME part under point into the current buffer."
3456   (interactive (list nil current-prefix-arg))
3457   (gnus-article-check-buffer)
3458   (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
3459          contents charset
3460          (b (point))
3461          buffer-read-only)
3462     (when handle
3463       (if (and (not arg) (mm-handle-undisplayer handle))
3464           (mm-remove-part handle)
3465         (setq contents (mm-get-part handle))
3466         (cond
3467          ((not arg)
3468           (setq charset (or (mail-content-type-get
3469                              (mm-handle-type handle) 'charset)
3470                             gnus-newsgroup-charset)))
3471          ((numberp arg)
3472           (if (mm-handle-undisplayer handle)
3473               (mm-remove-part handle))
3474           (setq charset
3475                 (or (cdr (assq arg
3476                                gnus-summary-show-article-charset-alist))
3477                     (read-coding-system "Charset: ")))))
3478         (forward-line 2)
3479         (mm-insert-inline handle
3480                           (if (and charset
3481                                    (setq charset (mm-charset-to-coding-system
3482                                                   charset))
3483                                    (not (eq charset 'ascii)))
3484                               (mm-decode-coding-string contents charset)
3485                             contents))
3486         (goto-char b)))))
3487
3488 (defun gnus-mime-view-part-as-charset (&optional handle arg)
3489   "Insert the MIME part under point into the current buffer using the
3490 specified charset."
3491   (interactive (list nil current-prefix-arg))
3492   (gnus-article-check-buffer)
3493   (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
3494          contents charset
3495          (b (point))
3496          buffer-read-only)
3497     (when handle
3498       (if (mm-handle-undisplayer handle)
3499           (mm-remove-part handle))
3500       (let ((gnus-newsgroup-charset
3501              (or (cdr (assq arg
3502                             gnus-summary-show-article-charset-alist))
3503                  (read-coding-system "Charset: ")))
3504           (gnus-newsgroup-ignored-charsets 'gnus-all))
3505         (gnus-article-press-button)))))
3506
3507 (defun gnus-mime-externalize-part (&optional handle)
3508   "View the MIME part under point with an external viewer."
3509   (interactive)
3510   (gnus-article-check-buffer)
3511   (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
3512          (mm-user-display-methods nil)
3513          (mm-inlined-types nil)
3514          (mail-parse-charset gnus-newsgroup-charset)
3515          (mail-parse-ignored-charsets
3516           (save-excursion (set-buffer gnus-summary-buffer)
3517                           gnus-newsgroup-ignored-charsets)))
3518     (when handle
3519       (if (mm-handle-undisplayer handle)
3520           (mm-remove-part handle)
3521         (mm-display-part handle)))))
3522
3523 (defun gnus-mime-internalize-part (&optional handle)
3524   "View the MIME part under point with an internal viewer.
3525 If no internal viewer is available, use an external viewer."
3526   (interactive)
3527   (gnus-article-check-buffer)
3528   (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
3529          (mm-inlined-types '(".*"))
3530          (mm-inline-large-images t)
3531          (mail-parse-charset gnus-newsgroup-charset)
3532          (mail-parse-ignored-charsets
3533           (save-excursion (set-buffer gnus-summary-buffer)
3534                           gnus-newsgroup-ignored-charsets)))
3535     (when handle
3536       (if (mm-handle-undisplayer handle)
3537           (mm-remove-part handle)
3538         (mm-display-part handle)))))
3539
3540 (defun gnus-mime-action-on-part (&optional action)
3541   "Do something with the MIME attachment at \(point\)."
3542   (interactive
3543    (list (completing-read "Action: " gnus-mime-action-alist)))
3544   (gnus-article-check-buffer)
3545   (let ((action-pair (assoc action gnus-mime-action-alist)))
3546     (if action-pair
3547         (funcall (cdr action-pair)))))
3548
3549 (defun gnus-article-part-wrapper (n function)
3550   (save-current-buffer
3551     (set-buffer gnus-article-buffer)
3552     (when (> n (length gnus-article-mime-handle-alist))
3553       (error "No such part"))
3554     (gnus-article-goto-part n)
3555     (let ((handle (cdr (assq n gnus-article-mime-handle-alist))))
3556       (funcall function handle))))
3557
3558 (defun gnus-article-pipe-part (n)
3559   "Pipe MIME part N, which is the numerical prefix."
3560   (interactive "p")
3561   (gnus-article-part-wrapper n 'mm-pipe-part))
3562
3563 (defun gnus-article-save-part (n)
3564   "Save MIME part N, which is the numerical prefix."
3565   (interactive "p")
3566   (gnus-article-part-wrapper n 'mm-save-part))
3567
3568 (defun gnus-article-interactively-view-part (n)
3569   "View MIME part N interactively, which is the numerical prefix."
3570   (interactive "p")
3571   (gnus-article-part-wrapper n 'mm-interactively-view-part))
3572
3573 (defun gnus-article-copy-part (n)
3574   "Copy MIME part N, which is the numerical prefix."
3575   (interactive "p")
3576   (gnus-article-part-wrapper n 'gnus-mime-copy-part))
3577
3578 (defun gnus-article-view-part-as-charset (n)
3579   "Copy MIME part N, which is the numerical prefix."
3580   (interactive "p")
3581   (gnus-article-part-wrapper n 'gnus-mime-view-part-as-charset))
3582
3583 (defun gnus-article-externalize-part (n)
3584   "View MIME part N externally, which is the numerical prefix."
3585   (interactive "p")
3586   (gnus-article-part-wrapper n 'gnus-mime-externalize-part))
3587
3588 (defun gnus-article-inline-part (n)
3589   "Inline MIME part N, which is the numerical prefix."
3590   (interactive "p")
3591   (gnus-article-part-wrapper n 'gnus-mime-inline-part))
3592
3593 (defun gnus-article-mime-match-handle-first (condition)
3594   (if condition
3595       (let ((alist gnus-article-mime-handle-alist) ihandle n)
3596         (while (setq ihandle (pop alist))
3597           (if (and (cond
3598                     ((functionp condition)
3599                      (funcall condition (cdr ihandle)))
3600                     ((eq condition 'undisplayed)
3601                      (not (or (mm-handle-undisplayer (cdr ihandle))
3602                               (equal (mm-handle-media-type (cdr ihandle))
3603                                      "multipart/alternative"))))
3604                     ((eq condition 'undisplayed-alternative)
3605                      (not (mm-handle-undisplayer (cdr ihandle))))
3606                     (t t))
3607                    (gnus-article-goto-part (car ihandle))
3608                    (or (not n) (< (car ihandle) n)))
3609               (setq n (car ihandle))))
3610         (or n 1))
3611     1))
3612
3613 (defun gnus-article-view-part (&optional n)
3614   "View MIME part N, which is the numerical prefix."
3615   (interactive "P")
3616   (save-current-buffer
3617     (set-buffer gnus-article-buffer)
3618     (or (numberp n) (setq n (gnus-article-mime-match-handle-first
3619                              gnus-article-mime-match-handle-function)))
3620     (when (> n (length gnus-article-mime-handle-alist))
3621       (error "No such part"))
3622     (let ((handle (cdr (assq n gnus-article-mime-handle-alist))))
3623       (when (gnus-article-goto-part n)
3624         (if (equal (car handle) "multipart/alternative")
3625             (gnus-article-press-button)
3626           (when (eq (gnus-mm-display-part handle) 'internal)
3627             (gnus-set-window-start)))))))
3628
3629 (defsubst gnus-article-mime-total-parts ()
3630   (if (bufferp (car gnus-article-mime-handles))
3631       1 ;; single part
3632     (1- (length gnus-article-mime-handles))))
3633
3634 (defun gnus-mm-display-part (handle)
3635   "Display HANDLE and fix MIME button."
3636   (let ((id (get-text-property (point) 'gnus-part))
3637         (point (point))
3638         buffer-read-only)
3639     (forward-line 1)
3640     (prog1
3641         (let ((window (selected-window))
3642               (mail-parse-charset gnus-newsgroup-charset)
3643               (mail-parse-ignored-charsets
3644                (save-excursion (set-buffer gnus-summary-buffer)
3645                                gnus-newsgroup-ignored-charsets)))
3646           (save-excursion
3647             (unwind-protect
3648                 (let ((win (get-buffer-window (current-buffer) t))
3649                       (beg (point)))
3650                   (when win
3651                     (select-window win))
3652                   (goto-char point)
3653                   (forward-line)
3654                   (if (mm-handle-displayed-p handle)
3655                       ;; This will remove the part.
3656                       (mm-display-part handle)
3657                     (save-restriction
3658                       (narrow-to-region (point) (1+ (point)))
3659                       (mm-display-part handle)
3660                       ;; We narrow to the part itself and
3661                       ;; then call the treatment functions.
3662                       (goto-char (point-min))
3663                       (forward-line 1)
3664                       (narrow-to-region (point) (point-max))
3665                       (gnus-treat-article
3666                        nil id
3667                        (gnus-article-mime-total-parts)
3668                        (mm-handle-media-type handle)))))
3669               (select-window window))))
3670       (goto-char point)
3671       (delete-region (gnus-point-at-bol) (progn (forward-line 1) (point)))
3672       (gnus-insert-mime-button
3673        handle id (list (mm-handle-displayed-p handle)))
3674       (goto-char point))))
3675
3676 (defun gnus-article-goto-part (n)
3677   "Go to MIME part N."
3678   (let ((point (text-property-any (point-min) (point-max) 'gnus-part n)))
3679     (when point
3680       (goto-char point))))
3681
3682 (defun gnus-insert-mime-button (handle gnus-tmp-id &optional displayed)
3683   (let ((gnus-tmp-name
3684          (or (mail-content-type-get (mm-handle-type handle)
3685                                     'name)
3686              (mail-content-type-get (mm-handle-disposition handle)
3687                                     'filename)
3688              (mail-content-type-get (mm-handle-type handle)
3689                                     'url)
3690              ""))
3691         (gnus-tmp-type (mm-handle-media-type handle))
3692         (gnus-tmp-description
3693          (mail-decode-encoded-word-string (or (mm-handle-description handle)
3694                                               "")))
3695         (gnus-tmp-dots
3696          (if (if displayed (car displayed)
3697                (mm-handle-displayed-p handle))
3698              "" "..."))
3699         (gnus-tmp-length (with-current-buffer (mm-handle-buffer handle)
3700                            (buffer-size)))
3701         gnus-tmp-type-long b e)
3702     (when (string-match ".*/" gnus-tmp-name)
3703       (setq gnus-tmp-name (replace-match "" t t gnus-tmp-name)))
3704     (setq gnus-tmp-type-long (concat gnus-tmp-type
3705                                      (and (not (equal gnus-tmp-name ""))
3706                                           (concat "; " gnus-tmp-name))))
3707     (or (equal gnus-tmp-description "")
3708         (setq gnus-tmp-type-long (concat " --- " gnus-tmp-type-long)))
3709     (unless (bolp)
3710       (insert "\n"))
3711     (setq b (point))
3712     (gnus-eval-format
3713      gnus-mime-button-line-format gnus-mime-button-line-format-alist
3714      `(keymap ,gnus-mime-button-map
3715               ,@(if (>= (string-to-number emacs-version) 21)
3716                     nil
3717                   (list 'local-map gnus-mime-button-map))
3718               gnus-callback gnus-mm-display-part
3719               gnus-part ,gnus-tmp-id
3720               article-type annotation
3721               gnus-data ,handle))
3722     (setq e (point))
3723     (widget-convert-button
3724      'link b e
3725      :mime-handle handle
3726      :action 'gnus-widget-press-button
3727      :button-keymap gnus-mime-button-map
3728      :help-echo
3729      (lambda (widget/window &optional overlay pos)
3730        ;; Needed to properly clear the message due to a bug in
3731        ;; wid-edit (XEmacs only).
3732        (if (boundp 'help-echo-owns-message)
3733            (setq help-echo-owns-message t))
3734        (format
3735         "%S: %s the MIME part; %S: more options"
3736         (aref gnus-mouse-2 0)
3737         ;; XEmacs will get a single widget arg; Emacs 21 will get
3738         ;; window, overlay, position.
3739         (if (mm-handle-displayed-p
3740              (if overlay
3741                  (with-current-buffer (gnus-overlay-buffer overlay)
3742                    (widget-get (widget-at (gnus-overlay-start overlay))
3743                                :mime-handle))
3744                (widget-get widget/window :mime-handle)))
3745             "hide" "show")
3746         (aref gnus-down-mouse-3 0))))))
3747
3748 (defun gnus-widget-press-button (elems el)
3749   (goto-char (widget-get elems :from))
3750   (gnus-article-press-button))
3751
3752 (defvar gnus-displaying-mime nil)
3753
3754 (defun gnus-display-mime (&optional ihandles)
3755   "Display the MIME parts."
3756   (save-excursion
3757     (save-selected-window
3758       (let ((window (get-buffer-window gnus-article-buffer))
3759             (point (point)))
3760         (when window
3761           (select-window window)
3762           ;; We have to do this since selecting the window
3763           ;; may change the point.  So we set the window point.
3764           (set-window-point window point)))
3765       (let* ((handles (or ihandles (mm-dissect-buffer) (mm-uu-dissect)))
3766              buffer-read-only handle name type b e display)
3767         (when (and (not ihandles)
3768                    (not gnus-displaying-mime))
3769           ;; Top-level call; we clean up.
3770           (when gnus-article-mime-handles
3771             (mm-destroy-parts gnus-article-mime-handles)
3772             (setq gnus-article-mime-handle-alist nil));; A trick.
3773           (setq gnus-article-mime-handles handles)
3774           ;; We allow users to glean info from the handles.
3775           (when gnus-article-mime-part-function
3776             (gnus-mime-part-function handles)))
3777         (if (and handles
3778                  (or (not (stringp (car handles)))
3779                      (cdr handles)))
3780             (progn
3781               (when (and (not ihandles)
3782                          (not gnus-displaying-mime))
3783                 ;; Clean up for mime parts.
3784                 (article-goto-body)
3785                 (delete-region (point) (point-max)))
3786               (let ((gnus-displaying-mime t))
3787                 (gnus-mime-display-part handles)))
3788           (save-restriction
3789             (article-goto-body)
3790             (narrow-to-region (point) (point-max))
3791             (gnus-treat-article nil 1 1)
3792             (widen)))
3793         (unless ihandles
3794           ;; Highlight the headers.
3795           (save-excursion
3796             (save-restriction
3797               (article-goto-body)
3798               (narrow-to-region (point-min) (point))
3799               (gnus-treat-article 'head))))))))
3800
3801 (defvar gnus-mime-display-multipart-as-mixed nil)
3802 (defvar gnus-mime-display-multipart-alternative-as-mixed nil)
3803 (defvar gnus-mime-display-multipart-related-as-mixed nil)
3804
3805 (defun gnus-mime-display-part (handle)
3806   (cond
3807    ;; Single part.
3808    ((not (stringp (car handle)))
3809     (gnus-mime-display-single handle))
3810    ;; User-defined multipart
3811    ((cdr (assoc (car handle) gnus-mime-multipart-functions))
3812     (funcall (cdr (assoc (car handle) gnus-mime-multipart-functions))
3813              handle))
3814    ;; multipart/alternative
3815    ((and (equal (car handle) "multipart/alternative")
3816          (not (or gnus-mime-display-multipart-as-mixed
3817                   gnus-mime-display-multipart-alternative-as-mixed)))
3818     (let ((id (1+ (length gnus-article-mime-handle-alist))))
3819       (push (cons id handle) gnus-article-mime-handle-alist)
3820       (gnus-mime-display-alternative (cdr handle) nil nil id)))
3821    ;; multipart/related
3822    ((and (equal (car handle) "multipart/related")
3823          (not (or gnus-mime-display-multipart-as-mixed
3824                   gnus-mime-display-multipart-related-as-mixed)))
3825     ;;;!!!We should find the start part, but we just default
3826     ;;;!!!to the first part.
3827     ;;(gnus-mime-display-part (cadr handle))
3828     ;;;!!! Most multipart/related is an HTML message plus images.
3829     ;;;!!! Unfortunately we are unable to let W3 display those
3830     ;;;!!! included images, so we just display it as a mixed multipart.
3831     ;;(gnus-mime-display-mixed (cdr handle))
3832     ;;;!!! No, w3 can display everything just fine.
3833     (gnus-mime-display-part (cadr handle)))
3834    ((equal (car handle) "multipart/signed")
3835     (or (memq 'signed gnus-article-wash-types)
3836         (push 'signed gnus-article-wash-types))
3837     (gnus-mime-display-security handle))
3838    ((equal (car handle) "multipart/encrypted")
3839     (or (memq 'encrypted gnus-article-wash-types)
3840         (push 'encrypted gnus-article-wash-types))
3841     (gnus-mime-display-security handle))
3842    ;; Other multiparts are handled like multipart/mixed.
3843    (t
3844     (gnus-mime-display-mixed (cdr handle)))))
3845
3846 (defun gnus-mime-part-function (handles)
3847   (if (stringp (car handles))
3848       (mapcar 'gnus-mime-part-function (cdr handles))
3849     (funcall gnus-article-mime-part-function handles)))
3850
3851 (defun gnus-mime-display-mixed (handles)
3852   (mapcar 'gnus-mime-display-part handles))
3853
3854 (defun gnus-mime-display-single (handle)
3855   (let ((type (mm-handle-media-type handle))
3856         (ignored gnus-ignored-mime-types)
3857         (not-attachment t)
3858         (move nil)
3859         display text)
3860     (catch 'ignored
3861       (progn
3862         (while ignored
3863           (when (string-match (pop ignored) type)
3864             (throw 'ignored nil)))
3865         (if (and (setq not-attachment
3866                        (and (not (mm-inline-override-p handle))
3867                             (or (not (mm-handle-disposition handle))
3868                                 (equal (car (mm-handle-disposition handle))
3869                                        "inline")
3870                                 (mm-attachment-override-p handle))))
3871                  (mm-automatic-display-p handle)
3872                  (or (mm-inlined-p handle)
3873                      (mm-automatic-external-display-p type)))
3874             (setq display t)
3875           (when (equal (mm-handle-media-supertype handle) "text")
3876             (setq text t)))
3877         (let ((id (1+ (length gnus-article-mime-handle-alist)))
3878               beg)
3879           (push (cons id handle) gnus-article-mime-handle-alist)
3880           (when (or (not display)
3881                     (not (gnus-unbuttonized-mime-type-p type)))
3882             ;(gnus-article-insert-newline)
3883             (gnus-insert-mime-button
3884              handle id (list (or display (and not-attachment text))))
3885             (gnus-article-insert-newline)
3886             ;(gnus-article-insert-newline)
3887             ;; Remember modify the number of forward lines.
3888             (setq move t))
3889           (setq beg (point))
3890           (cond
3891            (display
3892             (when move
3893               (forward-line -1)
3894               (setq beg (point)))
3895             (let ((mail-parse-charset gnus-newsgroup-charset)
3896                   (mail-parse-ignored-charsets
3897                    (save-excursion (condition-case ()
3898                                        (set-buffer gnus-summary-buffer)
3899                                      (error))
3900                                    gnus-newsgroup-ignored-charsets)))
3901               (mm-display-part handle t))
3902             (goto-char (point-max)))
3903            ((and text not-attachment)
3904             (when move
3905               (forward-line -1)
3906               (setq beg (point)))
3907             (gnus-article-insert-newline)
3908             (mm-insert-inline handle (mm-get-part handle))
3909             (goto-char (point-max))))
3910           ;; Do highlighting.
3911           (save-excursion
3912             (save-restriction
3913               (narrow-to-region beg (point))
3914               (gnus-treat-article
3915                nil id
3916                (gnus-article-mime-total-parts)
3917                (mm-handle-media-type handle)))))))))
3918
3919 (defun gnus-unbuttonized-mime-type-p (type)
3920   "Say whether TYPE is to be unbuttonized."
3921   (unless gnus-inhibit-mime-unbuttonizing
3922     (catch 'found
3923       (let ((types gnus-unbuttonized-mime-types))
3924         (while types
3925           (when (string-match (pop types) type)
3926             (throw 'found t)))))))
3927
3928 (defun gnus-article-insert-newline ()
3929   "Insert a newline, but mark it as undeletable."
3930   (gnus-put-text-property
3931    (point) (progn (insert "\n") (point)) 'gnus-undeletable t))
3932
3933 (defun gnus-mime-display-alternative (handles &optional preferred ibegend id)
3934   (let* ((preferred (or preferred (mm-preferred-alternative handles)))
3935          (ihandles handles)
3936          (point (point))
3937          handle buffer-read-only from props begend not-pref)
3938     (save-window-excursion
3939       (save-restriction
3940         (when ibegend
3941           (narrow-to-region (car ibegend)
3942                             (or (cdr ibegend)
3943                                 (progn
3944                                   (goto-char (car ibegend))
3945                                   (forward-line 2)
3946                                   (point))))
3947           (delete-region (point-min) (point-max))
3948           (mm-remove-parts handles))
3949         (setq begend (list (point-marker)))
3950         ;; Do the toggle.
3951         (unless (setq not-pref (cadr (member preferred ihandles)))
3952           (setq not-pref (car ihandles)))
3953         (when (or ibegend
3954                   (not preferred)
3955                   (not (gnus-unbuttonized-mime-type-p
3956                         "multipart/alternative")))
3957           (gnus-add-text-properties
3958            (setq from (point))
3959            (progn
3960              (insert (format "%d.  " id))
3961              (point))
3962            `(gnus-callback
3963              (lambda (handles)
3964                (unless ,(not ibegend)
3965                  (setq gnus-article-mime-handle-alist
3966                        ',gnus-article-mime-handle-alist))
3967                (gnus-mime-display-alternative
3968                 ',ihandles ',not-pref ',begend ,id))
3969              ,@(if (>= (string-to-number emacs-version) 21)
3970                    nil ;; XEmacs doesn't care
3971                  (list 'local-map gnus-mime-button-map))
3972              ,gnus-mouse-face-prop ,gnus-article-mouse-face
3973              face ,gnus-article-button-face
3974              keymap ,gnus-mime-button-map
3975              gnus-part ,id
3976              gnus-data ,handle))
3977           (widget-convert-button 'link from (point)
3978                                  :action 'gnus-widget-press-button
3979                                  :button-keymap gnus-widget-button-keymap)
3980           ;; Do the handles
3981           (while (setq handle (pop handles))
3982             (gnus-add-text-properties
3983              (setq from (point))
3984              (progn
3985                (insert (format "(%c) %-18s"
3986                                (if (equal handle preferred) ?* ? )
3987                                (mm-handle-media-type handle)))
3988                (point))
3989              `(gnus-callback
3990                (lambda (handles)
3991                  (unless ,(not ibegend)
3992                    (setq gnus-article-mime-handle-alist
3993                          ',gnus-article-mime-handle-alist))
3994                  (gnus-mime-display-alternative
3995                   ',ihandles ',handle ',begend ,id))
3996                ,@(if (>= (string-to-number emacs-version) 21)
3997                      nil ;; XEmacs doesn't care
3998                    (list 'local-map gnus-mime-button-map))
3999                ,gnus-mouse-face-prop ,gnus-article-mouse-face
4000                face ,gnus-article-button-face
4001                keymap ,gnus-mime-button-map
4002                gnus-part ,id
4003                gnus-data ,handle))
4004             (widget-convert-button 'link from (point)
4005                                    :action 'gnus-widget-press-button
4006                                    :button-keymap gnus-widget-button-keymap)
4007             (insert "  "))
4008           (insert "\n\n"))
4009         (when preferred
4010           (if (stringp (car preferred))
4011               (gnus-display-mime preferred)
4012             (let ((mail-parse-charset gnus-newsgroup-charset)
4013                   (mail-parse-ignored-charsets
4014                    (save-excursion (set-buffer gnus-summary-buffer)
4015                                    gnus-newsgroup-ignored-charsets)))
4016               (mm-display-part preferred)
4017               ;; Do highlighting.
4018               (save-excursion
4019                 (save-restriction
4020                   (narrow-to-region (car begend) (point-max))
4021                   (gnus-treat-article
4022                    nil (length gnus-article-mime-handle-alist)
4023                    (gnus-article-mime-total-parts)
4024                    (mm-handle-media-type handle))))))
4025           (goto-char (point-max))
4026           (setcdr begend (point-marker)))))
4027     (when ibegend
4028       (goto-char point))))
4029
4030 (defun gnus-article-wash-status ()
4031   "Return a string which display status of article washing."
4032   (save-excursion
4033     (set-buffer gnus-article-buffer)
4034     (let ((cite (memq 'cite gnus-article-wash-types))
4035           (headers (memq 'headers gnus-article-wash-types))
4036           (boring (memq 'boring-headers gnus-article-wash-types))
4037           (pgp (memq 'pgp gnus-article-wash-types))
4038           (pem (memq 'pem gnus-article-wash-types))
4039           (signed (memq 'signed gnus-article-wash-types))
4040           (encrypted (memq 'encrypted gnus-article-wash-types))
4041           (signature (memq 'signature gnus-article-wash-types))
4042           (overstrike (memq 'overstrike gnus-article-wash-types))
4043           (emphasis (memq 'emphasis gnus-article-wash-types)))
4044       (format "%c%c%c%c%c%c"
4045               (if cite ?c ? )
4046               (if (or headers boring) ?h ? )
4047               (if (or pgp pem signed encrypted) ?p ? )
4048               (if signature ?s ? )
4049               (if overstrike ?o ? )
4050               (if emphasis ?e ? )))))
4051
4052 (defalias 'gnus-article-hide-headers-if-wanted 'gnus-article-maybe-hide-headers)
4053
4054 (defun gnus-article-maybe-hide-headers ()
4055   "Hide unwanted headers if `gnus-have-all-headers' is nil.
4056 Provided for backwards compatibility."
4057   (when (and (or (not (gnus-buffer-live-p gnus-summary-buffer))
4058                  (not (save-excursion (set-buffer gnus-summary-buffer)
4059                                       gnus-have-all-headers)))
4060              (not gnus-inhibit-hiding))
4061     (gnus-article-hide-headers)))
4062
4063 ;;; Article savers.
4064
4065 (defun gnus-output-to-file (file-name)
4066   "Append the current article to a file named FILE-NAME."
4067   (let ((artbuf (current-buffer)))
4068     (with-temp-buffer
4069       (insert-buffer-substring artbuf)
4070       ;; Append newline at end of the buffer as separator, and then
4071       ;; save it to file.
4072       (goto-char (point-max))
4073       (insert "\n")
4074       (mm-append-to-file (point-min) (point-max) file-name)
4075       t)))
4076
4077 (defun gnus-narrow-to-page (&optional arg)
4078   "Narrow the article buffer to a page.
4079 If given a numerical ARG, move forward ARG pages."
4080   (interactive "P")
4081   (setq arg (if arg (prefix-numeric-value arg) 0))
4082   (save-excursion
4083     (set-buffer gnus-article-buffer)
4084     (goto-char (point-min))
4085     (widen)
4086     ;; Remove any old next/prev buttons.
4087     (when (gnus-visual-p 'page-marker)
4088       (let ((buffer-read-only nil))
4089         (gnus-remove-text-with-property 'gnus-prev)
4090         (gnus-remove-text-with-property 'gnus-next)))
4091     (when
4092         (cond ((< arg 0)
4093                (re-search-backward page-delimiter nil 'move (1+ (abs arg))))
4094               ((> arg 0)
4095                (re-search-forward page-delimiter nil 'move arg)))
4096       (goto-char (match-end 0)))
4097     (narrow-to-region
4098      (point)
4099      (if (re-search-forward page-delimiter nil 'move)
4100          (match-beginning 0)
4101        (point)))
4102     (when (and (gnus-visual-p 'page-marker)
4103                (not (= (point-min) 1)))
4104       (save-excursion
4105         (goto-char (point-min))
4106         (gnus-insert-prev-page-button)))
4107     (when (and (gnus-visual-p 'page-marker)
4108                (< (+ (point-max) 2) (buffer-size)))
4109       (save-excursion
4110         (goto-char (point-max))
4111         (gnus-insert-next-page-button)))))
4112
4113 ;; Article mode commands
4114
4115 (defun gnus-article-goto-next-page ()
4116   "Show the next page of the article."
4117   (interactive)
4118   (when (gnus-article-next-page)
4119     (goto-char (point-min))
4120     (gnus-article-read-summary-keys nil (gnus-character-to-event ?n))))
4121
4122 (defun gnus-article-goto-prev-page ()
4123   "Show the next page of the article."
4124   (interactive)
4125   (if (bobp) (gnus-article-read-summary-keys nil (gnus-character-to-event ?p))
4126     (gnus-article-prev-page nil)))
4127
4128 (defun gnus-article-next-page (&optional lines)
4129   "Show the next page of the current article.
4130 If end of article, return non-nil.  Otherwise return nil.
4131 Argument LINES specifies lines to be scrolled up."
4132   (interactive "p")
4133   (move-to-window-line -1)
4134   (if (save-excursion
4135         (end-of-line)
4136         (and (pos-visible-in-window-p)  ;Not continuation line.
4137              (eobp)))
4138       ;; Nothing in this page.
4139       (if (or (not gnus-page-broken)
4140               (save-excursion
4141                 (save-restriction
4142                   (widen) (forward-line 1) (eobp)))) ;Real end-of-buffer?
4143           t                             ;Nothing more.
4144         (gnus-narrow-to-page 1)         ;Go to next page.
4145         nil)
4146     ;; More in this page.
4147     (let ((scroll-in-place nil))
4148       (condition-case ()
4149           (scroll-up lines)
4150         (end-of-buffer
4151          ;; Long lines may cause an end-of-buffer error.
4152          (goto-char (point-max)))))
4153     (move-to-window-line 0)
4154     nil))
4155
4156 (defun gnus-article-prev-page (&optional lines)
4157   "Show previous page of current article.
4158 Argument LINES specifies lines to be scrolled down."
4159   (interactive "p")
4160   (move-to-window-line 0)
4161   (if (and gnus-page-broken
4162            (bobp)
4163            (not (save-restriction (widen) (bobp)))) ;Real beginning-of-buffer?
4164       (progn
4165         (gnus-narrow-to-page -1)        ;Go to previous page.
4166         (goto-char (point-max))
4167         (recenter -1))
4168     (let ((scroll-in-place nil))
4169       (prog1
4170           (condition-case ()
4171               (scroll-down lines)
4172             (beginning-of-buffer
4173              (goto-char (point-min))))
4174         (move-to-window-line 0)))))
4175
4176 (defun gnus-article-refer-article ()
4177   "Read article specified by message-id around point."
4178   (interactive)
4179   (let ((point (point)))
4180     (search-forward ">" nil t)          ;Move point to end of "<....>".
4181     (if (re-search-backward "\\(<[^<> \t\n]+>\\)" nil t)
4182         (let ((message-id (match-string 1)))
4183           (goto-char point)
4184           (set-buffer gnus-summary-buffer)
4185           (gnus-summary-refer-article message-id))
4186       (goto-char (point))
4187       (error "No references around point"))))
4188
4189 (defun gnus-article-show-summary ()
4190   "Reconfigure windows to show summary buffer."
4191   (interactive)
4192   (if (not (gnus-buffer-live-p gnus-summary-buffer))
4193       (error "There is no summary buffer for this article buffer")
4194     (gnus-article-set-globals)
4195     (gnus-configure-windows 'article)
4196     (gnus-summary-goto-subject gnus-current-article)
4197     (gnus-summary-position-point)))
4198
4199 (defun gnus-article-describe-briefly ()
4200   "Describe article mode commands briefly."
4201   (interactive)
4202   (gnus-message 6 (substitute-command-keys "\\<gnus-article-mode-map>\\[gnus-article-goto-next-page]:Next page   \\[gnus-article-goto-prev-page]:Prev page  \\[gnus-article-show-summary]:Show summary  \\[gnus-info-find-node]:Run Info  \\[gnus-article-describe-briefly]:This help")))
4203
4204 (defun gnus-article-summary-command ()
4205   "Execute the last keystroke in the summary buffer."
4206   (interactive)
4207   (let ((obuf (current-buffer))
4208         (owin (current-window-configuration))
4209         func)
4210     (switch-to-buffer gnus-article-current-summary 'norecord)
4211     (setq func (lookup-key (current-local-map) (this-command-keys)))
4212     (call-interactively func)
4213     (set-buffer obuf)
4214     (set-window-configuration owin)
4215     (set-window-point (get-buffer-window (current-buffer)) (point))))
4216
4217 (defun gnus-article-summary-command-nosave ()
4218   "Execute the last keystroke in the summary buffer."
4219   (interactive)
4220   (let (func)
4221     (pop-to-buffer gnus-article-current-summary 'norecord)
4222     (setq func (lookup-key (current-local-map) (this-command-keys)))
4223     (call-interactively func)))
4224
4225 (defun gnus-article-check-buffer ()
4226   "Beep if not in an article buffer."
4227   (unless (equal major-mode 'gnus-article-mode)
4228     (error "Command invoked outside of a Gnus article buffer")))
4229
4230 (defun gnus-article-read-summary-keys (&optional arg key not-restore-window)
4231   "Read a summary buffer key sequence and execute it from the article buffer."
4232   (interactive "P")
4233   (gnus-article-check-buffer)
4234   (let ((nosaves
4235          '("q" "Q"  "c" "r" "R" "\C-c\C-f" "m"  "a" "f" "F"
4236            "Zc" "ZC" "ZE" "ZQ" "ZZ" "Zn" "ZR" "ZG" "ZN" "ZP"
4237            "=" "^" "\M-^" "|"))
4238         (nosave-but-article
4239          '("A\r"))
4240         (nosave-in-article
4241          '("\C-d"))
4242         (up-to-top
4243          '("n" "Gn" "p" "Gp"))
4244         keys new-sum-point)
4245     (save-excursion
4246       (set-buffer gnus-article-current-summary)
4247       (let (gnus-pick-mode)
4248         (push (or key last-command-event) unread-command-events)
4249         (setq keys (if (featurep 'xemacs)
4250                        (events-to-keys (read-key-sequence nil))
4251                      (read-key-sequence nil)))))
4252
4253     (message "")
4254
4255     (if (or (member keys nosaves)
4256             (member keys nosave-but-article)
4257             (member keys nosave-in-article))
4258         (let (func)
4259           (save-window-excursion
4260             (pop-to-buffer gnus-article-current-summary 'norecord)
4261             ;; We disable the pick minor mode commands.
4262             (let (gnus-pick-mode)
4263               (setq func (lookup-key (current-local-map) keys))))
4264           (if (or (not func)
4265                   (numberp func))
4266               (ding)
4267             (unless (member keys nosave-in-article)
4268               (set-buffer gnus-article-current-summary))
4269             (call-interactively func)
4270             (setq new-sum-point (point)))
4271           (when (member keys nosave-but-article)
4272             (pop-to-buffer gnus-article-buffer 'norecord)))
4273       ;; These commands should restore window configuration.
4274       (let ((obuf (current-buffer))
4275             (owin (current-window-configuration))
4276             (opoint (point))
4277             (summary gnus-article-current-summary)
4278             func in-buffer selected)
4279         (if not-restore-window
4280             (pop-to-buffer summary 'norecord)
4281           (switch-to-buffer summary 'norecord))
4282         (setq in-buffer (current-buffer))
4283         ;; We disable the pick minor mode commands.
4284         (if (and (setq func (let (gnus-pick-mode)
4285                               (lookup-key (current-local-map) keys)))
4286                  (functionp func))
4287             (progn
4288               (call-interactively func)
4289               (setq new-sum-point (point))
4290               (when (eq in-buffer (current-buffer))
4291                 (setq selected (gnus-summary-select-article))
4292                 (set-buffer obuf)
4293                 (unless not-restore-window
4294                   (set-window-configuration owin))
4295                 (when (eq selected 'old)
4296                   (article-goto-body)
4297                   (set-window-start (get-buffer-window (current-buffer))
4298                                     1)
4299                   (set-window-point (get-buffer-window (current-buffer))
4300                                     (point)))
4301                 (let ((win (get-buffer-window gnus-article-current-summary)))
4302                   (when win
4303                     (set-window-point win new-sum-point))))    )
4304           (switch-to-buffer gnus-article-buffer)
4305           (ding))))))
4306
4307 (defun gnus-article-describe-key (key)
4308   "Display documentation of the function invoked by KEY.  KEY is a string."
4309   (interactive "kDescribe key: ")
4310   (gnus-article-check-buffer)
4311   (if (eq (key-binding key) 'gnus-article-read-summary-keys)
4312       (save-excursion
4313         (set-buffer gnus-article-current-summary)
4314         (let (gnus-pick-mode)
4315           (if (featurep 'xemacs)
4316               (progn
4317                 (push (elt key 0) unread-command-events)
4318                 (setq key (events-to-keys 
4319                            (read-key-sequence "Describe key: "))))
4320             (setq unread-command-events 
4321                   (mapcar 
4322                    (lambda (x) (if (>= x 128) (list 'meta (- x 128)) x))
4323                    (string-to-list key)))
4324             (setq key (read-key-sequence "Describe key: "))))
4325         (describe-key key))
4326     (describe-key key)))
4327
4328 (defun gnus-article-describe-key-briefly (key &optional insert)
4329   "Display documentation of the function invoked by KEY.  KEY is a string."
4330   (interactive "kDescribe key: \nP")
4331   (gnus-article-check-buffer)
4332   (if (eq (key-binding key) 'gnus-article-read-summary-keys)
4333       (save-excursion
4334         (set-buffer gnus-article-current-summary)
4335         (let (gnus-pick-mode)
4336           (if (featurep 'xemacs)
4337               (progn
4338                 (push (elt key 0) unread-command-events)
4339                 (setq key (events-to-keys 
4340                            (read-key-sequence "Describe key: "))))
4341             (setq unread-command-events 
4342                   (mapcar 
4343                    (lambda (x) (if (>= x 128) (list 'meta (- x 128)) x))
4344                    (string-to-list key)))
4345             (setq key (read-key-sequence "Describe key: "))))
4346         (describe-key-briefly key insert))
4347     (describe-key-briefly key insert)))
4348
4349 (defun gnus-article-hide (&optional arg force)
4350   "Hide all the gruft in the current article.
4351 This means that PGP stuff, signatures, cited text and (some)
4352 headers will be hidden.
4353 If given a prefix, show the hidden text instead."
4354   (interactive (append (gnus-article-hidden-arg) (list 'force)))
4355   (gnus-article-hide-headers arg)
4356   (gnus-article-hide-list-identifiers arg)
4357   (gnus-article-hide-pgp arg)
4358   (gnus-article-hide-citation-maybe arg force)
4359   (gnus-article-hide-signature arg))
4360
4361 (defun gnus-article-maybe-highlight ()
4362   "Do some article highlighting if article highlighting is requested."
4363   (when (gnus-visual-p 'article-highlight 'highlight)
4364     (gnus-article-highlight-some)))
4365
4366 (defun gnus-check-group-server ()
4367   ;; Make sure the connection to the server is alive.
4368   (unless (gnus-server-opened
4369            (gnus-find-method-for-group gnus-newsgroup-name))
4370     (gnus-check-server (gnus-find-method-for-group gnus-newsgroup-name))
4371     (gnus-request-group gnus-newsgroup-name t)))
4372
4373 (defun gnus-request-article-this-buffer (article group)
4374   "Get an article and insert it into this buffer."
4375   (let (do-update-line sparse-header)
4376     (prog1
4377         (save-excursion
4378           (erase-buffer)
4379           (gnus-kill-all-overlays)
4380           (setq group (or group gnus-newsgroup-name))
4381
4382           ;; Using `gnus-request-article' directly will insert the article into
4383           ;; `nntp-server-buffer' - so we'll save some time by not having to
4384           ;; copy it from the server buffer into the article buffer.
4385
4386           ;; We only request an article by message-id when we do not have the
4387           ;; headers for it, so we'll have to get those.
4388           (when (stringp article)
4389             (gnus-read-header article))
4390
4391           ;; If the article number is negative, that means that this article
4392           ;; doesn't belong in this newsgroup (possibly), so we find its
4393           ;; message-id and request it by id instead of number.
4394           (when (and (numberp article)
4395                      gnus-summary-buffer
4396                      (get-buffer gnus-summary-buffer)
4397                      (gnus-buffer-exists-p gnus-summary-buffer))
4398             (save-excursion
4399               (set-buffer gnus-summary-buffer)
4400               (let ((header (gnus-summary-article-header article)))
4401                 (when (< article 0)
4402                   (cond
4403                    ((memq article gnus-newsgroup-sparse)
4404                     ;; This is a sparse gap article.
4405                     (setq do-update-line article)
4406                     (setq article (mail-header-id header))
4407                     (setq sparse-header (gnus-read-header article))
4408                     (setq gnus-newsgroup-sparse
4409                           (delq article gnus-newsgroup-sparse)))
4410                    ((vectorp header)
4411                     ;; It's a real article.
4412                     (setq article (mail-header-id header)))
4413                    (t
4414                     ;; It is an extracted pseudo-article.
4415                     (setq article 'pseudo)
4416                     (gnus-request-pseudo-article header))))
4417
4418                 (let ((method (gnus-find-method-for-group
4419                                gnus-newsgroup-name)))
4420                   (when (and (eq (car method) 'nneething)
4421                              (vectorp header))
4422                     (let ((dir (expand-file-name
4423                                 (mail-header-subject header)
4424                                 (file-name-as-directory
4425                                  (or (cadr (assq 'nneething-address method))
4426                                      (nth 1 method))))))
4427                       (when (file-directory-p dir)
4428                         (setq article 'nneething)
4429                         (gnus-group-enter-directory dir))))))))
4430
4431           (cond
4432            ;; Refuse to select canceled articles.
4433            ((and (numberp article)
4434                  gnus-summary-buffer
4435                  (get-buffer gnus-summary-buffer)
4436                  (gnus-buffer-exists-p gnus-summary-buffer)
4437                  (eq (cdr (save-excursion
4438                             (set-buffer gnus-summary-buffer)
4439                             (assq article gnus-newsgroup-reads)))
4440                      gnus-canceled-mark))
4441             nil)
4442            ;; We first check `gnus-original-article-buffer'.
4443            ((and (get-buffer gnus-original-article-buffer)
4444                  (numberp article)
4445                  (save-excursion
4446                    (set-buffer gnus-original-article-buffer)
4447                    (and (equal (car gnus-original-article) group)
4448                         (eq (cdr gnus-original-article) article))))
4449             (insert-buffer-substring gnus-original-article-buffer)
4450             'article)
4451            ;; Check the backlog.
4452            ((and gnus-keep-backlog
4453                  (gnus-backlog-request-article group article (current-buffer)))
4454             'article)
4455            ;; Check asynchronous pre-fetch.
4456            ((gnus-async-request-fetched-article group article (current-buffer))
4457             (gnus-async-prefetch-next group article gnus-summary-buffer)
4458             (when (and (numberp article) gnus-keep-backlog)
4459               (gnus-backlog-enter-article group article (current-buffer)))
4460             'article)
4461            ;; Check the cache.
4462            ((and gnus-use-cache
4463                  (numberp article)
4464                  (gnus-cache-request-article article group))
4465             'article)
4466            ;; Get the article and put into the article buffer.
4467            ((or (stringp article)
4468                 (numberp article))
4469             (let ((gnus-override-method gnus-override-method)
4470                   (methods (and (stringp article)
4471                                 gnus-refer-article-method))
4472                   result
4473                   (buffer-read-only nil))
4474               (if (or (not (listp methods))
4475                       (and (symbolp (car methods))
4476                            (assq (car methods) nnoo-definition-alist)))
4477                   (setq methods (list methods)))
4478               (when (and (null gnus-override-method)
4479                          methods)
4480                 (setq gnus-override-method (pop methods)))
4481               (while (not result)
4482                 (when (eq gnus-override-method 'current)
4483                   (setq gnus-override-method gnus-current-select-method))
4484                 (erase-buffer)
4485                 (gnus-kill-all-overlays)
4486                 (let ((gnus-newsgroup-name group))
4487                   (gnus-check-group-server))
4488                 (when (gnus-request-article article group (current-buffer))
4489                   (when (numberp article)
4490                     (gnus-async-prefetch-next group article
4491                                               gnus-summary-buffer)
4492                     (when gnus-keep-backlog
4493                       (gnus-backlog-enter-article
4494                        group article (current-buffer))))
4495                   (setq result 'article))
4496                 (if (not result)
4497                     (if methods
4498                         (setq gnus-override-method (pop methods))
4499                       (setq result 'done))))
4500               (and (eq result 'article) 'article)))
4501            ;; It was a pseudo.
4502            (t article)))
4503
4504       ;; Associate this article with the current summary buffer.
4505       (setq gnus-article-current-summary gnus-summary-buffer)
4506
4507       ;; Take the article from the original article buffer
4508       ;; and place it in the buffer it's supposed to be in.
4509       (when (and (get-buffer gnus-article-buffer)
4510                  (equal (buffer-name (current-buffer))
4511                         (buffer-name (get-buffer gnus-article-buffer))))
4512         (save-excursion
4513           (if (get-buffer gnus-original-article-buffer)
4514               (set-buffer gnus-original-article-buffer)
4515             (set-buffer (gnus-get-buffer-create gnus-original-article-buffer))
4516             (buffer-disable-undo)
4517             (setq major-mode 'gnus-original-article-mode)
4518             (setq buffer-read-only t))
4519           (let (buffer-read-only)
4520             (erase-buffer)
4521             (insert-buffer-substring gnus-article-buffer))
4522           (setq gnus-original-article (cons group article)))
4523
4524         ;; Decode charsets.
4525         (run-hooks 'gnus-article-decode-hook)
4526         ;; Mark article as decoded or not.
4527         (setq gnus-article-decoded-p gnus-article-decode-hook))
4528
4529       ;; Update sparse articles.
4530       (when (and do-update-line
4531                  (or (numberp article)
4532                      (stringp article)))
4533         (let ((buf (current-buffer)))
4534           (set-buffer gnus-summary-buffer)
4535           (gnus-summary-update-article do-update-line sparse-header)
4536           (gnus-summary-goto-subject do-update-line nil t)
4537           (set-window-point (get-buffer-window (current-buffer) t)
4538                             (point))
4539           (set-buffer buf))))))
4540
4541 ;;;
4542 ;;; Article editing
4543 ;;;
4544
4545 (defcustom gnus-article-edit-mode-hook nil
4546   "Hook run in article edit mode buffers."
4547   :group 'gnus-article-various
4548   :type 'hook)
4549
4550 (defvar gnus-article-edit-done-function nil)
4551
4552 (defvar gnus-article-edit-mode-map nil)
4553
4554 ;; Should we be using derived.el for this?
4555 (unless gnus-article-edit-mode-map
4556   (setq gnus-article-edit-mode-map (make-sparse-keymap))
4557   (set-keymap-parent gnus-article-edit-mode-map text-mode-map)
4558
4559   (gnus-define-keys gnus-article-edit-mode-map
4560     "\C-c\C-c" gnus-article-edit-done
4561     "\C-c\C-k" gnus-article-edit-exit)
4562
4563   (gnus-define-keys (gnus-article-edit-wash-map
4564                      "\C-c\C-w" gnus-article-edit-mode-map)
4565     "f" gnus-article-edit-full-stops))
4566
4567 (defun gnus-article-edit-mode ()
4568   "Major mode for editing articles.
4569 This is an extended text-mode.
4570
4571 \\{gnus-article-edit-mode-map}"
4572   (interactive)
4573   (setq major-mode 'gnus-article-edit-mode)
4574   (setq mode-name "Article Edit")
4575   (use-local-map gnus-article-edit-mode-map)
4576   (make-local-variable 'gnus-article-edit-done-function)
4577   (make-local-variable 'gnus-prev-winconf)
4578   (setq buffer-read-only nil)
4579   (buffer-enable-undo)
4580   (widen)
4581   (gnus-run-hooks 'text-mode-hook 'gnus-article-edit-mode-hook))
4582
4583 (defun gnus-article-edit (&optional force)
4584   "Edit the current article.
4585 This will have permanent effect only in mail groups.
4586 If FORCE is non-nil, allow editing of articles even in read-only
4587 groups."
4588   (interactive "P")
4589   (when (and (not force)
4590              (gnus-group-read-only-p))
4591     (error "The current newsgroup does not support article editing"))
4592   (gnus-article-date-original)
4593   (gnus-article-edit-article
4594    'ignore
4595    `(lambda (no-highlight)
4596       'ignore
4597       (gnus-summary-edit-article-done
4598        ,(or (mail-header-references gnus-current-headers) "")
4599        ,(gnus-group-read-only-p) ,gnus-summary-buffer no-highlight))))
4600
4601 (defun gnus-article-edit-article (start-func exit-func)
4602   "Start editing the contents of the current article buffer."
4603   (let ((winconf (current-window-configuration)))
4604     (set-buffer gnus-article-buffer)
4605     (gnus-article-edit-mode)
4606     (funcall start-func)
4607     (set-buffer-modified-p nil)
4608     (gnus-configure-windows 'edit-article)
4609     (setq gnus-article-edit-done-function exit-func)
4610     (setq gnus-prev-winconf winconf)
4611     (gnus-message 6 "C-c C-c to end edits")))
4612
4613 (defun gnus-article-edit-done (&optional arg)
4614   "Update the article edits and exit."
4615   (interactive "P")
4616   (let ((func gnus-article-edit-done-function)
4617         (buf (current-buffer))
4618         (start (window-start)))
4619     ;; We remove all text props from the article buffer.
4620     (let ((content
4621            (buffer-substring-no-properties (point-min) (point-max)))
4622           (p (point)))
4623       (erase-buffer)
4624       (insert content)
4625       (let ((winconf gnus-prev-winconf))
4626         (gnus-article-mode)
4627         (set-window-configuration winconf)
4628         ;; Tippy-toe some to make sure that point remains where it was.
4629         (save-current-buffer
4630           (set-buffer buf)
4631           (set-window-start (get-buffer-window (current-buffer)) start)
4632           (goto-char p))))
4633     (save-excursion
4634       (set-buffer buf)
4635       (let ((buffer-read-only nil))
4636         (funcall func arg))
4637       ;; The cache and backlog have to be flushed somewhat.
4638       (when gnus-keep-backlog
4639         (gnus-backlog-remove-article
4640          (car gnus-article-current) (cdr gnus-article-current)))
4641       ;; Flush original article as well.
4642       (save-excursion
4643         (when (get-buffer gnus-original-article-buffer)
4644           (set-buffer gnus-original-article-buffer)
4645           (setq gnus-original-article nil)))
4646       (when gnus-use-cache
4647         (gnus-cache-update-article
4648          (car gnus-article-current) (cdr gnus-article-current))))
4649     (set-buffer buf)
4650     (set-window-start (get-buffer-window buf) start)
4651     (set-window-point (get-buffer-window buf) (point))))
4652
4653 (defun gnus-article-edit-exit ()
4654   "Exit the article editing without updating."
4655   (interactive)
4656   (when (or (not (buffer-modified-p))
4657             (yes-or-no-p "Article modified; kill anyway? "))
4658     (let ((curbuf (current-buffer))
4659           (p (point))
4660           (window-start (window-start)))
4661       (erase-buffer)
4662       (if (gnus-buffer-live-p gnus-original-article-buffer)
4663           (insert-buffer gnus-original-article-buffer))
4664       (let ((winconf gnus-prev-winconf))
4665         (gnus-article-mode)
4666         (set-window-configuration winconf)
4667         ;; Tippy-toe some to make sure that point remains where it was.
4668         (save-current-buffer
4669           (set-buffer curbuf)
4670           (set-window-start (get-buffer-window (current-buffer)) window-start)
4671           (goto-char p))))))
4672
4673 (defun gnus-article-edit-full-stops ()
4674   "Interactively repair spacing at end of sentences."
4675   (interactive)
4676   (save-excursion
4677     (goto-char (point-min))
4678     (search-forward-regexp "^$" nil t)
4679     (let ((case-fold-search nil))
4680       (query-replace-regexp "\\([.!?][])}]* \\)\\([[({A-Z]\\)" "\\1 \\2"))))
4681
4682 ;;;
4683 ;;; Article highlights
4684 ;;;
4685
4686 ;; Written by Per Abrahamsen <abraham@iesd.auc.dk>.
4687
4688 ;;; Internal Variables:
4689
4690 (defcustom gnus-button-url-regexp "\\b\\(\\(www\\.\\|\\(s?https?\\|ftp\\|file\\|gopher\\|news\\|telnet\\|wais\\|mailto\\):\\)\\(//[-a-zA-Z0-9_.]+:[0-9]*\\)?\\([-a-zA-Z0-9_=!?#$@~`%&*+|\\/:;.,]\\|\\w\\)+\\([-a-zA-Z0-9_=#$@~`%&*+|\\/]\\|\\w\\)\\)"
4691   "Regular expression that matches URLs."
4692   :group 'gnus-article-buttons
4693   :type 'regexp)
4694
4695 (defcustom gnus-button-alist
4696   `(("<\\(url:[>\n\t ]*?\\)?\\(nntp\\|news\\):[>\n\t ]*\\([^>\n\t ]*@[^>\n\t ]*\\)>"
4697      0 t gnus-button-handle-news 3)
4698     ("\\b\\(nntp\\|news\\):\\([^>\n\t ]*@[^>)!;:,\n\t ]*\\)" 0 t
4699      gnus-button-handle-news 2)
4700     ("\\(\\b<\\(url:[>\n\t ]*\\)?news:[>\n\t ]*\\(//\\)?\\([^>\n\t ]*\\)>\\)"
4701      1 t
4702      gnus-button-fetch-group 4)
4703     ("\\bnews:\\(//\\)?\\([^'\">\n\t ]+\\)" 0 t gnus-button-fetch-group 2)
4704     ("\\bin\\( +article\\| +message\\)? +\\(<\\([^\n @<>]+@[^\n @<>]+\\)>\\)" 2
4705      t gnus-button-message-id 3)
4706     ("\\(<URL: *\\)mailto: *\\([^> \n\t]+\\)>" 0 t gnus-url-mailto 2)
4707     ("mailto:\\([-a-zA-Z.@_+0-9%=?]+\\)" 0 t gnus-url-mailto 1)
4708     ("\\bmailto:\\([^ \n\t]+\\)" 0 t gnus-url-mailto 1)
4709     ;; This is how URLs _should_ be embedded in text...
4710     ("<URL: *\\([^<>]*\\)>" 0 t gnus-button-embedded-url 1)
4711     ;; Raw URLs.
4712     (,gnus-button-url-regexp 0 t browse-url 0))
4713   "*Alist of regexps matching buttons in article bodies.
4714
4715 Each entry has the form (REGEXP BUTTON FORM CALLBACK PAR...), where
4716 REGEXP: is the string matching text around the button,
4717 BUTTON: is the number of the regexp grouping actually matching the button,
4718 FORM: is a lisp expression which must eval to true for the button to
4719 be added,
4720 CALLBACK: is the function to call when the user push this button, and each
4721 PAR: is a number of a regexp grouping whose text will be passed to CALLBACK.
4722
4723 CALLBACK can also be a variable, in that case the value of that
4724 variable it the real callback function."
4725   :group 'gnus-article-buttons
4726   :type '(repeat (list regexp
4727                        (integer :tag "Button")
4728                        (sexp :tag "Form")
4729                        (function :tag "Callback")
4730                        (repeat :tag "Par"
4731                                :inline t
4732                                (integer :tag "Regexp group")))))
4733
4734 (defcustom gnus-header-button-alist
4735   `(("^\\(References\\|Message-I[Dd]\\):" "<[^>]+>"
4736      0 t gnus-button-message-id 0)
4737     ("^\\(From\\|Reply-To\\):" ": *\\(.+\\)$" 1 t gnus-button-reply 1)
4738     ("^\\(Cc\\|To\\):" "[^ \t\n<>,()\"]+@[^ \t\n<>,()\"]+"
4739      0 t gnus-button-mailto 0)
4740     ("^X-[Uu][Rr][Ll]:" ,gnus-button-url-regexp 0 t browse-url 0)
4741     ("^Subject:" ,gnus-button-url-regexp 0 t browse-url 0)
4742     ("^[^:]+:" ,gnus-button-url-regexp 0 t browse-url 0)
4743     ("^[^:]+:" "\\(<\\(url: \\)?news:\\([^>\n ]*\\)>\\)" 1 t
4744      gnus-button-message-id 3))
4745   "*Alist of headers and regexps to match buttons in article heads.
4746
4747 This alist is very similar to `gnus-button-alist', except that each
4748 alist has an additional HEADER element first in each entry:
4749
4750 \(HEADER REGEXP BUTTON FORM CALLBACK PAR)
4751
4752 HEADER is a regexp to match a header.  For a fuller explanation, see
4753 `gnus-button-alist'."
4754   :group 'gnus-article-buttons
4755   :group 'gnus-article-headers
4756   :type '(repeat (list (regexp :tag "Header")
4757                        regexp
4758                        (integer :tag "Button")
4759                        (sexp :tag "Form")
4760                        (function :tag "Callback")
4761                        (repeat :tag "Par"
4762                                :inline t
4763                                (integer :tag "Regexp group")))))
4764
4765 (defvar gnus-button-regexp nil)
4766 (defvar gnus-button-marker-list nil)
4767 ;; Regexp matching any of the regexps from `gnus-button-alist'.
4768
4769 (defvar gnus-button-last nil)
4770 ;; The value of `gnus-button-alist' when `gnus-button-regexp' was build.
4771
4772 ;;; Commands:
4773
4774 (defun gnus-article-push-button (event)
4775   "Check text under the mouse pointer for a callback function.
4776 If the text under the mouse pointer has a `gnus-callback' property,
4777 call it with the value of the `gnus-data' text property."
4778   (interactive "e")
4779   (set-buffer (window-buffer (posn-window (event-start event))))
4780   (let* ((pos (posn-point (event-start event)))
4781          (data (get-text-property pos 'gnus-data))
4782          (fun (get-text-property pos 'gnus-callback)))
4783     (goto-char pos)
4784     (when fun
4785       (funcall fun data))))
4786
4787 (defun gnus-article-press-button ()
4788   "Check text at point for a callback function.
4789 If the text at point has a `gnus-callback' property,
4790 call it with the value of the `gnus-data' text property."
4791   (interactive)
4792   (let* ((data (get-text-property (point) 'gnus-data))
4793          (fun (get-text-property (point) 'gnus-callback)))
4794     (when fun
4795       (funcall fun data))))
4796
4797 (defun gnus-article-highlight (&optional force)
4798   "Highlight current article.
4799 This function calls `gnus-article-highlight-headers',
4800 `gnus-article-highlight-citation',
4801 `gnus-article-highlight-signature', and `gnus-article-add-buttons' to
4802 do the highlighting.  See the documentation for those functions."
4803   (interactive (list 'force))
4804   (gnus-article-highlight-headers)
4805   (gnus-article-highlight-citation force)
4806   (gnus-article-highlight-signature)
4807   (gnus-article-add-buttons force)
4808   (gnus-article-add-buttons-to-head))
4809
4810 (defun gnus-article-highlight-some (&optional force)
4811   "Highlight current article.
4812 This function calls `gnus-article-highlight-headers',
4813 `gnus-article-highlight-signature', and `gnus-article-add-buttons' to
4814 do the highlighting.  See the documentation for those functions."
4815   (interactive (list 'force))
4816   (gnus-article-highlight-headers)
4817   (gnus-article-highlight-signature)
4818   (gnus-article-add-buttons))
4819
4820 (defun gnus-article-highlight-headers ()
4821   "Highlight article headers as specified by `gnus-header-face-alist'."
4822   (interactive)
4823   (save-excursion
4824     (set-buffer gnus-article-buffer)
4825     (save-restriction
4826       (let ((alist gnus-header-face-alist)
4827             (buffer-read-only nil)
4828             (case-fold-search t)
4829             (inhibit-point-motion-hooks t)
4830             entry regexp header-face field-face from hpoints fpoints)
4831         (article-narrow-to-head)
4832         (while (setq entry (pop alist))
4833           (goto-char (point-min))
4834           (setq regexp (concat "^\\("
4835                                (if (string-equal "" (nth 0 entry))
4836                                    "[^\t ]"
4837                                  (nth 0 entry))
4838                                "\\)")
4839                 header-face (nth 1 entry)
4840                 field-face (nth 2 entry))
4841           (while (and (re-search-forward regexp nil t)
4842                       (not (eobp)))
4843             (beginning-of-line)
4844             (setq from (point))
4845             (unless (search-forward ":" nil t)
4846               (forward-char 1))
4847             (when (and header-face
4848                        (not (memq (point) hpoints)))
4849               (push (point) hpoints)
4850               (gnus-put-text-property from (point) 'face header-face))
4851             (when (and field-face
4852                        (not (memq (setq from (point)) fpoints)))
4853               (push from fpoints)
4854               (if (re-search-forward "^[^ \t]" nil t)
4855                   (forward-char -2)
4856                 (goto-char (point-max)))
4857               (gnus-put-text-property from (point) 'face field-face))))))))
4858
4859 (defun gnus-article-highlight-signature ()
4860   "Highlight the signature in an article.
4861 It does this by highlighting everything after
4862 `gnus-signature-separator' using `gnus-signature-face'."
4863   (interactive)
4864   (save-excursion
4865     (set-buffer gnus-article-buffer)
4866     (let ((buffer-read-only nil)
4867           (inhibit-point-motion-hooks t))
4868       (save-restriction
4869         (when (and gnus-signature-face
4870                    (gnus-article-narrow-to-signature))
4871           (gnus-overlay-put (gnus-make-overlay (point-min) (point-max))
4872                             'face gnus-signature-face)
4873           (widen)
4874           (gnus-article-search-signature)
4875           (let ((start (match-beginning 0))
4876                 (end (set-marker (make-marker) (1+ (match-end 0)))))
4877             (gnus-article-add-button start (1- end) 'gnus-signature-toggle
4878                                      end)))))))
4879
4880 (defun gnus-button-in-region-p (b e prop)
4881   "Say whether PROP exists in the region."
4882   (text-property-not-all b e prop nil))
4883
4884 (defun gnus-article-add-buttons (&optional force)
4885   "Find external references in the article and make buttons of them.
4886 \"External references\" are things like Message-IDs and URLs, as
4887 specified by `gnus-button-alist'."
4888   (interactive (list 'force))
4889   (save-excursion
4890     (set-buffer gnus-article-buffer)
4891     (let ((buffer-read-only nil)
4892           (inhibit-point-motion-hooks t)
4893           (case-fold-search t)
4894           (alist gnus-button-alist)
4895           beg entry regexp)
4896       ;; Remove all old markers.
4897       (let (marker entry new-list)
4898         (while (setq marker (pop gnus-button-marker-list))
4899           (if (or (< marker (point-min)) (>= marker (point-max)))
4900               (push marker new-list)
4901             (goto-char marker)
4902             (when (setq entry (gnus-button-entry))
4903               (put-text-property (match-beginning (nth 1 entry))
4904                                  (match-end (nth 1 entry))
4905                                  'gnus-callback nil))
4906             (set-marker marker nil)))
4907         (setq gnus-button-marker-list new-list))
4908       ;; We skip the headers.
4909       (article-goto-body)
4910       (setq beg (point))
4911       (while (setq entry (pop alist))
4912         (setq regexp (car entry))
4913         (goto-char beg)
4914         (while (re-search-forward regexp nil t)
4915           (let* ((start (and entry (match-beginning (nth 1 entry))))
4916                  (end (and entry (match-end (nth 1 entry))))
4917                  (from (match-beginning 0)))
4918             (when (and (or (eq t (nth 2 entry))
4919                            (eval (nth 2 entry)))
4920                        (not (gnus-button-in-region-p
4921                              start end 'gnus-callback)))
4922               ;; That optional form returned non-nil, so we add the
4923               ;; button.
4924               (gnus-article-add-button
4925                start end 'gnus-button-push
4926                (car (push (set-marker (make-marker) from)
4927                           gnus-button-marker-list))))))))))
4928
4929 ;; Add buttons to the head of an article.
4930 (defun gnus-article-add-buttons-to-head ()
4931   "Add buttons to the head of the article."
4932   (interactive)
4933   (save-excursion
4934     (set-buffer gnus-article-buffer)
4935     (save-restriction
4936       (let ((buffer-read-only nil)
4937             (inhibit-point-motion-hooks t)
4938             (case-fold-search t)
4939             (alist gnus-header-button-alist)
4940             entry beg end)
4941         (article-narrow-to-head)
4942         (while alist
4943           ;; Each alist entry.
4944           (setq entry (car alist)
4945                 alist (cdr alist))
4946           (goto-char (point-min))
4947           (while (re-search-forward (car entry) nil t)
4948             ;; Each header matching the entry.
4949             (setq beg (match-beginning 0))
4950             (setq end (or (and (re-search-forward "^[^ \t]" nil t)
4951                                (match-beginning 0))
4952                           (point-max)))
4953             (goto-char beg)
4954             (while (re-search-forward (nth 1 entry) end t)
4955               ;; Each match within a header.
4956               (let* ((entry (cdr entry))
4957                      (start (match-beginning (nth 1 entry)))
4958                      (end (match-end (nth 1 entry)))
4959                      (form (nth 2 entry)))
4960                 (goto-char (match-end 0))
4961                 (when (eval form)
4962                   (gnus-article-add-button
4963                    start end (nth 3 entry)
4964                    (buffer-substring (match-beginning (nth 4 entry))
4965                                      (match-end (nth 4 entry)))))))
4966             (goto-char end)))))))
4967
4968 ;;; External functions:
4969
4970 (defun gnus-article-add-button (from to fun &optional data)
4971   "Create a button between FROM and TO with callback FUN and data DATA."
4972   (when gnus-article-button-face
4973     (gnus-overlay-put (gnus-make-overlay from to)
4974                       'face gnus-article-button-face))
4975   (gnus-add-text-properties
4976    from to
4977    (nconc (and gnus-article-mouse-face
4978                (list gnus-mouse-face-prop gnus-article-mouse-face))
4979           (list 'gnus-callback fun)
4980           (and data (list 'gnus-data data))))
4981   (widget-convert-button 'link from to :action 'gnus-widget-press-button
4982                          :button-keymap gnus-widget-button-keymap))
4983
4984 ;;; Internal functions:
4985
4986 (defun gnus-article-set-globals ()
4987   (save-excursion
4988     (set-buffer gnus-summary-buffer)
4989     (gnus-set-global-variables)))
4990
4991 (defun gnus-signature-toggle (end)
4992   (save-excursion
4993     (set-buffer gnus-article-buffer)
4994     (let ((buffer-read-only nil)
4995           (inhibit-point-motion-hooks t))
4996       (if (text-property-any end (point-max) 'article-type 'signature)
4997           (gnus-remove-text-properties-when
4998            'article-type 'signature end (point-max)
4999            (cons 'article-type (cons 'signature
5000                                      gnus-hidden-properties)))
5001         (gnus-add-text-properties-when
5002          'article-type nil end (point-max)
5003          (cons 'article-type (cons 'signature
5004                                    gnus-hidden-properties)))))))
5005
5006 (defun gnus-button-entry ()
5007   ;; Return the first entry in `gnus-button-alist' matching this place.
5008   (let ((alist gnus-button-alist)
5009         (entry nil))
5010     (while alist
5011       (setq entry (pop alist))
5012       (if (looking-at (car entry))
5013           (setq alist nil)
5014         (setq entry nil)))
5015     entry))
5016
5017 (defun gnus-button-push (marker)
5018   ;; Push button starting at MARKER.
5019   (save-excursion
5020     (goto-char marker)
5021     (let* ((entry (gnus-button-entry))
5022            (inhibit-point-motion-hooks t)
5023            (fun (nth 3 entry))
5024            (args (mapcar (lambda (group)
5025                            (let ((string (match-string group)))
5026                              (gnus-set-text-properties
5027                               0 (length string) nil string)
5028                              string))
5029                          (nthcdr 4 entry))))
5030       (cond
5031        ((fboundp fun)
5032         (apply fun args))
5033        ((and (boundp fun)
5034              (fboundp (symbol-value fun)))
5035         (apply (symbol-value fun) args))
5036        (t
5037         (gnus-message 1 "You must define `%S' to use this button"
5038                       (cons fun args)))))))
5039
5040 (defun gnus-parse-news-url (url)
5041   (let (scheme server group message-id articles)
5042     (with-temp-buffer
5043       (insert url)
5044       (goto-char (point-min))
5045       (when (looking-at "\\([A-Za-z]+\\):")
5046         (setq scheme (match-string 1))
5047         (goto-char (match-end 0)))
5048       (when (looking-at "//\\([^/]+\\)/")
5049         (setq server (match-string 1))
5050         (goto-char (match-end 0)))
5051         
5052       (cond
5053        ((looking-at "\\(.*@.*\\)")
5054         (setq message-id (match-string 1)))
5055        ((looking-at "\\([^/]+\\)/\\([-0-9]+\\)")
5056         (setq group (match-string 1)
5057               articles (split-string (match-string 2) "-")))
5058        ((looking-at "\\([^/]+\\)/?")
5059         (setq group (match-string 1)))
5060        (t
5061         (error "Unknown news URL syntax"))))
5062     (list scheme server group message-id articles)))
5063
5064 (defun gnus-button-handle-news (url)
5065   "Fetch a news URL."
5066   (destructuring-bind (scheme server group message-id articles)
5067       (gnus-parse-news-url url)
5068     (cond
5069      (message-id
5070       (save-excursion
5071         (set-buffer gnus-summary-buffer)
5072         (if server
5073             (let ((gnus-refer-article-method (list (list 'nntp server))))
5074               (gnus-summary-refer-article message-id))
5075           (gnus-summary-refer-article message-id))))
5076      (group
5077       (gnus-button-fetch-group url)))))
5078
5079 (defun gnus-button-message-id (message-id)
5080   "Fetch MESSAGE-ID."
5081   (save-excursion
5082     (set-buffer gnus-summary-buffer)
5083     (gnus-summary-refer-article message-id)))
5084
5085 (defun gnus-button-fetch-group (address)
5086   "Fetch GROUP specified by ADDRESS."
5087   (if (not (string-match "[:/]" address))
5088       ;; This is just a simple group url.
5089       (gnus-group-read-ephemeral-group address gnus-select-method)
5090     (if (not (string-match "^\\([^:/]+\\)\\(:\\([^/]+\\)/\\)?\\(.*\\)$"
5091                            address))
5092         (error "Can't parse %s" address)
5093       (gnus-group-read-ephemeral-group
5094        (match-string 4 address)
5095        `(nntp ,(match-string 1 address)
5096               (nntp-address ,(match-string 1 address))
5097               (nntp-port-number ,(if (match-end 3)
5098                                      (match-string 3 address)
5099                                    "nntp")))))))
5100
5101 (defun gnus-url-parse-query-string (query &optional downcase)
5102   (let (retval pairs cur key val)
5103     (setq pairs (split-string query "&"))
5104     (while pairs
5105       (setq cur (car pairs)
5106             pairs (cdr pairs))
5107       (if (not (string-match "=" cur))
5108           nil                           ; Grace
5109         (setq key (gnus-url-unhex-string (substring cur 0 (match-beginning 0)))
5110               val (gnus-url-unhex-string (substring cur (match-end 0) nil)))
5111         (if downcase
5112             (setq key (downcase key)))
5113         (setq cur (assoc key retval))
5114         (if cur
5115             (setcdr cur (cons val (cdr cur)))
5116           (setq retval (cons (list key val) retval)))))
5117     retval))
5118
5119 (defun gnus-url-unhex (x)
5120   (if (> x ?9)
5121       (if (>= x ?a)
5122           (+ 10 (- x ?a))
5123         (+ 10 (- x ?A)))
5124     (- x ?0)))
5125
5126 (defun gnus-url-unhex-string (str &optional allow-newlines)
5127   "Remove %XXX embedded spaces, etc in a url.
5128 If optional second argument ALLOW-NEWLINES is non-nil, then allow the
5129 decoding of carriage returns and line feeds in the string, which is normally
5130 forbidden in URL encoding."
5131   (setq str (or str ""))
5132   (let ((tmp "")
5133         (case-fold-search t))
5134     (while (string-match "%[0-9a-f][0-9a-f]" str)
5135       (let* ((start (match-beginning 0))
5136              (ch1 (gnus-url-unhex (elt str (+ start 1))))
5137              (code (+ (* 16 ch1)
5138                       (gnus-url-unhex (elt str (+ start 2))))))
5139         (setq tmp (concat
5140                    tmp (substring str 0 start)
5141                    (cond
5142                     (allow-newlines
5143                      (char-to-string code))
5144                     ((or (= code ?\n) (= code ?\r))
5145                      " ")
5146                     (t (char-to-string code))))
5147               str (substring str (match-end 0)))))
5148     (setq tmp (concat tmp str))
5149     tmp))
5150
5151 (defun gnus-url-mailto (url)
5152   ;; Send mail to someone
5153   (when (string-match "mailto:/*\\(.*\\)" url)
5154     (setq url (substring url (match-beginning 1) nil)))
5155   (let (to args subject func)
5156     (if (string-match (regexp-quote "?") url)
5157         (setq to (gnus-url-unhex-string (substring url 0 (match-beginning 0)))
5158               args (gnus-url-parse-query-string
5159                     (substring url (match-end 0) nil) t))
5160       (setq to (gnus-url-unhex-string url)))
5161     (setq args (cons (list "to" to) args)
5162           subject (cdr-safe (assoc "subject" args)))
5163     (gnus-msg-mail)
5164     (while args
5165       (setq func (intern-soft (concat "message-goto-" (downcase (caar args)))))
5166       (if (fboundp func)
5167           (funcall func)
5168         (message-position-on-field (caar args)))
5169       (insert (mapconcat 'identity (cdar args) ", "))
5170       (setq args (cdr args)))
5171     (if subject
5172         (message-goto-body)
5173       (message-goto-subject))))
5174
5175 (defun gnus-button-embedded-url (address)
5176   "Activate ADDRESS with `browse-url'."
5177   (browse-url (gnus-strip-whitespace address)))
5178
5179 ;;; Next/prev buttons in the article buffer.
5180
5181 (defvar gnus-next-page-line-format "%{%(Next page...%)%}\n")
5182 (defvar gnus-prev-page-line-format "%{%(Previous page...%)%}\n")
5183
5184 (defvar gnus-prev-page-map nil)
5185 (unless gnus-prev-page-map
5186   (setq gnus-prev-page-map (make-sparse-keymap))
5187   (define-key gnus-prev-page-map gnus-mouse-2 'gnus-button-prev-page)
5188   (define-key gnus-prev-page-map "\r" 'gnus-button-prev-page))
5189
5190 (defun gnus-insert-prev-page-button ()
5191   (let ((buffer-read-only nil))
5192     (gnus-eval-format
5193      gnus-prev-page-line-format nil
5194      `(gnus-prev t local-map ,gnus-prev-page-map
5195                  gnus-callback gnus-article-button-prev-page
5196                  article-type annotation))))
5197
5198 (defvar gnus-next-page-map nil)
5199 (unless gnus-next-page-map
5200   (setq gnus-next-page-map (make-keymap))
5201   (suppress-keymap gnus-prev-page-map)
5202   (define-key gnus-next-page-map gnus-mouse-2 'gnus-button-next-page)
5203   (define-key gnus-next-page-map "\r" 'gnus-button-next-page))
5204
5205 (defun gnus-button-next-page ()
5206   "Go to the next page."
5207   (interactive)
5208   (let ((win (selected-window)))
5209     (select-window (get-buffer-window gnus-article-buffer t))
5210     (gnus-article-next-page)
5211     (select-window win)))
5212
5213 (defun gnus-button-prev-page ()
5214   "Go to the prev page."
5215   (interactive)
5216   (let ((win (selected-window)))
5217     (select-window (get-buffer-window gnus-article-buffer t))
5218     (gnus-article-prev-page)
5219     (select-window win)))
5220
5221 (defun gnus-insert-next-page-button ()
5222   (let ((buffer-read-only nil))
5223     (gnus-eval-format gnus-next-page-line-format nil
5224                       `(gnus-next
5225                         t local-map ,gnus-next-page-map
5226                         gnus-callback gnus-article-button-next-page
5227                         article-type annotation))))
5228
5229 (defun gnus-article-button-next-page (arg)
5230   "Go to the next page."
5231   (interactive "P")
5232   (let ((win (selected-window)))
5233     (select-window (get-buffer-window gnus-article-buffer t))
5234     (gnus-article-next-page)
5235     (select-window win)))
5236
5237 (defun gnus-article-button-prev-page (arg)
5238   "Go to the prev page."
5239   (interactive "P")
5240   (let ((win (selected-window)))
5241     (select-window (get-buffer-window gnus-article-buffer t))
5242     (gnus-article-prev-page)
5243     (select-window win)))
5244
5245 (defvar gnus-decode-header-methods
5246   '(mail-decode-encoded-word-region)
5247   "List of methods used to decode headers.
5248
5249 This variable is a list of FUNCTION or (REGEXP . FUNCTION).  If item
5250 is FUNCTION, FUNCTION will be apply to all newsgroups.  If item is a
5251 (REGEXP . FUNCTION), FUNCTION will be only apply to thes newsgroups
5252 whose names match REGEXP.
5253
5254 For example:
5255 ((\"chinese\" . gnus-decode-encoded-word-region-by-guess)
5256  mail-decode-encoded-word-region
5257  (\"chinese\" . rfc1843-decode-region))
5258 ")
5259
5260 (defvar gnus-decode-header-methods-cache nil)
5261
5262 (defun gnus-multi-decode-header (start end)
5263   "Apply the functions from `gnus-encoded-word-methods' that match."
5264   (unless (and gnus-decode-header-methods-cache
5265                (eq gnus-newsgroup-name
5266                    (car gnus-decode-header-methods-cache)))
5267     (setq gnus-decode-header-methods-cache (list gnus-newsgroup-name))
5268     (mapcar (lambda (x)
5269               (if (symbolp x)
5270                   (nconc gnus-decode-header-methods-cache (list x))
5271                 (if (and gnus-newsgroup-name
5272                          (string-match (car x) gnus-newsgroup-name))
5273                     (nconc gnus-decode-header-methods-cache
5274                            (list (cdr x))))))
5275           gnus-decode-header-methods))
5276   (let ((xlist gnus-decode-header-methods-cache))
5277     (pop xlist)
5278     (save-restriction
5279       (narrow-to-region start end)
5280       (while xlist
5281         (funcall (pop xlist) (point-min) (point-max))))))
5282
5283 ;;;
5284 ;;; Treatment top-level handling.
5285 ;;;
5286
5287 (defun gnus-treat-article (condition &optional part-number total-parts type)
5288   (let ((length (- (point-max) (point-min)))
5289         (alist gnus-treatment-function-alist)
5290         (article-goto-body-goes-to-point-min-p t)
5291         (treated-type
5292          (or (not type)
5293              (catch 'found
5294                (let ((list gnus-article-treat-types))
5295                  (while list
5296                    (when (string-match (pop list) type)
5297                      (throw 'found t)))))))
5298         (highlightp (gnus-visual-p 'article-highlight 'highlight))
5299         val elem)
5300     (gnus-run-hooks 'gnus-part-display-hook)
5301     (while (setq elem (pop alist))
5302       (setq val
5303             (save-excursion
5304               (if (gnus-buffer-live-p gnus-summary-buffer)
5305                   (set-buffer gnus-summary-buffer))
5306               (symbol-value (car elem))))
5307       (when (and (or (consp val)
5308                      treated-type)
5309                  (gnus-treat-predicate val)
5310                  (or (not (get (car elem) 'highlight))
5311                      highlightp))
5312         (save-restriction
5313           (funcall (cadr elem)))))))
5314
5315 ;; Dynamic variables.
5316 (eval-when-compile
5317   (defvar part-number)
5318   (defvar total-parts)
5319   (defvar type)
5320   (defvar condition)
5321   (defvar length))
5322
5323 (defun gnus-treat-predicate (val)
5324   (cond
5325    ((null val)
5326     nil)
5327    ((and (listp val)
5328          (stringp (car val)))
5329     (apply 'gnus-or (mapcar `(lambda (s)
5330                                (string-match s ,(or gnus-newsgroup-name "")))
5331                             val)))
5332    ((listp val)
5333     (let ((pred (pop val)))
5334       (cond
5335        ((eq pred 'or)
5336         (apply 'gnus-or (mapcar 'gnus-treat-predicate val)))
5337        ((eq pred 'and)
5338         (apply 'gnus-and (mapcar 'gnus-treat-predicate val)))
5339        ((eq pred 'not)
5340         (not (gnus-treat-predicate (car val))))
5341        ((eq pred 'typep)
5342         (equal (car val) type))
5343        (t
5344         (error "%S is not a valid predicate" pred)))))
5345    (condition
5346     (eq condition val))
5347    ((eq val t)
5348     t)
5349    ((eq val 'head)
5350     nil)
5351    ((eq val 'last)
5352     (eq part-number total-parts))
5353    ((numberp val)
5354     (< length val))
5355    (t
5356     (error "%S is not a valid value" val))))
5357
5358 (defun gnus-article-encrypt-body (protocol &optional n)
5359   "Encrypt the article body."
5360   (interactive
5361    (list
5362     (or gnus-article-encrypt-protocol
5363         (completing-read "Encrypt protocol: "
5364                          gnus-article-encrypt-protocol-alist
5365                          nil t))
5366     current-prefix-arg))
5367   (let ((func (cdr (assoc protocol gnus-article-encrypt-protocol-alist))))
5368     (unless func
5369       (error (format "Can't find the encrypt protocol %s" protocol)))
5370     (if (equal gnus-newsgroup-name "nndraft:drafts")
5371         (error "Can't encrypt the article in group nndraft:drafts."))
5372     (if (equal gnus-newsgroup-name "nndraft:queue")
5373         (error "Don't encrypt the article in group nndraft:queue."))
5374     (gnus-summary-iterate n
5375       (save-excursion
5376         (set-buffer gnus-summary-buffer)
5377         (let ((mail-parse-charset gnus-newsgroup-charset)
5378               (mail-parse-ignored-charsets gnus-newsgroup-ignored-charsets)
5379               (summary-buffer gnus-summary-buffer)
5380               references point)
5381           (gnus-set-global-variables)
5382           (when (gnus-group-read-only-p)
5383             (error "The current newsgroup does not support article encrypt"))
5384           (gnus-summary-show-article t)
5385           (setq references
5386               (or (mail-header-references gnus-current-headers) ""))
5387           (set-buffer gnus-article-buffer)
5388           (let* ((buffer-read-only nil)
5389                  (headers
5390                   (mapcar (lambda (field)
5391                             (and (save-restriction
5392                                    (message-narrow-to-head)
5393                                    (goto-char (point-min))
5394                                    (search-forward field nil t))
5395                                  (prog2
5396                                      (message-narrow-to-field)
5397                                      (buffer-substring (point-min) (point-max))
5398                                    (delete-region (point-min) (point-max))
5399                                    (widen))))
5400                           '("Content-Type:" "Content-Transfer-Encoding:"
5401                             "Content-Disposition:"))))
5402             (message-narrow-to-head)
5403             (message-remove-header "MIME-Version")
5404             (goto-char (point-max))
5405             (setq point (point))
5406             (insert (apply 'concat headers))
5407             (widen)
5408             (narrow-to-region point (point-max))
5409             (let ((message-options message-options))
5410               (message-options-set 'message-sender user-mail-address)
5411               (message-options-set 'message-recipients user-mail-address)
5412               (message-options-set 'message-sign-encrypt 'not)
5413               (funcall func))
5414             (goto-char (point-min))
5415             (insert "MIME-Version: 1.0\n")
5416             (widen)
5417             (gnus-summary-edit-article-done
5418              references nil summary-buffer t))
5419           (when gnus-keep-backlog
5420             (gnus-backlog-remove-article
5421              (car gnus-article-current) (cdr gnus-article-current)))
5422           (save-excursion
5423             (when (get-buffer gnus-original-article-buffer)
5424               (set-buffer gnus-original-article-buffer)
5425               (setq gnus-original-article nil)))
5426           (when gnus-use-cache
5427             (gnus-cache-update-article
5428              (car gnus-article-current) (cdr gnus-article-current))))))))
5429
5430 (defvar gnus-mime-security-button-line-format "%{%([[%t:%i]%D]%)%}\n"
5431   "The following specs can be used:
5432 %t  The security MIME type
5433 %i  Additional info
5434 %d  Details
5435 %D  Details if button is pressed")
5436
5437 (defvar gnus-mime-security-button-end-line-format "%{%([[End of %t]%D]%)%}\n"
5438   "The following specs can be used:
5439 %t  The security MIME type
5440 %i  Additional info
5441 %d  Details
5442 %D  Details if button is pressed")
5443
5444 (defvar gnus-mime-security-button-line-format-alist
5445   '((?t gnus-tmp-type ?s)
5446     (?i gnus-tmp-info ?s)
5447     (?d gnus-tmp-details ?s)
5448     (?D gnus-tmp-pressed-details ?s)))
5449
5450 (defvar gnus-mime-security-button-map
5451   (let ((map (make-sparse-keymap)))
5452     (unless (>= (string-to-number emacs-version) 21)
5453       (set-keymap-parent map gnus-article-mode-map))
5454     (define-key map gnus-mouse-2 'gnus-article-push-button)
5455     (define-key map "\r" 'gnus-article-press-button)
5456     map))
5457
5458 (defvar gnus-mime-security-details-buffer nil)
5459
5460 (defvar gnus-mime-security-button-pressed nil)
5461
5462 (defvar gnus-mime-security-show-details-inline t
5463   "If non-nil, show details in the article buffer.")
5464
5465 (defun gnus-mime-security-verify-or-decrypt (handle)
5466   (mm-remove-parts (cdr handle))
5467   (let ((region (mm-handle-multipart-ctl-parameter handle 'gnus-region))
5468         buffer-read-only)
5469     (when region
5470       (delete-region (car region) (cdr region))
5471       (set-marker (car region) nil)
5472       (set-marker (cdr region) nil)))
5473   (with-current-buffer (mm-handle-multipart-original-buffer handle)
5474     (let* ((mm-verify-option 'known)
5475            (mm-decrypt-option 'known)
5476            (nparts (mm-possibly-verify-or-decrypt (cdr handle) handle)))
5477       (unless (eq nparts (cdr handle))
5478         (mm-destroy-parts (cdr handle))
5479         (setcdr handle nparts))))
5480   (let ((point (point))
5481         buffer-read-only)
5482     (gnus-mime-display-security handle)
5483     (goto-char point)))
5484
5485 (defun gnus-mime-security-show-details (handle)
5486   (let ((details (mm-handle-multipart-ctl-parameter handle 'gnus-details)))
5487     (if details
5488         (if gnus-mime-security-show-details-inline
5489             (let ((gnus-mime-security-button-pressed t)
5490                   (gnus-mime-security-button-line-format
5491                    (get-text-property (point) 'gnus-line-format))
5492                 buffer-read-only)
5493               (forward-char -1)
5494               (while (eq (get-text-property (point) 'gnus-line-format)
5495                          gnus-mime-security-button-line-format)
5496                 (forward-char -1))
5497               (forward-char)
5498               (delete-region (point)
5499                              (or (text-property-not-all
5500                                   (point) (point-max)
5501                                 'gnus-line-format
5502                                 gnus-mime-security-button-line-format)
5503                                  (point-max)))
5504               (gnus-insert-mime-security-button handle))
5505           (if (gnus-buffer-live-p gnus-mime-security-details-buffer)
5506               (with-current-buffer gnus-mime-security-details-buffer
5507                 (erase-buffer)
5508                 t)
5509             (setq gnus-mime-security-details-buffer
5510                   (gnus-get-buffer-create "*MIME Security Details*")))
5511           (with-current-buffer gnus-mime-security-details-buffer
5512             (insert details)
5513             (goto-char (point-min)))
5514           (pop-to-buffer gnus-mime-security-details-buffer))
5515       (gnus-message 5 "No details."))))
5516
5517 (defun gnus-mime-security-press-button (handle)
5518   (if (mm-handle-multipart-ctl-parameter handle 'gnus-info)
5519       (gnus-mime-security-show-details handle)
5520     (gnus-mime-security-verify-or-decrypt handle)))
5521
5522 (defun gnus-insert-mime-security-button (handle &optional displayed)
5523   (let* ((protocol (mm-handle-multipart-ctl-parameter handle 'protocol))
5524          (gnus-tmp-type
5525           (concat
5526            (or (nth 2 (assoc protocol mm-verify-function-alist))
5527                (nth 2 (assoc protocol mm-decrypt-function-alist))
5528                "Unknown")
5529            (if (equal (car handle) "multipart/signed")
5530                " Signed" " Encrypted")
5531            " Part"))
5532          (gnus-tmp-info
5533           (or (mm-handle-multipart-ctl-parameter handle 'gnus-info)
5534               "Undecided"))
5535          (gnus-tmp-details
5536           (mm-handle-multipart-ctl-parameter handle 'gnus-details))
5537          gnus-tmp-pressed-details
5538          b e)
5539     (setq gnus-tmp-details
5540           (if gnus-tmp-details
5541               (concat "\n" gnus-tmp-details) ""))
5542     (setq gnus-tmp-pressed-details
5543           (if gnus-mime-security-button-pressed gnus-tmp-details ""))
5544     (unless (bolp)
5545       (insert "\n"))
5546     (setq b (point))
5547     (gnus-eval-format
5548      gnus-mime-security-button-line-format
5549      gnus-mime-security-button-line-format-alist
5550      `(keymap ,gnus-mime-security-button-map
5551               ,@(if (>= (string-to-number emacs-version) 21)
5552                     nil ;; XEmacs doesn't care
5553                   (list 'local-map gnus-mime-security-button-map))
5554               gnus-callback gnus-mime-security-press-button
5555               gnus-line-format ,gnus-mime-security-button-line-format
5556               article-type annotation
5557               gnus-data ,handle))
5558     (setq e (point))
5559     (widget-convert-button
5560      'link b e
5561      :mime-handle handle
5562      :action 'gnus-widget-press-button
5563      :button-keymap gnus-mime-security-button-map
5564      :help-echo
5565      (lambda (widget/window &optional overlay pos)
5566        ;; Needed to properly clear the message due to a bug in
5567        ;; wid-edit (XEmacs only).
5568        (if (boundp 'help-echo-owns-message)
5569            (setq help-echo-owns-message t))
5570        (format
5571         "%S: show detail"
5572         (aref gnus-mouse-2 0))))))
5573
5574 (defun gnus-mime-display-security (handle)
5575   (save-restriction
5576     (narrow-to-region (point) (point))
5577     (gnus-insert-mime-security-button handle)
5578     (gnus-mime-display-mixed (cdr handle))
5579     (unless (bolp)
5580       (insert "\n"))
5581     (let ((gnus-mime-security-button-line-format
5582            gnus-mime-security-button-end-line-format))
5583       (gnus-insert-mime-security-button handle))
5584     (mm-set-handle-multipart-parameter
5585      handle 'gnus-region
5586      (cons (set-marker (make-marker) (point-min))
5587            (set-marker (make-marker) (point-max))))))
5588
5589 (gnus-ems-redefine)
5590
5591 (provide 'gnus-art)
5592
5593 (run-hooks 'gnus-art-load-hook)
5594
5595 ;;; gnus-art.el ends here