1853644a3d8abe0eaee3cd2b1a747a8ddf4ce25e
[elisp/gnus.git-] / lisp / gnus-art.el
1 ;;; gnus-art.el --- article mode commands for Semi-gnus
2 ;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003
3 ;;        Free Software Foundation, Inc.
4
5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
6 ;;      MORIOKA Tomohiko <morioka@jaist.ac.jp>
7 ;;      Katsumi Yamaoka <yamaoka@jpl.org>
8 ;; Keywords: mail, news, MIME
9
10 ;; This file is part of GNU Emacs.
11
12 ;; GNU Emacs is free software; you can redistribute it and/or modify
13 ;; it under the terms of the GNU General Public License as published by
14 ;; the Free Software Foundation; either version 2, or (at your option)
15 ;; any later version.
16
17 ;; GNU Emacs is distributed in the hope that it will be useful,
18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
20 ;; GNU General Public License for more details.
21
22 ;; You should have received a copy of the GNU General Public License
23 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
24 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
25 ;; Boston, MA 02111-1307, USA.
26
27 ;;; Commentary:
28
29 ;;; Code:
30
31 (eval-when-compile (require 'cl))
32 (eval-when-compile (require 'static))
33
34 (require 'path-util)
35 (require 'gnus)
36 (require 'gnus-sum)
37 (require 'gnus-spec)
38 (require 'gnus-int)
39 (require 'gnus-win)
40 (require 'alist)
41 (require 'mime-view)
42 (require 'wid-edit)
43
44 ;; Avoid byte-compile warnings.
45 (eval-when-compile
46   (require 'mm-bodies)
47   (require 'mail-parse)
48   (require 'mm-decode)
49   (require 'mm-view)
50   (require 'mm-uu))
51
52 (autoload 'gnus-msg-mail "gnus-msg" nil t)
53 (autoload 'gnus-button-mailto "gnus-msg")
54 (autoload 'gnus-button-reply "gnus-msg" nil t)
55
56 (defgroup gnus-article nil
57   "Article display."
58   :link '(custom-manual "(gnus)The Article Buffer")
59   :group 'gnus)
60
61 (defgroup gnus-article-treat nil
62   "Treating article parts."
63   :link '(custom-manual "(gnus)Article Hiding")
64   :group 'gnus-article)
65
66 (defgroup gnus-article-hiding nil
67   "Hiding article parts."
68   :link '(custom-manual "(gnus)Article Hiding")
69   :group 'gnus-article)
70
71 (defgroup gnus-article-highlight nil
72   "Article highlighting."
73   :link '(custom-manual "(gnus)Article Highlighting")
74   :group 'gnus-article
75   :group 'gnus-visual)
76
77 (defgroup gnus-article-signature nil
78   "Article signatures."
79   :link '(custom-manual "(gnus)Article Signature")
80   :group 'gnus-article)
81
82 (defgroup gnus-article-headers nil
83   "Article headers."
84   :link '(custom-manual "(gnus)Hiding Headers")
85   :group 'gnus-article)
86
87 (defgroup gnus-article-washing nil
88   "Special commands on articles."
89   :link '(custom-manual "(gnus)Article Washing")
90   :group 'gnus-article)
91
92 (defgroup gnus-article-emphasis nil
93   "Fontisizing articles."
94   :link '(custom-manual "(gnus)Article Fontisizing")
95   :group 'gnus-article)
96
97 (defgroup gnus-article-saving nil
98   "Saving articles."
99   :link '(custom-manual "(gnus)Saving Articles")
100   :group 'gnus-article)
101
102 (defgroup gnus-article-mime nil
103   "Worshiping the MIME wonder."
104   :link '(custom-manual "(gnus)Using MIME")
105   :group 'gnus-article)
106
107 (defgroup gnus-article-buttons nil
108   "Pushable buttons in the article buffer."
109   :link '(custom-manual "(gnus)Article Buttons")
110   :group 'gnus-article)
111
112 (defgroup gnus-article-various nil
113   "Other article options."
114   :link '(custom-manual "(gnus)Misc Article")
115   :group 'gnus-article)
116
117 (defcustom gnus-ignored-headers
118   '("^Path:" "^Expires:" "^Date-Received:" "^References:" "^Xref:" "^Lines:"
119     "^Relay-Version:" "^Message-ID:" "^Approved:" "^Sender:" "^Received:"
120     "^X-UIDL:" "^MIME-Version:" "^Return-Path:" "^In-Reply-To:"
121     "^Content-Type:" "^Content-Transfer-Encoding:" "^X-WebTV-Signature:"
122     "^X-MimeOLE:" "^X-MSMail-Priority:" "^X-Priority:" "^X-Loop:"
123     "^X-Authentication-Warning:" "^X-MIME-Autoconverted:" "^X-Face"
124     "^X-Attribution:" "^X-Originating-IP:" "^Delivered-To:"
125     "^NNTP-[-A-Za-z]+:" "^Distribution:" "^X-no-archive:" "^X-Trace:"
126     "^X-Complaints-To:" "^X-NNTP-Posting-Host:" "^X-Orig.*:"
127     "^Abuse-Reports-To:" "^Cache-Post-Path:" "^X-Article-Creation-Date:"
128     "^X-Poster:" "^X-Mail2News-Path:" "^X-Server-Date:" "^X-Cache:"
129     "^Originator:" "^X-Problems-To:" "^X-Auth-User:" "^X-Post-Time:"
130     "^X-Admin:" "^X-UID:" "^Resent-[-A-Za-z]+:" "^X-Mailing-List:"
131     "^Precedence:" "^Original-[-A-Za-z]+:" "^X-filename:" "^X-Orcpt:"
132     "^Old-Received:" "^X-Pgp" "^X-Auth:" "^X-From-Line:"
133     "^X-Gnus-Article-Number:" "^X-Majordomo:" "^X-Url:" "^X-Sender:"
134     "^MBOX-Line" "^Priority:" "^X400-[-A-Za-z]+:"
135     "^Status:" "^X-Gnus-Mail-Source:" "^Cancel-Lock:"
136     "^X-FTN" "^X-EXP32-SerialNo:" "^Encoding:" "^Importance:"
137     "^Autoforwarded:" "^Original-Encoded-Information-Types:" "^X-Ya-Pop3:"
138     "^X-Face-Version:" "^X-Vms-To:" "^X-ML-NAME:" "^X-ML-COUNT:"
139     "^Mailing-List:" "^X-finfo:" "^X-md5sum:" "^X-md5sum-Origin:"
140     "^X-Sun-Charset:" "^X-Accept-Language:" "^X-Envelope-Sender:"
141     "^List-[A-Za-z]+:" "^X-Listprocessor-Version:"
142     "^X-Received:" "^X-Distribute:" "^X-Sequence:" "^X-Juno-Line-Breaks:"
143     "^X-Notes-Item:" "^X-MS-TNEF-Correlator:" "^x-uunet-gateway:"
144     "^X-Received:" "^Content-length:" "X-precedence:"
145     "^X-Authenticated-User:" "^X-Comment" "^X-Report:" "^X-Abuse-Info:"
146     "^X-HTTP-Proxy:" "^X-Mydeja-Info:" "^X-Copyright" "^X-No-Markup:"
147     "^X-Abuse-Info:" "^X-From_:" "^X-Accept-Language:" "^Errors-To:"
148     "^X-BeenThere:" "^X-Mailman-Version:" "^List-Help:" "^List-Post:"
149     "^List-Subscribe:" "^List-Id:" "^List-Unsubscribe:" "^List-Archive:"
150      "^X-Content-length:" "^X-Posting-Agent:" "^Original-Received:"
151      "^X-Request-PGP:" "^X-Fingerprint:" "^X-WRIEnvto:" "^X-WRIEnvfrom:"
152      "^X-Virus-Scanned:" "^X-Delivery-Agent:" "^Posted-Date:" "^X-Gateway:"
153      "^X-Local-Origin:" "^X-Local-Destination:" "^X-UserInfo1:"
154      "^X-Received-Date:" "^X-Hashcash:" "^Face:")
155   "*All headers that start with this regexp will be hidden.
156 This variable can also be a list of regexps of headers to be ignored.
157 If `gnus-visible-headers' is non-nil, this variable will be ignored."
158   :type '(choice :custom-show nil
159                  regexp
160                  (repeat regexp))
161   :group 'gnus-article-hiding)
162
163 (defcustom gnus-visible-headers
164   "^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:"
165   "*All headers that do not match this regexp will be hidden.
166 This variable can also be a list of regexp of headers to remain visible.
167 If this variable is non-nil, `gnus-ignored-headers' will be ignored."
168   :type '(repeat :value-to-internal (lambda (widget value)
169                                       (custom-split-regexp-maybe value))
170                  :match (lambda (widget value)
171                           (or (stringp value)
172                               (widget-editable-list-match widget value)))
173                  regexp)
174   :group 'gnus-article-hiding)
175
176 (defcustom gnus-sorted-header-list
177   '("^From:" "^Subject:" "^Summary:" "^Keywords:" "^Newsgroups:"
178     "^Followup-To:" "^To:" "^Cc:" "^Date:" "^Organization:")
179   "*This variable is a list of regular expressions.
180 If it is non-nil, headers that match the regular expressions will
181 be placed first in the article buffer in the sequence specified by
182 this list."
183   :type '(repeat regexp)
184   :group 'gnus-article-hiding)
185
186 (defcustom gnus-boring-article-headers '(empty followup-to reply-to)
187   "Headers that are only to be displayed if they have interesting data.
188 Possible values in this list are:
189
190   'empty       Headers with no content.
191   'newsgroups  Newsgroup identical to Gnus group.
192   'to-address  To identical to To-address.
193   'followup-to Followup-to identical to Newsgroups.
194   'reply-to    Reply-to identical to From.
195   'date        Date less than four days old.
196   'long-to     To and/or Cc longer than 1024 characters.
197   'many-to     Multiple To and/or Cc."
198   :type '(set (const :tag "Headers with no content." empty)
199               (const :tag "Newsgroups identical to Gnus group." newsgroups)
200               (const :tag "To identical to To-address." to-address)
201               (const :tag "Followup-to identical to Newsgroups." followup-to)
202               (const :tag "Reply-to identical to From." reply-to)
203               (const :tag "Date less than four days old." date)
204               (const :tag "To and/or Cc longer than 1024 characters." long-to)
205               (const :tag "Multiple To and/or Cc headers." many-to))
206   :group 'gnus-article-hiding)
207
208 (defcustom gnus-signature-separator '("^-- $" "^-- *$")
209   "Regexp matching signature separator.
210 This can also be a list of regexps.  In that case, it will be checked
211 from head to tail looking for a separator.  Searches will be done from
212 the end of the buffer."
213   :type '(repeat string)
214   :group 'gnus-article-signature)
215
216 (defcustom gnus-signature-limit nil
217   "Provide a limit to what is considered a signature.
218 If it is a number, no signature may not be longer (in characters) than
219 that number.  If it is a floating point number, no signature may be
220 longer (in lines) than that number.  If it is a function, the function
221 will be called without any parameters, and if it returns nil, there is
222 no signature in the buffer.  If it is a string, it will be used as a
223 regexp.  If it matches, the text in question is not a signature."
224   :type '(choice (integer :value 200)
225                  (number :value 4.0)
226                  (function :value fun)
227                  (regexp :value ".*"))
228   :group 'gnus-article-signature)
229
230 (defcustom gnus-hidden-properties '(invisible t intangible t)
231   "Property list to use for hiding text."
232   :type 'sexp
233   :group 'gnus-article-hiding)
234
235 ;; Fixme: This isn't the right thing for mixed graphical and and
236 ;; non-graphical frames in a session.
237 (defcustom gnus-article-x-face-command
238   (cond
239    ((featurep 'xemacs)
240     (if (or (gnus-image-type-available-p 'xface)
241             (gnus-image-type-available-p 'pbm))
242         'gnus-display-x-face-in-from
243       "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | ee -"))
244    ((and (fboundp 'image-type-available-p)
245          (module-installed-p 'x-face-e21))
246     'x-face-decode-message-header)
247    ((gnus-image-type-available-p 'pbm)
248     'gnus-display-x-face-in-from)
249    ((and window-system
250          (module-installed-p 'x-face-mule))
251     'x-face-mule-gnus-article-display-x-face)
252    (t
253     "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | \
254 display -"))
255   "*String or function to be executed to display an X-Face header.
256 If it is a string, the command will be executed in a sub-shell
257 asynchronously.  The compressed face will be piped to this command."
258   :type `(choice
259           ,@(let (x-face-e21 x-face-mule)
260               (if (featurep 'xemacs)
261                   nil
262                 (setq x-face-e21 (module-installed-p 'x-face-e21)
263                       x-face-mule (module-installed-p 'x-face-mule)))
264               (delq nil
265                     (list
266                      'string
267                      (if (or (gnus-image-type-available-p 'xface)
268                              (gnus-image-type-available-p 'pbm))
269                          '(function-item gnus-display-x-face-in-from))
270                      (if (and x-face-e21
271                               (fboundp 'image-type-available-p))
272                          '(function-item
273                            :tag "x-face-decode-message-header (x-face-e21)"
274                            x-face-decode-message-header))
275                      (if x-face-mule
276                          '(function-item
277                            x-face-mule-gnus-article-display-x-face))
278                      'function))))
279   ;;:version "21.1"
280   :group 'gnus-picon
281   :group 'gnus-article-washing)
282
283 (defcustom gnus-article-x-face-too-ugly nil
284   "Regexp matching posters whose face shouldn't be shown automatically."
285   :type '(choice regexp (const nil))
286   :group 'gnus-article-washing)
287
288 (defcustom gnus-article-banner-alist nil
289   "Banner alist for stripping.
290 For example,
291      ((egroups . \"^[ \\t\\n]*-------------------+\\\\( \\\\(e\\\\|Yahoo! \\\\)Groups Sponsor -+\\\\)?....\\n\\\\(.+\\n\\\\)+\"))"
292   :version "21.1"
293   :type '(repeat (cons symbol regexp))
294   :group 'gnus-article-washing)
295
296 (gnus-define-group-parameter
297  banner
298  :variable-document
299  "Alist of regexps (to match group names) and banner."
300  :variable-group gnus-article-washing
301  :parameter-type
302  '(choice :tag "Banner"
303           :value nil
304           (const :tag "Remove signature" signature)
305           (symbol :tag "Item in `gnus-article-banner-alist'" none)
306           regexp
307           (const :tag "None" nil))
308  :parameter-document
309  "If non-nil, specify how to remove `banners' from articles.
310
311 Symbol `signature' means to remove signatures delimited by
312 `gnus-signature-separator'.  Any other symbol is used to look up a
313 regular expression to match the banner in `gnus-article-banner-alist'.
314 A string is used as a regular expression to match the banner
315 directly.")
316
317 (defcustom gnus-article-address-banner-alist nil
318   "Alist of mail addresses and banners.
319 Each element has the form (ADDRESS . BANNER), where ADDRESS is a regexp
320 to match a mail address in the From: header, BANNER is one of a symbol
321 `signature', an item in `gnus-article-banner-alist', a regexp and nil.
322 If ADDRESS matches author's mail address, it will remove things like
323 advertisements.  For example:
324
325 \((\"@yoo-hoo\\\\.co\\\\.jp\\\\'\" . \"\\n_+\\nDo You Yoo-hoo!\\\\?\\n.*\\n.*\\n\"))
326 "
327   :type '(repeat
328           (cons
329            (regexp :tag "Address")
330            (choice :tag "Banner" :value nil
331                    (const :tag "Remove signature" signature)
332                    (symbol :tag "Item in `gnus-article-banner-alist'" none)
333                    regexp
334                    (const :tag "None" nil))))
335   :group 'gnus-article-washing)
336
337 (defcustom gnus-emphasis-alist
338   (let ((format
339          "\\(\\s-\\|^\\|\\=\\|[-\"]\\|\\s(\\)\\(%s\\(\\w+\\(\\s-+\\w+\\)*[.,]?\\)%s\\)\\(\\([-,.;:!?\"]\\|\\s)\\)+\\s-\\|[?!.]\\s-\\|\\s)\\|\\s-\\)")
340         (types
341          '(("\\*" "\\*" bold)
342            ("_" "_" underline)
343            ("/" "/" italic)
344            ("_/" "/_" underline-italic)
345            ("_\\*" "\\*_" underline-bold)
346            ("\\*/" "/\\*" bold-italic)
347            ("_\\*/" "/\\*_" underline-bold-italic))))
348     `(,@(mapcar
349          (lambda (spec)
350            (list
351             (format format (car spec) (car (cdr spec)))
352             2 3 (intern (format "gnus-emphasis-%s" (nth 2 spec)))))
353          types)
354         ("\\(\\s-\\|^\\)\\(-\\(\\(\\w\\|-[^-]\\)+\\)-\\)\\(\\s-\\|[?!.,;]\\)"
355          2 3 gnus-emphasis-strikethru)
356         ("\\(\\s-\\|^\\)\\(_\\(\\(\\w\\|_[^_]\\)+\\)_\\)\\(\\s-\\|[?!.,;]\\)"
357          2 3 gnus-emphasis-underline)))
358   "*Alist that says how to fontify certain phrases.
359 Each item looks like this:
360
361   (\"_\\\\(\\\\w+\\\\)_\" 0 1 'underline)
362
363 The first element is a regular expression to be matched.  The second
364 is a number that says what regular expression grouping used to find
365 the entire emphasized word.  The third is a number that says what
366 regexp grouping should be displayed and highlighted.  The fourth
367 is the face used for highlighting."
368   :type '(repeat (list :value ("" 0 0 default)
369                        regexp
370                        (integer :tag "Match group")
371                        (integer :tag "Emphasize group")
372                        face))
373   :group 'gnus-article-emphasis)
374
375 (defcustom gnus-emphasize-whitespace-regexp "^[ \t]+\\|[ \t]*\n"
376   "A regexp to describe whitespace which should not be emphasized.
377 Typical values are \"^[ \\t]+\\\\|[ \\t]*\\n\" and \"[ \\t]+\\\\|[ \\t]*\\n\".
378 The former avoids underlining of leading and trailing whitespace,
379 and the latter avoids underlining any whitespace at all."
380   :version "21.1"
381   :group 'gnus-article-emphasis
382   :type 'regexp)
383
384 (defface gnus-emphasis-bold '((t (:bold t)))
385   "Face used for displaying strong emphasized text (*word*)."
386   :group 'gnus-article-emphasis)
387
388 (defface gnus-emphasis-italic '((t (:italic t)))
389   "Face used for displaying italic emphasized text (/word/)."
390   :group 'gnus-article-emphasis)
391
392 (defface gnus-emphasis-underline '((t (:underline t)))
393   "Face used for displaying underlined emphasized text (_word_)."
394   :group 'gnus-article-emphasis)
395
396 (defface gnus-emphasis-underline-bold '((t (:bold t :underline t)))
397   "Face used for displaying underlined bold emphasized text (_*word*_)."
398   :group 'gnus-article-emphasis)
399
400 (defface gnus-emphasis-underline-italic '((t (:italic t :underline t)))
401   "Face used for displaying underlined italic emphasized text (_/word/_)."
402   :group 'gnus-article-emphasis)
403
404 (defface gnus-emphasis-bold-italic '((t (:bold t :italic t)))
405   "Face used for displaying bold italic emphasized text (/*word*/)."
406   :group 'gnus-article-emphasis)
407
408 (defface gnus-emphasis-underline-bold-italic
409   '((t (:bold t :italic t :underline t)))
410   "Face used for displaying underlined bold italic emphasized text.
411 Example: (_/*word*/_)."
412   :group 'gnus-article-emphasis)
413
414 (defface gnus-emphasis-strikethru '((t (:strikethru t)))
415   "Face used for displaying strike-through text (-word-)."
416   :group 'gnus-article-emphasis)
417
418 (defface gnus-emphasis-highlight-words
419   '((t (:background "black" :foreground "yellow")))
420   "Face used for displaying highlighted words."
421   :group 'gnus-article-emphasis)
422
423 (defcustom gnus-article-time-format "%a, %b %d %Y %T %Z"
424   "Format for display of Date headers in article bodies.
425 See `format-time-string' for the possible values.
426
427 The variable can also be function, which should return a complete Date
428 header.  The function is called with one argument, the time, which can
429 be fed to `format-time-string'."
430   :type '(choice string symbol)
431   :link '(custom-manual "(gnus)Article Date")
432   :group 'gnus-article-washing)
433
434 (eval-and-compile
435   (autoload 'mail-extract-address-components "mail-extr"))
436
437 (defcustom gnus-save-all-headers t
438   "*If non-nil, don't remove any headers before saving."
439   :group 'gnus-article-saving
440   :type 'boolean)
441
442 (defcustom gnus-prompt-before-saving 'always
443   "*This variable says how much prompting is to be done when saving articles.
444 If it is nil, no prompting will be done, and the articles will be
445 saved to the default files.  If this variable is `always', each and
446 every article that is saved will be preceded by a prompt, even when
447 saving large batches of articles.  If this variable is neither nil not
448 `always', there the user will be prompted once for a file name for
449 each invocation of the saving commands."
450   :group 'gnus-article-saving
451   :type '(choice (item always)
452                  (item :tag "never" nil)
453                  (sexp :tag "once" :format "%t\n" :value t)))
454
455 (defcustom gnus-saved-headers gnus-visible-headers
456   "Headers to keep if `gnus-save-all-headers' is nil.
457 If `gnus-save-all-headers' is non-nil, this variable will be ignored.
458 If that variable is nil, however, all headers that match this regexp
459 will be kept while the rest will be deleted before saving."
460   :group 'gnus-article-saving
461   :type 'regexp)
462
463 (defcustom gnus-default-article-saver 'gnus-summary-save-in-rmail
464   "A function to save articles in your favourite format.
465 The function must be interactively callable (in other words, it must
466 be an Emacs command).
467
468 Gnus provides the following functions:
469
470 * gnus-summary-save-in-rmail (Rmail format)
471 * gnus-summary-save-in-mail (Unix mail format)
472 * gnus-summary-save-in-folder (MH folder)
473 * gnus-summary-save-in-file (article format)
474 * gnus-summary-save-body-in-file (article body)
475 * gnus-summary-save-in-vm (use VM's folder format)
476 * gnus-summary-write-to-file (article format -- overwrite)."
477   :group 'gnus-article-saving
478   :type '(radio (function-item gnus-summary-save-in-rmail)
479                 (function-item gnus-summary-save-in-mail)
480                 (function-item gnus-summary-save-in-folder)
481                 (function-item gnus-summary-save-in-file)
482                 (function-item gnus-summary-save-body-in-file)
483                 (function-item gnus-summary-save-in-vm)
484                 (function-item gnus-summary-write-to-file)))
485
486 (defcustom gnus-rmail-save-name 'gnus-plain-save-name
487   "A function generating a file name to save articles in Rmail format.
488 The function is called with NEWSGROUP, HEADERS, and optional LAST-FILE."
489   :group 'gnus-article-saving
490   :type 'function)
491
492 (defcustom gnus-mail-save-name 'gnus-plain-save-name
493   "A function generating a file name to save articles in Unix mail format.
494 The function is called with NEWSGROUP, HEADERS, and optional LAST-FILE."
495   :group 'gnus-article-saving
496   :type 'function)
497
498 (defcustom gnus-folder-save-name 'gnus-folder-save-name
499   "A function generating a file name to save articles in MH folder.
500 The function is called with NEWSGROUP, HEADERS, and optional LAST-FOLDER."
501   :group 'gnus-article-saving
502   :type 'function)
503
504 (defcustom gnus-file-save-name 'gnus-numeric-save-name
505   "A function generating a file name to save articles in article format.
506 The function is called with NEWSGROUP, HEADERS, and optional
507 LAST-FILE."
508   :group 'gnus-article-saving
509   :type 'function)
510
511 (defcustom gnus-split-methods
512   '((gnus-article-archive-name)
513     (gnus-article-nndoc-name))
514   "*Variable used to suggest where articles are to be saved.
515 For instance, if you would like to save articles related to Gnus in
516 the file \"gnus-stuff\", and articles related to VM in \"vm-stuff\",
517 you could set this variable to something like:
518
519  '((\"^Subject:.*gnus\\|^Newsgroups:.*gnus\" \"gnus-stuff\")
520    (\"^Subject:.*vm\\|^Xref:.*vm\" \"vm-stuff\"))
521
522 This variable is an alist where the where the key is the match and the
523 value is a list of possible files to save in if the match is non-nil.
524
525 If the match is a string, it is used as a regexp match on the
526 article.  If the match is a symbol, that symbol will be funcalled
527 from the buffer of the article to be saved with the newsgroup as the
528 parameter.  If it is a list, it will be evaled in the same buffer.
529
530 If this form or function returns a string, this string will be used as
531 a possible file name; and if it returns a non-nil list, that list will
532 be used as possible file names."
533   :group 'gnus-article-saving
534   :type '(repeat (choice (list :value (fun) function)
535                          (cons :value ("" "") regexp (repeat string))
536                          (sexp :value nil))))
537
538 (defcustom gnus-article-display-method-for-mime
539   'gnus-article-display-mime-message
540   "Function to display a MIME message.
541 The function is called from the article buffer."
542   :group 'gnus-article-mime
543   :type 'function)
544
545 (defcustom gnus-article-display-method-for-traditional
546   'gnus-article-display-traditional-message
547   "*Function to display a traditional message.
548 The function is called from the article buffer."
549   :group 'gnus-article-mime
550   :type 'function)
551
552 (defcustom gnus-page-delimiter "^\^L"
553   "*Regexp describing what to use as article page delimiters.
554 The default value is \"^\^L\", which is a form linefeed at the
555 beginning of a line."
556   :type 'regexp
557   :group 'gnus-article-various)
558
559 (defcustom gnus-article-mode-line-format "Gnus: %g [%w] %S%m"
560   "*The format specification for the article mode line.
561 See `gnus-summary-mode-line-format' for a closer description.
562
563 The following additional specs are available:
564
565 %w  The article washing status.
566 %m  The number of MIME parts in the article."
567   :type 'string
568   :group 'gnus-article-various)
569
570 (defcustom gnus-article-mode-hook nil
571   "*A hook for Gnus article mode."
572   :type 'hook
573   :group 'gnus-article-various)
574
575 (when (featurep 'xemacs)
576   ;; Extracted from gnus-xmas-define in order to preserve user settings
577   (when (fboundp 'turn-off-scroll-in-place)
578     (add-hook 'gnus-article-mode-hook 'turn-off-scroll-in-place))
579   ;; Extracted from gnus-xmas-redefine in order to preserve user settings
580   (add-hook 'gnus-article-mode-hook 'gnus-xmas-article-menu-add))
581
582 (defcustom gnus-article-menu-hook nil
583   "*Hook run after the creation of the article mode menu."
584   :type 'hook
585   :group 'gnus-article-various)
586
587 (defcustom gnus-article-prepare-hook nil
588   "*A hook called after an article has been prepared in the article buffer."
589   :type 'hook
590   :group 'gnus-article-various)
591
592 (defcustom gnus-article-hide-pgp-hook nil
593   "*A hook called after successfully hiding a PGP signature."
594   :type 'hook
595   :group 'gnus-article-various)
596
597 (defcustom gnus-article-button-face 'bold
598   "Face used for highlighting buttons in the article buffer.
599
600 An article button is a piece of text that you can activate by pressing
601 `RET' or `mouse-2' above it."
602   :type 'face
603   :group 'gnus-article-buttons)
604
605 (defcustom gnus-article-mouse-face 'highlight
606   "Face used for mouse highlighting in the article buffer.
607
608 Article buttons will be displayed in this face when the cursor is
609 above them."
610   :type 'face
611   :group 'gnus-article-buttons)
612
613 (defcustom gnus-signature-face 'gnus-signature-face
614   "Face used for highlighting a signature in the article buffer.
615 Obsolete; use the face `gnus-signature-face' for customizations instead."
616   :type 'face
617   :group 'gnus-article-highlight
618   :group 'gnus-article-signature)
619
620 (defface gnus-signature-face
621   '((t
622      (:italic t)))
623   "Face used for highlighting a signature in the article buffer."
624   :group 'gnus-article-highlight
625   :group 'gnus-article-signature)
626
627 (defface gnus-header-from-face
628   '((((class color)
629       (background dark))
630      (:foreground "spring green"))
631     (((class color)
632       (background light))
633      (:foreground "red3"))
634     (t
635      (:italic t)))
636   "Face used for displaying from headers."
637   :group 'gnus-article-headers
638   :group 'gnus-article-highlight)
639
640 (defface gnus-header-subject-face
641   '((((class color)
642       (background dark))
643      (:foreground "SeaGreen3"))
644     (((class color)
645       (background light))
646      (:foreground "red4"))
647     (t
648      (:bold t :italic t)))
649   "Face used for displaying subject headers."
650   :group 'gnus-article-headers
651   :group 'gnus-article-highlight)
652
653 (defface gnus-header-newsgroups-face
654   '((((class color)
655       (background dark))
656      (:foreground "yellow" :italic t))
657     (((class color)
658       (background light))
659      (:foreground "MidnightBlue" :italic t))
660     (t
661      (:italic t)))
662   "Face used for displaying newsgroups headers."
663   :group 'gnus-article-headers
664   :group 'gnus-article-highlight)
665
666 (defface gnus-header-name-face
667   '((((class color)
668       (background dark))
669      (:foreground "SeaGreen"))
670     (((class color)
671       (background light))
672      (:foreground "maroon"))
673     (t
674      (:bold t)))
675   "Face used for displaying header names."
676   :group 'gnus-article-headers
677   :group 'gnus-article-highlight)
678
679 (defface gnus-header-content-face
680   '((((class color)
681       (background dark))
682      (:foreground "forest green" :italic t))
683     (((class color)
684       (background light))
685      (:foreground "indianred4" :italic t))
686     (t
687      (:italic t)))
688   "Face used for displaying header content."
689   :group 'gnus-article-headers
690   :group 'gnus-article-highlight)
691
692 (defcustom gnus-header-face-alist
693   '(("From" nil gnus-header-from-face)
694     ("Subject" nil gnus-header-subject-face)
695     ("Newsgroups:.*," nil gnus-header-newsgroups-face)
696     ("" gnus-header-name-face gnus-header-content-face))
697   "*Controls highlighting of article header.
698
699 An alist of the form (HEADER NAME CONTENT).
700
701 HEADER is a regular expression which should match the name of an
702 header header and NAME and CONTENT are either face names or nil.
703
704 The name of each header field will be displayed using the face
705 specified by the first element in the list where HEADER match the
706 header name and NAME is non-nil.  Similarly, the content will be
707 displayed by the first non-nil matching CONTENT face."
708   :group 'gnus-article-headers
709   :group 'gnus-article-highlight
710   :type '(repeat (list (regexp :tag "Header")
711                        (choice :tag "Name"
712                                (item :tag "skip" nil)
713                                (face :value default))
714                        (choice :tag "Content"
715                                (item :tag "skip" nil)
716                                (face :value default)))))
717
718 (defcustom gnus-article-decode-hook nil
719   "*Hook run to decode charsets in articles."
720   :group 'gnus-article-headers
721   :type 'hook)
722
723 (defcustom gnus-display-mime-function 'gnus-display-mime
724   "Function to display MIME articles."
725   :group 'gnus-article-mime
726   :type 'function)
727
728 (defvar gnus-decode-header-function 'mail-decode-encoded-word-region
729   "Function used to decode headers.")
730
731 (defvar gnus-article-dumbquotes-map
732   '(("\200" "EUR")
733     ("\202" ",")
734     ("\203" "f")
735     ("\204" ",,")
736     ("\205" "...")
737     ("\213" "<")
738     ("\214" "OE")
739     ("\221" "`")
740     ("\222" "'")
741     ("\223" "``")
742     ("\224" "\"")
743     ("\225" "*")
744     ("\226" "-")
745     ("\227" "--")
746     ("\230" "~")
747     ("\231" "(TM)")
748     ("\233" ">")
749     ("\234" "oe")
750     ("\264" "'"))
751   "Table for MS-to-Latin1 translation.")
752
753 (defcustom gnus-ignored-mime-types nil
754   "List of MIME types that should be ignored by Gnus."
755   :version "21.1"
756   :group 'gnus-article-mime
757   :type '(repeat regexp))
758
759 (defcustom gnus-unbuttonized-mime-types '(".*/.*")
760   "List of MIME types that should not be given buttons when rendered inline.
761 See also `gnus-buttonized-mime-types' which may override this variable.
762 This variable is only used when `gnus-inhibit-mime-unbuttonizing' is nil."
763   :version "21.1"
764   :group 'gnus-article-mime
765   :type '(repeat regexp))
766
767 (defcustom gnus-buttonized-mime-types nil
768   "List of MIME types that should be given buttons when rendered inline.
769 If set, this variable overrides `gnus-unbuttonized-mime-types'.
770 To see e.g. security buttons you could set this to
771 `(\"multipart/signed\")'.
772 This variable is only used when `gnus-inhibit-mime-unbuttonizing' is nil."
773   :version "21.1"
774   :group 'gnus-article-mime
775   :type '(repeat regexp))
776
777 (defcustom gnus-inhibit-mime-unbuttonizing nil
778   "If non-nil, all MIME parts get buttons.
779 When nil (the default value), then some MIME parts do not get buttons,
780 as described by the variables `gnus-buttonized-mime-types' and
781 `gnus-unbuttonized-mime-types'."
782   :version "21.3"
783   :type 'boolean)
784
785 (defcustom gnus-body-boundary-delimiter "_"
786   "String used to delimit header and body.
787 This variable is used by `gnus-article-treat-body-boundary' which can
788 be controlled by `gnus-treat-body-boundary'."
789   :group 'gnus-article-various
790   :type '(choice (item :tag "None" :value nil)
791                  string))
792
793 (defcustom gnus-picon-databases '("/usr/lib/picon" "/usr/local/faces")
794   "Defines the location of the faces database.
795 For information on obtaining this database of pretty pictures, please
796 see http://www.cs.indiana.edu/picons/ftp/index.html"
797   :type '(repeat directory)
798   :link '(url-link :tag "download"
799                    "http://www.cs.indiana.edu/picons/ftp/index.html")
800   :link '(custom-manual "(gnus)Picons")
801   :group 'gnus-picon)
802
803 (defun gnus-picons-installed-p ()
804   "Say whether picons are installed on your machine."
805   (let ((installed nil))
806     (dolist (database gnus-picon-databases)
807       (when (file-exists-p database)
808         (setq installed t)))
809     installed))
810
811 (defcustom gnus-article-mime-part-function nil
812   "Function called with a MIME handle as the argument.
813 This is meant for people who want to do something automatic based
814 on parts -- for instance, adding Vcard info to a database."
815   :group 'gnus-article-mime
816   :type 'function)
817
818 (defcustom gnus-mime-multipart-functions nil
819   "An alist of MIME types to functions to display them."
820   :version "21.1"
821   :group 'gnus-article-mime
822   :type 'alist)
823
824 (defcustom gnus-article-date-lapsed-new-header nil
825   "Whether the X-Sent and Date headers can coexist.
826 When using `gnus-treat-date-lapsed', the \"X-Sent:\" header will
827 either replace the old \"Date:\" header (if this variable is nil), or
828 be added below it (otherwise)."
829   :version "21.1"
830   :group 'gnus-article-headers
831   :type 'boolean)
832
833 (defcustom gnus-article-mime-match-handle-function 'undisplayed-alternative
834   "Function called with a MIME handle as the argument.
835 This is meant for people who want to view first matched part.
836 For `undisplayed-alternative' (default), the first undisplayed
837 part or alternative part is used.  For `undisplayed', the first
838 undisplayed part is used.  For a function, the first part which
839 the function return `t' is used.  For `nil', the first part is
840 used."
841   :version "21.1"
842   :group 'gnus-article-mime
843   :type '(choice
844           (item :tag "first" :value nil)
845           (item :tag "undisplayed" :value undisplayed)
846           (item :tag "undisplayed or alternative"
847                 :value undisplayed-alternative)
848           (function)))
849
850 (defcustom gnus-mime-action-alist
851   '(("save to file" . gnus-mime-save-part)
852     ("save and strip" . gnus-mime-save-part-and-strip)
853     ("display as text" . gnus-mime-inline-part)
854     ("view the part" . gnus-mime-view-part)
855     ("pipe to command" . gnus-mime-pipe-part)
856     ("toggle display" . gnus-article-press-button)
857     ("toggle display" . gnus-article-view-part-as-charset)
858     ("view as type" . gnus-mime-view-part-as-type)
859     ("view internally" . gnus-mime-view-part-internally)
860     ("view externally" . gnus-mime-view-part-externally))
861   "An alist of actions that run on the MIME attachment."
862   :group 'gnus-article-mime
863   :type '(repeat (cons (string :tag "name")
864                        (function))))
865
866 ;;;
867 ;;; The treatment variables
868 ;;;
869
870 (defvar gnus-part-display-hook nil
871   "Hook called on parts that are to receive treatment.")
872
873 (defvar gnus-article-treat-custom
874   '(choice (const :tag "Off" nil)
875            (const :tag "On" t)
876            (const :tag "Header" head)
877            (const :tag "Last" last)
878            (const :tag "Mime" mime)
879            (integer :tag "Less")
880            (repeat :tag "Groups" regexp)
881            (sexp :tag "Predicate")))
882
883 (defvar gnus-article-treat-head-custom
884   '(choice (const :tag "Off" nil)
885            (const :tag "Header" head)))
886
887 (defvar gnus-article-treat-types '("text/plain")
888   "Parts to treat.")
889
890 (defvar gnus-inhibit-treatment nil
891   "Whether to inhibit treatment.")
892
893 (defcustom gnus-treat-highlight-signature '(or last (typep "text/x-vcard"))
894   "Highlight the signature.
895 Valid values are nil, t, `head', `last', an integer or a predicate.
896 See Info node `(gnus)Customizing Articles'."
897   :group 'gnus-article-treat
898   :link '(custom-manual "(gnus)Customizing Articles")
899   :type gnus-article-treat-custom)
900 (put 'gnus-treat-highlight-signature 'highlight t)
901
902 (defcustom gnus-treat-buttonize 100000
903   "Add buttons.
904 Valid values are nil, t, `head', `last', an integer or a predicate.
905 See Info node `(gnus)Customizing Articles'."
906   :group 'gnus-article-treat
907   :link '(custom-manual "(gnus)Customizing Articles")
908   :type gnus-article-treat-custom)
909 (put 'gnus-treat-buttonize 'highlight t)
910
911 (defcustom gnus-treat-buttonize-head 'head
912   "Add buttons to the head.
913 Valid values are nil, t, `head', `last', an integer or a predicate.
914 See Info node `(gnus)Customizing Articles' for details."
915   :group 'gnus-article-treat
916   :link '(custom-manual "(gnus)Customizing Articles")
917   :type gnus-article-treat-head-custom)
918 (put 'gnus-treat-buttonize-head 'highlight t)
919
920 (defcustom gnus-treat-emphasize
921   (and (or window-system
922            (featurep 'xemacs)
923            (>= (string-to-number emacs-version) 21))
924        50000)
925   "Emphasize text.
926 Valid values are nil, t, `head', `last', an integer or a predicate.
927 See Info node `(gnus)Customizing Articles' for details."
928   :group 'gnus-article-treat
929   :link '(custom-manual "(gnus)Customizing Articles")
930   :type gnus-article-treat-custom)
931 (put 'gnus-treat-emphasize 'highlight t)
932
933 (defcustom gnus-treat-strip-cr nil
934   "Remove carriage returns.
935 Valid values are nil, t, `head', `last', an integer or a predicate.
936 See Info node `(gnus)Customizing Articles' for details."
937   :group 'gnus-article-treat
938   :link '(custom-manual "(gnus)Customizing Articles")
939   :type gnus-article-treat-custom)
940
941 (defcustom gnus-treat-unsplit-urls nil
942   "Remove newlines from within URLs.
943 Valid values are nil, t, `head', `last', an integer or a predicate.
944 See Info node `(gnus)Customizing Articles' for details."
945   :group 'gnus-article-treat
946   :link '(custom-manual "(gnus)Customizing Articles")
947   :type gnus-article-treat-custom)
948
949 (defcustom gnus-treat-leading-whitespace nil
950   "Remove leading whitespace in headers.
951 Valid values are nil, t, `head', `last', an integer or a predicate.
952 See Info node `(gnus)Customizing Articles' for details."
953   :group 'gnus-article-treat
954   :link '(custom-manual "(gnus)Customizing Articles")
955   :type gnus-article-treat-custom)
956
957 (defcustom gnus-treat-hide-headers 'head
958   "Hide headers.
959 Valid values are nil, t, `head', `last', an integer or a predicate.
960 See Info node `(gnus)Customizing Articles' for details."
961   :group 'gnus-article-treat
962   :link '(custom-manual "(gnus)Customizing Articles")
963   :type gnus-article-treat-head-custom)
964
965 (defcustom gnus-treat-hide-boring-headers nil
966   "Hide boring headers.
967 Valid values are nil, t, `head', `last', an integer or a predicate.
968 See Info node `(gnus)Customizing Articles' for details."
969   :group 'gnus-article-treat
970   :link '(custom-manual "(gnus)Customizing Articles")
971   :type gnus-article-treat-head-custom)
972
973 (defcustom gnus-treat-hide-signature nil
974   "Hide the signature.
975 Valid values are nil, t, `head', `last', an integer or a predicate.
976 See Info node `(gnus)Customizing Articles' for details."
977   :group 'gnus-article-treat
978   :link '(custom-manual "(gnus)Customizing Articles")
979   :type gnus-article-treat-custom)
980
981 (defcustom gnus-treat-fill-article nil
982   "Fill the article.
983 Valid values are nil, t, `head', `last', an integer or a predicate.
984 See Info node `(gnus)Customizing Articles' for details."
985   :group 'gnus-article-treat
986   :link '(custom-manual "(gnus)Customizing Articles")
987   :type gnus-article-treat-custom)
988
989 (defcustom gnus-treat-hide-citation nil
990   "Hide cited text.
991 Valid values are nil, t, `head', `last', an integer or a predicate.
992 See Info node `(gnus)Customizing Articles' for details."
993   :group 'gnus-article-treat
994   :link '(custom-manual "(gnus)Customizing Articles")
995   :type gnus-article-treat-custom)
996
997 (defcustom gnus-treat-hide-citation-maybe nil
998   "Hide cited text.
999 Valid values are nil, t, `head', `last', an integer or a predicate.
1000 See Info node `(gnus)Customizing Articles' for details."
1001   :group 'gnus-article-treat
1002   :link '(custom-manual "(gnus)Customizing Articles")
1003   :type gnus-article-treat-custom)
1004
1005 (defcustom gnus-treat-strip-list-identifiers 'head
1006   "Strip list identifiers from `gnus-list-identifiers`.
1007 Valid values are nil, t, `head', `last', an integer or a predicate.
1008 See Info node `(gnus)Customizing Articles' for details."
1009   :version "21.1"
1010   :group 'gnus-article-treat
1011   :link '(custom-manual "(gnus)Customizing Articles")
1012   :type gnus-article-treat-custom)
1013
1014 (defcustom gnus-treat-strip-pgp t
1015   "Strip PGP signatures.
1016 Valid values are nil, t, `head', `last', an integer or a predicate.
1017 See Info node `(gnus)Customizing Articles' for details."
1018   :group 'gnus-article-treat
1019   :link '(custom-manual "(gnus)Customizing Articles")
1020   :type gnus-article-treat-custom)
1021
1022 (defcustom gnus-treat-strip-pem nil
1023   "Strip PEM signatures.
1024 Valid values are nil, t, `head', `last', an integer or a predicate.
1025 See Info node `(gnus)Customizing Articles' for details."
1026   :group 'gnus-article-treat
1027   :link '(custom-manual "(gnus)Customizing Articles")
1028   :type gnus-article-treat-custom)
1029
1030 (defcustom gnus-treat-strip-banner t
1031   "Strip banners from articles.
1032 The banner to be stripped is specified in the `banner' group parameter.
1033 Valid values are nil, t, `head', `last', an integer or a predicate.
1034 See Info node `(gnus)Customizing Articles' for details."
1035   :group 'gnus-article-treat
1036   :link '(custom-manual "(gnus)Customizing Articles")
1037   :type gnus-article-treat-custom)
1038
1039 (defcustom gnus-treat-highlight-headers 'head
1040   "Highlight the headers.
1041 Valid values are nil, t, `head', `last', an integer or a predicate.
1042 See Info node `(gnus)Customizing Articles' for details."
1043   :group 'gnus-article-treat
1044   :link '(custom-manual "(gnus)Customizing Articles")
1045   :type gnus-article-treat-head-custom)
1046 (put 'gnus-treat-highlight-headers 'highlight t)
1047
1048 (defcustom gnus-treat-highlight-citation t
1049   "Highlight cited text.
1050 Valid values are nil, t, `head', `last', an integer or a predicate.
1051 See Info node `(gnus)Customizing Articles' for details."
1052   :group 'gnus-article-treat
1053   :link '(custom-manual "(gnus)Customizing Articles")
1054   :type gnus-article-treat-custom)
1055 (put 'gnus-treat-highlight-citation 'highlight t)
1056
1057 (defcustom gnus-treat-date-ut nil
1058   "Display the Date in UT (GMT).
1059 Valid values are nil, t, `head', `last', an integer or a predicate.
1060 See Info node `(gnus)Customizing Articles' for details."
1061   :group 'gnus-article-treat
1062   :link '(custom-manual "(gnus)Customizing Articles")
1063   :type gnus-article-treat-head-custom)
1064
1065 (defcustom gnus-treat-date-local nil
1066   "Display the Date in the local timezone.
1067 Valid values are nil, t, `head', `last', an integer or a predicate.
1068 See Info node `(gnus)Customizing Articles' for details."
1069   :group 'gnus-article-treat
1070   :link '(custom-manual "(gnus)Customizing Articles")
1071   :type gnus-article-treat-head-custom)
1072
1073 (defcustom gnus-treat-date-english nil
1074   "Display the Date in a format that can be read aloud in English.
1075 Valid values are nil, t, `head', `last', an integer or a predicate.
1076 See Info node `(gnus)Customizing Articles' for details."
1077   :group 'gnus-article-treat
1078   :link '(custom-manual "(gnus)Customizing Articles")
1079   :type gnus-article-treat-head-custom)
1080
1081 (defcustom gnus-treat-date-lapsed nil
1082   "Display the Date header in a way that says how much time has elapsed.
1083 Valid values are nil, t, `head', `last', an integer or a predicate.
1084 See Info node `(gnus)Customizing Articles' for details."
1085   :group 'gnus-article-treat
1086   :link '(custom-manual "(gnus)Customizing Articles")
1087   :type gnus-article-treat-head-custom)
1088
1089 (defcustom gnus-treat-date-original nil
1090   "Display the date in the original timezone.
1091 Valid values are nil, t, `head', `last', an integer or a predicate.
1092 See Info node `(gnus)Customizing Articles' for details."
1093   :group 'gnus-article-treat
1094   :link '(custom-manual "(gnus)Customizing Articles")
1095   :type gnus-article-treat-head-custom)
1096
1097 (defcustom gnus-treat-date-iso8601 nil
1098   "Display the date in the ISO8601 format.
1099 Valid values are nil, t, `head', `last', an integer or a predicate.
1100 See Info node `(gnus)Customizing Articles' for details."
1101   :version "21.1"
1102   :group 'gnus-article-treat
1103   :link '(custom-manual "(gnus)Customizing Articles")
1104   :type gnus-article-treat-head-custom)
1105
1106 (defcustom gnus-treat-date-user-defined nil
1107   "Display the date in a user-defined format.
1108 The format is defined by the `gnus-article-time-format' variable.
1109 Valid values are nil, t, `head', `last', an integer or a predicate.
1110 See Info node `(gnus)Customizing Articles' for details."
1111   :group 'gnus-article-treat
1112   :link '(custom-manual "(gnus)Customizing Articles")
1113   :type gnus-article-treat-head-custom)
1114
1115 (defcustom gnus-treat-strip-headers-in-body t
1116   "Strip the X-No-Archive header line from the beginning of the body.
1117 Valid values are nil, t, `head', `last', an integer or a predicate.
1118 See Info node `(gnus)Customizing Articles' for details."
1119   :version "21.1"
1120   :group 'gnus-article-treat
1121   :link '(custom-manual "(gnus)Customizing Articles")
1122   :type gnus-article-treat-custom)
1123
1124 (defcustom gnus-treat-strip-trailing-blank-lines nil
1125   "Strip trailing blank lines.
1126 Valid values are nil, t, `head', `last', an integer or a predicate.
1127 See Info node `(gnus)Customizing Articles' for details."
1128   :group 'gnus-article-treat
1129   :link '(custom-manual "(gnus)Customizing Articles")
1130   :type gnus-article-treat-custom)
1131
1132 (defcustom gnus-treat-strip-leading-blank-lines nil
1133   "Strip leading blank lines.
1134 Valid values are nil, t, `head', `last', an integer or a predicate.
1135 See Info node `(gnus)Customizing Articles' for details."
1136   :group 'gnus-article-treat
1137   :link '(custom-manual "(gnus)Customizing Articles")
1138   :type gnus-article-treat-custom)
1139
1140 (defcustom gnus-treat-strip-multiple-blank-lines nil
1141   "Strip multiple blank lines.
1142 Valid values are nil, t, `head', `last', an integer or a predicate.
1143 See Info node `(gnus)Customizing Articles' for details."
1144   :group 'gnus-article-treat
1145   :link '(custom-manual "(gnus)Customizing Articles")
1146   :type gnus-article-treat-custom)
1147
1148 (defcustom gnus-treat-unfold-headers 'head
1149   "Unfold folded header lines.
1150 Valid values are nil, t, `head', `last', an integer or a predicate.
1151 See Info node `(gnus)Customizing Articles' for details."
1152   :group 'gnus-article-treat
1153   :link '(custom-manual "(gnus)Customizing Articles")
1154   :type gnus-article-treat-custom)
1155
1156 (defcustom gnus-treat-fold-headers nil
1157   "Fold headers.
1158 Valid values are nil, t, `head', `last', an integer or a predicate.
1159 See Info node `(gnus)Customizing Articles' for details."
1160   :group 'gnus-article-treat
1161   :link '(custom-manual "(gnus)Customizing Articles")
1162   :type gnus-article-treat-custom)
1163
1164 (defcustom gnus-treat-fold-newsgroups 'head
1165   "Fold the Newsgroups and Followup-To headers.
1166 Valid values are nil, t, `head', `last', an integer or a predicate.
1167 See Info node `(gnus)Customizing Articles' for details."
1168   :group 'gnus-article-treat
1169   :link '(custom-manual "(gnus)Customizing Articles")
1170   :type gnus-article-treat-custom)
1171
1172 (defcustom gnus-treat-overstrike t
1173   "Treat overstrike highlighting.
1174 Valid values are nil, t, `head', `last', an integer or a predicate.
1175 See Info node `(gnus)Customizing Articles' for details."
1176   :group 'gnus-article-treat
1177   :link '(custom-manual "(gnus)Customizing Articles")
1178   :type gnus-article-treat-custom)
1179 (put 'gnus-treat-overstrike 'highlight t)
1180
1181 (defcustom gnus-treat-display-xface
1182   (and (not noninteractive)
1183        (or (and (fboundp 'image-type-available-p)
1184                 (image-type-available-p 'xbm)
1185                 (string-match "^0x" (shell-command-to-string "uncompface")))
1186            (and (featurep 'xemacs)
1187                 (featurep 'xface))
1188            (eq 'x-face-mule-gnus-article-display-x-face
1189                gnus-article-x-face-command))
1190        'head)
1191   "Display X-Face headers.
1192 Valid values are nil, t, `head', `last', an integer or a predicate.
1193 See Info node `(gnus)Customizing Articles' and Info node
1194 `(gnus)X-Face' for details."
1195   :group 'gnus-article-treat
1196   ;;:version "21.1"
1197   :link '(custom-manual "(gnus)Customizing Articles")
1198   :link '(custom-manual "(gnus)X-Face")
1199   :type gnus-article-treat-head-custom)
1200 (put 'gnus-treat-display-xface 'highlight t)
1201
1202 (defcustom gnus-article-should-use-smiley-mule
1203   (not (or (featurep 'xemacs)
1204            (gnus-image-type-available-p 'xpm)
1205            (gnus-image-type-available-p 'pbm)))
1206   "If non-nil, gnus uses `smiley-mule' for displaying smileys rather than
1207 `smiley'.  It defaults to t when Emacs 20 or earlier is running.
1208 `smiley-mule' is boundled in BITMAP-MULE package.  You can set it to t
1209 even if you are using Emacs 21+.  It has no effect on XEmacs."
1210   :group 'gnus-article-various
1211   :type 'boolean
1212   :get (lambda (symbol)
1213          (and (default-value symbol)
1214               (not (featurep 'xemacs))
1215               (module-installed-p 'smiley-mule)
1216               t))
1217   :set (lambda (symbol value)
1218          (set-default symbol (and value
1219                                   (not (featurep 'xemacs))
1220                                   (module-installed-p 'smiley-mule)
1221                                   t))))
1222
1223 (defvar gnus-article-smiley-mule-loaded-p nil
1224   "Internal variable used to say whether `smiley-mule' is loaded (whether
1225 smiley functions are not overridden by `smiley').")
1226
1227 (defcustom gnus-treat-display-face
1228   (and (not noninteractive)
1229        (or (and (fboundp 'image-type-available-p)
1230                 (image-type-available-p 'png))
1231            (and (featurep 'xemacs)
1232                 (featurep 'png)))
1233        'head)
1234   "Display Face headers.
1235 Valid values are nil, t, `head', `last', an integer or a predicate.
1236 See Info node `(gnus)Customizing Articles' and Info node
1237 `(gnus)X-Face' for details."
1238   :group 'gnus-article-treat
1239   :version "21.1"
1240   :link '(custom-manual "(gnus)Customizing Articles")
1241   :link '(custom-manual "(gnus)X-Face")
1242   :type gnus-article-treat-head-custom)
1243 (put 'gnus-treat-display-xface 'highlight t)
1244
1245 (defcustom gnus-treat-display-grey-xface
1246   (and (not noninteractive)
1247        (or (featurep 'xemacs)
1248            (and (fboundp 'display-images-p)
1249                 (display-images-p)))
1250        (string-match "^0x" (shell-command-to-string "uncompface"))
1251        t)
1252   "Display grey X-Face headers.
1253 Valid values are nil, t."
1254   :group 'gnus-article-treat
1255   :version "21.3"
1256   :type 'boolean)
1257 (put 'gnus-treat-display-grey-xface 'highlight t)
1258
1259 (defcustom gnus-treat-display-smileys
1260   (if (or (and (featurep 'xemacs)
1261                (featurep 'xpm))
1262           (gnus-image-type-available-p 'xpm)
1263           (gnus-image-type-available-p 'pbm)
1264           (and (not (featurep 'xemacs))
1265                window-system
1266                (module-installed-p 'smiley-mule)))
1267       t
1268     nil)
1269   "Display smileys.
1270 Valid values are nil, t, `head', `last', an integer or a predicate.
1271 See Info node `(gnus)Customizing Articles' and Info node
1272 `(gnus)Smileys' for details."
1273   :group 'gnus-article-treat
1274   ;;:version "21.1"
1275   :link '(custom-manual "(gnus)Customizing Articles")
1276   :link '(custom-manual "(gnus)Smileys")
1277   :type gnus-article-treat-custom)
1278 (put 'gnus-treat-display-smileys 'highlight t)
1279
1280 (defcustom gnus-treat-from-picon
1281   (if (and (gnus-image-type-available-p 'xpm)
1282            (gnus-picons-installed-p))
1283       'head nil)
1284   "Display picons in the From header.
1285 Valid values are nil, t, `head', `last', an integer or a predicate.
1286 See Info node `(gnus)Customizing Articles' and Info node
1287 `(gnus)Picons' for details."
1288   :group 'gnus-article-treat
1289   :group 'gnus-picon
1290   :link '(custom-manual "(gnus)Customizing Articles")
1291   :link '(custom-manual "(gnus)Picons")
1292   :type gnus-article-treat-head-custom)
1293 (put 'gnus-treat-from-picon 'highlight t)
1294
1295 (defcustom gnus-treat-mail-picon
1296   (if (and (gnus-image-type-available-p 'xpm)
1297            (gnus-picons-installed-p))
1298       'head nil)
1299   "Display picons in To and Cc headers.
1300 Valid values are nil, t, `head', `last', an integer or a predicate.
1301 See Info node `(gnus)Customizing Articles' and Info node
1302 `(gnus)Picons' for details."
1303   :group 'gnus-article-treat
1304   :group 'gnus-picon
1305   :link '(custom-manual "(gnus)Customizing Articles")
1306   :link '(custom-manual "(gnus)Picons")
1307   :type gnus-article-treat-head-custom)
1308 (put 'gnus-treat-mail-picon 'highlight t)
1309
1310 (defcustom gnus-treat-newsgroups-picon
1311   (if (and (gnus-image-type-available-p 'xpm)
1312            (gnus-picons-installed-p))
1313       'head nil)
1314   "Display picons in the Newsgroups and Followup-To headers.
1315 Valid values are nil, t, `head', `last', an integer or a predicate.
1316 See Info node `(gnus)Customizing Articles' and Info node
1317 `(gnus)Picons' for details."
1318   :group 'gnus-article-treat
1319   :group 'gnus-picon
1320   :link '(custom-manual "(gnus)Customizing Articles")
1321   :link '(custom-manual "(gnus)Picons")
1322   :type gnus-article-treat-head-custom)
1323 (put 'gnus-treat-newsgroups-picon 'highlight t)
1324
1325 (defcustom gnus-treat-body-boundary
1326   (if (or gnus-treat-newsgroups-picon
1327           gnus-treat-mail-picon
1328           gnus-treat-from-picon)
1329       'head nil)
1330   "Draw a boundary at the end of the headers.
1331 Valid values are nil, t, `head', `last', an integer or a predicate.
1332 See Info node `(gnus)Customizing Articles' for details."
1333   :version "21.1"
1334   :group 'gnus-article-treat
1335   :link '(custom-manual "(gnus)Customizing Articles")
1336   :type gnus-article-treat-custom)
1337
1338 (defcustom gnus-treat-capitalize-sentences nil
1339   "Capitalize sentence-starting words.
1340 Valid values are nil, t, `head', `last', an integer or a predicate.
1341 See Info node `(gnus)Customizing Articles' for details."
1342   :version "21.1"
1343   :group 'gnus-article-treat
1344   :link '(custom-manual "(gnus)Customizing Articles")
1345   :type gnus-article-treat-custom)
1346
1347 (defcustom gnus-treat-wash-html nil
1348   "Format as HTML.
1349 Valid values are nil, t, `head', `last', an integer or a predicate.
1350 See Info node `(gnus)Customizing Articles' for details."
1351   :group 'gnus-article-treat
1352   :link '(custom-manual "(gnus)Customizing Articles")
1353   :type gnus-article-treat-custom)
1354
1355 (defcustom gnus-treat-fill-long-lines nil
1356   "Fill long lines.
1357 Valid values are nil, t, `head', `last', an integer or a predicate.
1358 See Info node `(gnus)Customizing Articles' for details."
1359   :group 'gnus-article-treat
1360   :link '(custom-manual "(gnus)Customizing Articles")
1361   :type gnus-article-treat-custom)
1362
1363 (defcustom gnus-treat-play-sounds nil
1364   "Play sounds.
1365 Valid values are nil, t, `head', `last', an integer or a predicate.
1366 See Info node `(gnus)Customizing Articles' for details."
1367   :version "21.1"
1368   :group 'gnus-article-treat
1369   :link '(custom-manual "(gnus)Customizing Articles")
1370   :type gnus-article-treat-custom)
1371
1372 (defcustom gnus-treat-decode-article-as-default-mime-charset nil
1373   "Decode an article as `default-mime-charset'.  For instance, if you want to
1374 attempt to decode an article even if the value of `gnus-show-mime' is nil,
1375 you could set this variable to something like: nil for don't decode, t for
1376 decode the body, '(or header t) for the whole article, etc."
1377   :group 'gnus-article-treat
1378   :type '(radio (const :tag "Off" nil)
1379                 (const :tag "Decode body" t)
1380                 (const :tag "Decode all" (or head t))))
1381
1382 (defcustom gnus-treat-translate nil
1383   "Translate articles from one language to another.
1384 Valid values are nil, t, `head', `last', an integer or a predicate.
1385 See Info node `(gnus)Customizing Articles' for details."
1386   :version "21.1"
1387   :group 'gnus-article-treat
1388   :link '(custom-manual "(gnus)Customizing Articles")
1389   :type gnus-article-treat-custom)
1390
1391 (defcustom gnus-treat-x-pgp-sig nil
1392   "Verify X-PGP-Sig.
1393 To automatically treat X-PGP-Sig, set it to head.
1394 Valid values are nil, t, `head', `last', an integer or a predicate.
1395 See Info node `(gnus)Customizing Articles' for details."
1396   :group 'gnus-article-treat
1397   :group 'mime-security
1398   :type gnus-article-treat-custom)
1399
1400 (defcustom gnus-treat-monafy nil
1401   "Display body part with mona font.
1402 Valid values are nil, t, `head', `last', an integer or a predicate.
1403 See Info node `(gnus)Customizing Articles' for details."
1404   :group 'gnus-article-treat
1405   :group 'mime-security
1406   :link '(custom-manual "(gnus)Customizing Articles")
1407   :type gnus-article-treat-custom)
1408
1409 (defvar gnus-article-encrypt-protocol-alist
1410   '(("PGP" . mml2015-self-encrypt)))
1411
1412 ;; Set to nil if more than one protocol added to
1413 ;; gnus-article-encrypt-protocol-alist.
1414 (defcustom gnus-article-encrypt-protocol "PGP"
1415   "The protocol used for encrypt articles.
1416 It is a string, such as \"PGP\". If nil, ask user."
1417   :type 'string
1418   :group 'mime-security)
1419
1420 (defvar gnus-article-wash-function nil
1421   "Function used for converting HTML into text.")
1422
1423 ;;; Internal variables
1424
1425 (defvar gnus-english-month-names
1426   '("January" "February" "March" "April" "May" "June" "July" "August"
1427     "September" "October" "November" "December"))
1428
1429 (defvar article-goto-body-goes-to-point-min-p nil)
1430 (defvar gnus-article-wash-types nil)
1431 (defvar gnus-article-emphasis-alist nil)
1432 (defvar gnus-article-image-alist nil)
1433
1434 (defvar gnus-article-mime-handle-alist-1 nil)
1435 (defvar gnus-treatment-function-alist
1436   '((gnus-treat-decode-article-as-default-mime-charset
1437      gnus-article-decode-article-as-default-mime-charset)
1438     (gnus-treat-x-pgp-sig gnus-article-verify-x-pgp-sig)
1439     (gnus-treat-monafy gnus-article-monafy)
1440     (gnus-treat-strip-banner gnus-article-strip-banner)
1441     (gnus-treat-strip-headers-in-body gnus-article-strip-headers-in-body)
1442     (gnus-treat-buttonize gnus-article-add-buttons)
1443     (gnus-treat-fill-article gnus-article-fill-cited-article)
1444     (gnus-treat-fill-long-lines gnus-article-fill-long-lines)
1445     (gnus-treat-strip-cr gnus-article-remove-cr)
1446     (gnus-treat-unsplit-urls gnus-article-unsplit-urls)
1447     (gnus-treat-date-ut gnus-article-date-ut)
1448     (gnus-treat-date-local gnus-article-date-local)
1449     (gnus-treat-date-english gnus-article-date-english)
1450     (gnus-treat-date-lapsed gnus-article-date-lapsed)
1451     (gnus-treat-date-original gnus-article-date-original)
1452     (gnus-treat-date-user-defined gnus-article-date-user)
1453     (gnus-treat-date-iso8601 gnus-article-date-iso8601)
1454     (gnus-treat-display-face gnus-article-display-face)
1455     (gnus-treat-hide-headers gnus-article-maybe-hide-headers)
1456     (gnus-treat-hide-boring-headers gnus-article-hide-boring-headers)
1457     (gnus-treat-hide-signature gnus-article-hide-signature)
1458     (gnus-treat-strip-list-identifiers gnus-article-hide-list-identifiers)
1459     (gnus-treat-leading-whitespace gnus-article-remove-leading-whitespace)
1460     (gnus-treat-strip-pgp gnus-article-hide-pgp)
1461     (gnus-treat-strip-pem gnus-article-hide-pem)
1462     (gnus-treat-from-picon gnus-treat-from-picon)
1463     (gnus-treat-mail-picon gnus-treat-mail-picon)
1464     (gnus-treat-newsgroups-picon gnus-treat-newsgroups-picon)
1465     (gnus-treat-highlight-headers gnus-article-highlight-headers)
1466     (gnus-treat-highlight-signature gnus-article-highlight-signature)
1467     (gnus-treat-strip-trailing-blank-lines
1468      gnus-article-remove-trailing-blank-lines)
1469     (gnus-treat-strip-leading-blank-lines
1470      gnus-article-strip-leading-blank-lines)
1471     (gnus-treat-strip-multiple-blank-lines
1472      gnus-article-strip-multiple-blank-lines)
1473     (gnus-treat-overstrike gnus-article-treat-overstrike)
1474     (gnus-treat-unfold-headers gnus-article-treat-unfold-headers)
1475     (gnus-treat-fold-headers gnus-article-treat-fold-headers)
1476     ;; Displaying X-Face should be done after unfolding headers
1477     ;; to protect bitmap lines.
1478     (gnus-treat-display-xface gnus-article-display-x-face)
1479     (gnus-treat-fold-newsgroups gnus-article-treat-fold-newsgroups)
1480     (gnus-treat-buttonize-head gnus-article-add-buttons-to-head)
1481     (gnus-treat-display-smileys gnus-treat-smiley)
1482     (gnus-treat-capitalize-sentences gnus-article-capitalize-sentences)
1483     (gnus-treat-wash-html gnus-article-wash-html)
1484     (gnus-treat-emphasize gnus-article-emphasize)
1485     (gnus-treat-hide-citation gnus-article-hide-citation)
1486     (gnus-treat-hide-citation-maybe gnus-article-hide-citation-maybe)
1487     (gnus-treat-highlight-citation gnus-article-highlight-citation)
1488     (gnus-treat-body-boundary gnus-article-treat-body-boundary)
1489     (gnus-treat-play-sounds gnus-earcon-display)))
1490
1491 (defvar gnus-article-mime-handle-alist nil)
1492 (defvar article-lapsed-timer nil)
1493 (defvar gnus-article-current-summary nil)
1494
1495 (defvar gnus-article-mode-syntax-table
1496   (let ((table (copy-syntax-table text-mode-syntax-table)))
1497     ;; This causes the citation match run O(2^n).
1498     ;; (modify-syntax-entry ?- "w" table)
1499     (modify-syntax-entry ?> ")<" table)
1500     (modify-syntax-entry ?< "(>" table)
1501     ;; make M-. in article buffers work for `foo' strings
1502     (modify-syntax-entry ?' " " table)
1503     (modify-syntax-entry ?` " " table)
1504     table)
1505   "Syntax table used in article mode buffers.
1506 Initialized from `text-mode-syntax-table.")
1507
1508 (defvar gnus-save-article-buffer nil)
1509
1510 (defvar gnus-article-mode-line-format-alist
1511   (nconc '((?w (gnus-article-wash-status) ?s)
1512            (?m (gnus-article-mime-part-status) ?s))
1513          gnus-summary-mode-line-format-alist))
1514
1515 (defvar gnus-number-of-articles-to-be-saved nil)
1516
1517 (defvar gnus-inhibit-hiding nil)
1518
1519 ;;; Macros for dealing with the article buffer.
1520
1521 (defmacro gnus-with-article-headers (&rest forms)
1522   `(save-excursion
1523      (set-buffer gnus-article-buffer)
1524      (save-restriction
1525        (let ((buffer-read-only nil)
1526              (inhibit-point-motion-hooks t)
1527              (case-fold-search t))
1528          (article-narrow-to-head)
1529          ,@forms))))
1530
1531 (put 'gnus-with-article-headers 'lisp-indent-function 0)
1532 (put 'gnus-with-article-headers 'edebug-form-spec '(body))
1533
1534 (defmacro gnus-with-article-buffer (&rest forms)
1535   `(save-excursion
1536      (set-buffer gnus-article-buffer)
1537      (let ((buffer-read-only nil))
1538        ,@forms)))
1539
1540 (put 'gnus-with-article-buffer 'lisp-indent-function 0)
1541 (put 'gnus-with-article-buffer 'edebug-form-spec '(body))
1542
1543 (defun gnus-article-goto-header (header)
1544   "Go to HEADER, which is a regular expression."
1545   (re-search-forward (concat "^\\(" header "\\):") nil t))
1546
1547 (defsubst gnus-article-hide-text (b e props)
1548   "Set text PROPS on the B to E region, extending `intangible' 1 past B."
1549   (gnus-add-text-properties-when 'article-type nil b e props)
1550   (when (memq 'intangible props)
1551     (put-text-property
1552      (max (1- b) (point-min))
1553      b 'intangible (cddr (memq 'intangible props)))))
1554
1555 (defsubst gnus-article-unhide-text (b e)
1556   "Remove hidden text properties from region between B and E."
1557   (remove-text-properties b e gnus-hidden-properties)
1558   (when (memq 'intangible gnus-hidden-properties)
1559     (put-text-property (max (1- b) (point-min))
1560                        b 'intangible nil)))
1561
1562 (defun gnus-article-hide-text-type (b e type)
1563   "Hide text of TYPE between B and E."
1564   (gnus-add-wash-type type)
1565   (gnus-article-hide-text
1566    b e (cons 'article-type (cons type gnus-hidden-properties))))
1567
1568 (defun gnus-article-unhide-text-type (b e type)
1569   "Unhide text of TYPE between B and E."
1570   (gnus-delete-wash-type type)
1571   (remove-text-properties
1572    b e (cons 'article-type (cons type gnus-hidden-properties)))
1573   (when (memq 'intangible gnus-hidden-properties)
1574     (put-text-property (max (1- b) (point-min))
1575                        b 'intangible nil)))
1576
1577 (defun gnus-article-hide-text-of-type (type)
1578   "Hide text of TYPE in the current buffer."
1579   (save-excursion
1580     (let ((b (point-min))
1581           (e (point-max)))
1582       (while (setq b (text-property-any b e 'article-type type))
1583         (add-text-properties b (incf b) gnus-hidden-properties)))))
1584
1585 (defun gnus-article-delete-text-of-type (type)
1586   "Delete text of TYPE in the current buffer."
1587   (save-excursion
1588     (let ((b (point-min)))
1589       (while (setq b (text-property-any b (point-max) 'article-type type))
1590         (delete-region
1591          b (or (text-property-not-all b (point-max) 'article-type type)
1592                (point-max)))))))
1593
1594 (defun gnus-article-delete-invisible-text ()
1595   "Delete all invisible text in the current buffer."
1596   (save-excursion
1597     (let ((b (point-min)))
1598       (while (setq b (text-property-any b (point-max) 'invisible t))
1599         (delete-region
1600          b (or (text-property-not-all b (point-max) 'invisible t)
1601                (point-max)))))))
1602
1603 (defun gnus-article-text-type-exists-p (type)
1604   "Say whether any text of type TYPE exists in the buffer."
1605   (text-property-any (point-min) (point-max) 'article-type type))
1606
1607 (defsubst gnus-article-header-rank ()
1608   "Give the rank of the string HEADER as given by `gnus-sorted-header-list'."
1609   (let ((list gnus-sorted-header-list)
1610         (i 1))
1611     (while list
1612       (if (looking-at (car list))
1613           (setq list nil)
1614         (setq list (cdr list))
1615         (incf i)))
1616       i))
1617
1618 (defun article-hide-headers (&optional arg delete)
1619   "Hide unwanted headers and possibly sort them as well."
1620   (interactive (gnus-article-hidden-arg))
1621   ;; Lars said that this function might be inhibited.
1622   (if (gnus-article-check-hidden-text 'headers arg)
1623       (progn
1624         ;; Show boring headers as well.
1625         (gnus-article-show-hidden-text 'boring-headers)
1626         (when (eq 1 (point-min))
1627           (set-window-start (get-buffer-window (current-buffer)) 1)))
1628     (unless gnus-inhibit-hiding
1629       (save-excursion
1630         (save-restriction
1631           (let ((inhibit-read-only t)
1632                 (case-fold-search t)
1633                 (max (1+ (length gnus-sorted-header-list)))
1634                 (ignored (when (not gnus-visible-headers)
1635                            (cond ((stringp gnus-ignored-headers)
1636                                   gnus-ignored-headers)
1637                                  ((listp gnus-ignored-headers)
1638                                   (mapconcat 'identity gnus-ignored-headers
1639                                              "\\|")))))
1640                 (visible
1641                  (cond ((stringp gnus-visible-headers)
1642                         gnus-visible-headers)
1643                        ((and gnus-visible-headers
1644                              (listp gnus-visible-headers))
1645                         (mapconcat 'identity gnus-visible-headers "\\|"))))
1646                 (inhibit-point-motion-hooks t)
1647                 beg)
1648             ;; First we narrow to just the headers.
1649             (article-narrow-to-head)
1650             ;; Hide any "From " lines at the beginning of (mail) articles.
1651             (while (looking-at "From ")
1652               (forward-line 1))
1653             (unless (bobp)
1654               (if delete
1655                   (delete-region (point-min) (point))
1656                 (gnus-article-hide-text (point-min) (point)
1657                                         (nconc (list 'article-type 'headers)
1658                                                gnus-hidden-properties))))
1659             ;; Then treat the rest of the header lines.
1660             ;; Then we use the two regular expressions
1661             ;; `gnus-ignored-headers' and `gnus-visible-headers' to
1662             ;; select which header lines is to remain visible in the
1663             ;; article buffer.
1664             (while (re-search-forward "^[^ \t:]*:" nil t)
1665               (beginning-of-line)
1666               ;; Mark the rank of the header.
1667               (put-text-property
1668                (point) (1+ (point)) 'message-rank
1669                (if (or (and visible (looking-at visible))
1670                        (and ignored
1671                             (not (looking-at ignored))))
1672                    (gnus-article-header-rank)
1673                  (+ 2 max)))
1674               (forward-line 1))
1675             (message-sort-headers-1)
1676             (when (setq beg (text-property-any
1677                              (point-min) (point-max) 'message-rank (+ 2 max)))
1678               ;; We delete or make invisible the unwanted headers.
1679               (gnus-add-wash-type 'headers)
1680               (if delete
1681                   (progn
1682                     (add-text-properties
1683                      (point-min) (+ 5 (point-min))
1684                      '(article-type headers dummy-invisible t))
1685                     (delete-region beg (point-max)))
1686                 (gnus-article-hide-text-type beg (point-max) 'headers)))))))))
1687
1688 (defun article-hide-boring-headers (&optional arg)
1689   "Toggle hiding of headers that aren't very interesting.
1690 If given a negative prefix, always show; if given a positive prefix,
1691 always hide."
1692   (interactive (gnus-article-hidden-arg))
1693   (when (and (not (gnus-article-check-hidden-text 'boring-headers arg))
1694              (not gnus-show-all-headers))
1695     (save-excursion
1696       (save-restriction
1697         (let ((buffer-read-only nil)
1698               (list gnus-boring-article-headers)
1699               (inhibit-point-motion-hooks t)
1700               elem)
1701           (article-narrow-to-head)
1702           (while list
1703             (setq elem (pop list))
1704             (goto-char (point-min))
1705             (cond
1706              ;; Hide empty headers.
1707              ((eq elem 'empty)
1708               (while (re-search-forward "^[^: \t]+:[ \t]*\n[^ \t]" nil t)
1709                 (forward-line -1)
1710                 (gnus-article-hide-text-type
1711                  (progn (beginning-of-line) (point))
1712                  (progn
1713                    (end-of-line)
1714                    (if (re-search-forward "^[^ \t]" nil t)
1715                        (match-beginning 0)
1716                      (point-max)))
1717                  'boring-headers)))
1718              ;; Hide boring Newsgroups header.
1719              ((eq elem 'newsgroups)
1720               (when (gnus-string-equal
1721                      (gnus-fetch-field "newsgroups")
1722                      (gnus-group-real-name
1723                       (if (boundp 'gnus-newsgroup-name)
1724                           gnus-newsgroup-name
1725                         "")))
1726                 (gnus-article-hide-header "newsgroups")))
1727              ((eq elem 'to-address)
1728               (let ((to (message-fetch-field "to"))
1729                     (to-address
1730                      (gnus-parameter-to-address
1731                       (if (boundp 'gnus-newsgroup-name)
1732                           gnus-newsgroup-name ""))))
1733                 (when (and to to-address
1734                            (ignore-errors
1735                              (gnus-string-equal
1736                               ;; only one address in To
1737                               (nth 1 (mail-extract-address-components to))
1738                               to-address)))
1739                   (gnus-article-hide-header "to"))))
1740              ((eq elem 'followup-to)
1741               (when (gnus-string-equal
1742                      (message-fetch-field "followup-to")
1743                      (message-fetch-field "newsgroups"))
1744                 (gnus-article-hide-header "followup-to")))
1745              ((eq elem 'reply-to)
1746               (let ((from (message-fetch-field "from"))
1747                     (reply-to (message-fetch-field "reply-to")))
1748                 (when (and
1749                        from reply-to
1750                        (ignore-errors
1751                          (gnus-string-equal
1752                           (nth 1 (mail-extract-address-components from))
1753                           (nth 1 (mail-extract-address-components reply-to)))))
1754                   (gnus-article-hide-header "reply-to"))))
1755              ((eq elem 'date)
1756               (let ((date (message-fetch-field "date")))
1757                 (when (and date
1758                            (< (days-between (current-time-string) date)
1759                               4))
1760                   (gnus-article-hide-header "date"))))
1761              ((eq elem 'long-to)
1762               (let ((to (message-fetch-field "to"))
1763                     (cc (message-fetch-field "cc")))
1764                 (when (> (length to) 1024)
1765                   (gnus-article-hide-header "to"))
1766                 (when (> (length cc) 1024)
1767                   (gnus-article-hide-header "cc"))))
1768              ((eq elem 'many-to)
1769               (let ((to-count 0)
1770                     (cc-count 0))
1771                 (goto-char (point-min))
1772                 (while (re-search-forward "^to:" nil t)
1773                   (setq to-count (1+ to-count)))
1774                 (when (> to-count 1)
1775                   (while (> to-count 0)
1776                     (goto-char (point-min))
1777                     (save-restriction
1778                       (re-search-forward "^to:" nil nil to-count)
1779                       (forward-line -1)
1780                       (narrow-to-region (point) (point-max))
1781                       (gnus-article-hide-header "to"))
1782                     (setq to-count (1- to-count))))
1783                 (goto-char (point-min))
1784                 (while (re-search-forward "^cc:" nil t)
1785                   (setq cc-count (1+ cc-count)))
1786                 (when (> cc-count 1)
1787                   (while (> cc-count 0)
1788                     (goto-char (point-min))
1789                     (save-restriction
1790                       (re-search-forward "^cc:" nil nil cc-count)
1791                       (forward-line -1)
1792                       (narrow-to-region (point) (point-max))
1793                       (gnus-article-hide-header "cc"))
1794                     (setq cc-count (1- cc-count)))))))))))))
1795
1796 (defun gnus-article-hide-header (header)
1797   (save-excursion
1798     (goto-char (point-min))
1799     (when (re-search-forward (concat "^" header ":") nil t)
1800       (gnus-article-hide-text-type
1801        (progn (beginning-of-line) (point))
1802        (progn
1803          (end-of-line)
1804          (if (re-search-forward "^[^ \t]" nil t)
1805              (match-beginning 0)
1806            (point-max)))
1807        'boring-headers))))
1808
1809 (defvar gnus-article-normalized-header-length 40
1810   "Length of normalized headers.")
1811
1812 (defun article-normalize-headers ()
1813   "Make all header lines 40 characters long."
1814   (interactive)
1815   (let ((buffer-read-only nil)
1816         column)
1817     (save-excursion
1818       (save-restriction
1819         (article-narrow-to-head)
1820         (while (not (eobp))
1821           (cond
1822            ((< (setq column (- (gnus-point-at-eol) (point)))
1823                gnus-article-normalized-header-length)
1824             (end-of-line)
1825             (insert (make-string
1826                      (- gnus-article-normalized-header-length column)
1827                      ? )))
1828            ((> column gnus-article-normalized-header-length)
1829             (gnus-put-text-property
1830              (progn
1831                (forward-char gnus-article-normalized-header-length)
1832                (point))
1833              (gnus-point-at-eol)
1834              'invisible t))
1835            (t
1836             ;; Do nothing.
1837             ))
1838           (forward-line 1))))))
1839
1840 (defun article-treat-dumbquotes ()
1841   "Translate M****s*** sm*rtq**t*s into proper text.
1842 Note that this function guesses whether a character is a sm*rtq**t* or
1843 not, so it should only be used interactively.
1844
1845 Sm*rtq**t*s are M****s***'s unilateral extension to the character map
1846 in an attempt to provide more quoting characters.  If you see
1847 something like \\222 or \\264 where you're expecting some kind of
1848 apostrophe or quotation mark, then try this wash."
1849   (interactive)
1850   (article-translate-strings gnus-article-dumbquotes-map))
1851
1852 (defun article-translate-characters (from to)
1853   "Translate all characters in the body of the article according to FROM and TO.
1854 FROM is a string of characters to translate from; to is a string of
1855 characters to translate to."
1856   (save-excursion
1857     (when (article-goto-body)
1858       (let ((buffer-read-only nil)
1859             (x (make-string 225 ?x))
1860             (i -1))
1861         (while (< (incf i) (length x))
1862           (aset x i i))
1863         (setq i 0)
1864         (while (< i (length from))
1865           (aset x (aref from i) (aref to i))
1866           (incf i))
1867         (translate-region (point) (point-max) x)))))
1868
1869 (defun article-translate-strings (map)
1870   "Translate all string in the body of the article according to MAP.
1871 MAP is an alist where the elements are on the form (\"from\" \"to\")."
1872   (save-excursion
1873     (when (article-goto-body)
1874       (let ((buffer-read-only nil)
1875             elem)
1876         (while (setq elem (pop map))
1877           (save-excursion
1878             (while (search-forward (car elem) nil t)
1879               (replace-match (cadr elem)))))))))
1880
1881 (defun article-treat-overstrike ()
1882   "Translate overstrikes into bold text."
1883   (interactive)
1884   (save-excursion
1885     (when (article-goto-body)
1886       (let ((buffer-read-only nil))
1887         (while (search-forward "\b" nil t)
1888           (let ((next (char-after))
1889                 start end previous)
1890             (backward-char 2)
1891             (setq start (point)
1892                   previous (char-after))
1893             (forward-char 3)
1894             (setq end (point))
1895             (backward-char)
1896             ;; We do the boldification/underlining by hiding the
1897             ;; overstrikes and putting the proper text property
1898             ;; on the letters.
1899             (cond
1900              ((eq next previous)
1901               (gnus-article-hide-text-type start (point) 'overstrike)
1902               (put-text-property (point) end 'face 'bold))
1903              ((eq next ?_)
1904               (gnus-article-hide-text-type
1905                (1- (point)) (1+ (point)) 'overstrike)
1906               (put-text-property
1907                start (1- (point)) 'face 'underline))
1908              ((eq previous ?_)
1909               (gnus-article-hide-text-type start (point) 'overstrike)
1910               (put-text-property
1911                (point) end 'face 'underline)))))))))
1912
1913 (defun gnus-article-treat-unfold-headers ()
1914   "Unfold folded message headers.
1915 Only the headers that fit into the current window width will be
1916 unfolded."
1917   (interactive)
1918   (gnus-with-article-headers
1919     (let (length)
1920       (while (not (eobp))
1921         (save-restriction
1922           (mail-header-narrow-to-field)
1923           (let ((header (buffer-substring (point-min) (point-max))))
1924             (with-temp-buffer
1925               (insert header)
1926               (goto-char (point-min))
1927               (while (re-search-forward "\n[\t ]" nil t)
1928                 (replace-match " " t t)))
1929             (setq length (- (point-max) (point-min) 1)))
1930           (when (< length (window-width))
1931             (while (re-search-forward "\n[\t ]" nil t)
1932               (replace-match " " t t)))
1933           (goto-char (point-max)))))))
1934
1935 (defun gnus-article-treat-fold-headers ()
1936   "Fold message headers."
1937   (interactive)
1938   (gnus-with-article-headers
1939     (while (not (eobp))
1940       (save-restriction
1941         (mail-header-narrow-to-field)
1942         (mail-header-fold-field)
1943         (goto-char (point-max))))))
1944
1945 (defun gnus-treat-smiley ()
1946   "Toggle display of textual emoticons (\"smileys\") as small graphical icons."
1947   (interactive)
1948   (unless (featurep 'xemacs)
1949     (when (and (>= emacs-major-version 21)
1950                (not gnus-article-should-use-smiley-mule)
1951                gnus-article-smiley-mule-loaded-p)
1952       (load "smiley" nil t)
1953       (setq gnus-article-smiley-mule-loaded-p nil))
1954     (when (and gnus-article-should-use-smiley-mule
1955                (not gnus-article-smiley-mule-loaded-p))
1956       (load "smiley-mule" nil t)
1957       (setq gnus-article-smiley-mule-loaded-p t)))
1958   (gnus-with-article-buffer
1959     (if (memq 'smiley gnus-article-wash-types)
1960         (gnus-delete-images 'smiley)
1961       (article-goto-body)
1962       (let ((images (smiley-region (point) (point-max))))
1963         (when images
1964           (gnus-add-wash-type 'smiley)
1965           (dolist (image images)
1966             (gnus-add-image 'smiley image)))))))
1967
1968 (defun gnus-article-remove-images ()
1969   "Remove all images from the article buffer."
1970   (interactive)
1971   (gnus-with-article-buffer
1972     (dolist (elem gnus-article-image-alist)
1973       (gnus-delete-images (car elem)))))
1974
1975 (defun gnus-article-treat-fold-newsgroups ()
1976   "Unfold folded message headers.
1977 Only the headers that fit into the current window width will be
1978 unfolded."
1979   (interactive)
1980   (gnus-with-article-headers
1981     (while (gnus-article-goto-header "newsgroups\\|followup-to")
1982       (save-restriction
1983         (mail-header-narrow-to-field)
1984         (while (re-search-forward ", *" nil t)
1985           (replace-match ", " t t))
1986         (mail-header-fold-field)
1987         (goto-char (point-max))))))
1988
1989 (defun gnus-article-treat-body-boundary ()
1990   "Place a boundary line at the end of the headers."
1991   (interactive)
1992   (when (and gnus-body-boundary-delimiter
1993              (> (length gnus-body-boundary-delimiter) 0))
1994     (gnus-with-article-headers
1995       (goto-char (point-max))
1996       (let ((start (point)))
1997         (insert "X-Boundary: ")
1998         (gnus-add-text-properties start (point) '(invisible t intangible t))
1999         (insert (let (str)
2000                   (while (>= (1- (window-width)) (length str))
2001                     (setq str (concat str gnus-body-boundary-delimiter)))
2002                   (substring str 0 (1- (window-width))))
2003                 "\n")
2004         (gnus-put-text-property start (point) 'gnus-decoration 'header)))))
2005
2006 (defun article-fill-long-lines ()
2007   "Fill lines that are wider than the window width."
2008   (interactive)
2009   (save-excursion
2010     (let ((buffer-read-only nil)
2011           (width (window-width (get-buffer-window (current-buffer)))))
2012       (save-restriction
2013         (article-goto-body)
2014         (let ((adaptive-fill-mode nil)) ;Why?  -sm
2015           (while (not (eobp))
2016             (end-of-line)
2017             (when (>= (current-column) (min fill-column width))
2018               (narrow-to-region (min (1+ (point)) (point-max))
2019                                 (gnus-point-at-bol))
2020               (let ((goback (point-marker)))
2021                 (fill-paragraph nil)
2022                 (goto-char (marker-position goback)))
2023               (widen))
2024             (forward-line 1)))))))
2025
2026 (defun article-capitalize-sentences ()
2027   "Capitalize the first word in each sentence."
2028   (interactive)
2029   (save-excursion
2030     (let ((buffer-read-only nil)
2031           (paragraph-start "^[\n\^L]"))
2032       (article-goto-body)
2033       (while (not (eobp))
2034         (capitalize-word 1)
2035         (forward-sentence)))))
2036
2037 (defun article-remove-cr ()
2038   "Remove trailing CRs and then translate remaining CRs into LFs."
2039   (interactive)
2040   (save-excursion
2041     (let ((buffer-read-only nil))
2042       (goto-char (point-min))
2043       (while (re-search-forward "\r+$" nil t)
2044         (replace-match "" t t))
2045       (goto-char (point-min))
2046       (while (search-forward "\r" nil t)
2047         (replace-match "\n" t t)))))
2048
2049 (defun article-remove-trailing-blank-lines ()
2050   "Remove all trailing blank lines from the article."
2051   (interactive)
2052   (save-excursion
2053     (let ((buffer-read-only nil))
2054       (goto-char (point-max))
2055       (delete-region
2056        (point)
2057        (progn
2058          (while (and (not (bobp))
2059                      (looking-at "^[ \t]*$")
2060                      (not (gnus-annotation-in-region-p
2061                            (point) (gnus-point-at-eol))))
2062            (forward-line -1))
2063          (forward-line 1)
2064          (point))))))
2065
2066 (defun article-display-face ()
2067   "Display any Face headers in the header."
2068   (interactive)
2069   (gnus-with-article-headers
2070     (let ((face nil))
2071       (save-excursion
2072         (when (gnus-buffer-live-p gnus-original-article-buffer)
2073           (set-buffer gnus-original-article-buffer)
2074           (setq face (message-fetch-field "face"))))
2075       (when face
2076         (let ((png (gnus-convert-face-to-png face))
2077               image)
2078           (when png
2079             (setq image (gnus-create-image png 'png t))
2080             (gnus-article-goto-header "from")
2081             (when (bobp)
2082               (insert "From: [no `from' set]\n")
2083               (forward-char -17))
2084             (gnus-add-wash-type 'face)
2085             (gnus-add-image 'face image)
2086             (gnus-put-image image)))))))
2087
2088 (defun article-display-x-face (&optional force)
2089   "Look for an X-Face header and display it if present."
2090   (interactive (list 'force))
2091   (let ((wash-face-p buffer-read-only)) ;; When type `W f'
2092     (gnus-with-article-headers
2093       ;; Delete the old process, if any.
2094       (when (process-status "article-x-face")
2095         (delete-process "article-x-face"))
2096       (if (memq 'xface gnus-article-wash-types)
2097           ;; We have already displayed X-Faces, so we remove them
2098           ;; instead.
2099           (gnus-delete-images 'xface)
2100         ;; Display X-Faces.
2101         (let (x-faces from face grey)
2102           (save-excursion
2103             (when (and wash-face-p
2104                        (progn
2105                          (goto-char (point-min))
2106                          (not (re-search-forward
2107                                "^X-Face\\(-[0-9]+\\)?:[\t ]*" nil t)))
2108                        (gnus-buffer-live-p gnus-original-article-buffer))
2109               ;; If type `W f', use gnus-original-article-buffer,
2110               ;; otherwise use the current buffer because displaying
2111               ;; RFC822 parts calls this function too.
2112               (set-buffer gnus-original-article-buffer))
2113             (save-restriction
2114               (mail-narrow-to-head)
2115               (if gnus-treat-display-grey-xface
2116                   (progn
2117                     (while (gnus-article-goto-header "X-Face\\(-[0-9]+\\)?")
2118                       (if (match-beginning 2)
2119                           (progn
2120                             (setq grey t)
2121                             (push (cons (- (string-to-number (match-string 2)))
2122                                         (mail-header-field-value))
2123                                   x-faces))
2124                         (push (cons 0 (mail-header-field-value)) x-faces)))
2125                     (dolist (x-face (prog1
2126                                         (if grey
2127                                             (sort x-faces 'car-less-than-car)
2128                                           (nreverse x-faces))
2129                                       (setq x-faces nil)))
2130                       (push (cdr x-face) x-faces)))
2131                 (while (gnus-article-goto-header "X-Face")
2132                   (push (mail-header-field-value) x-faces)))
2133               (setq from (message-fetch-field "from"))))
2134           (if grey
2135               (let ((xpm (gnus-convert-gray-x-face-to-xpm x-faces))
2136                     image)
2137                 (when xpm
2138                   (setq image (gnus-create-image xpm 'xpm t))
2139                   (gnus-article-goto-header "from")
2140                   (when (bobp)
2141                     (insert "From: [no `from' set]\n")
2142                     (forward-char -17))
2143                   (gnus-add-wash-type 'xface)
2144                   (gnus-add-image 'xface image)
2145                   (gnus-put-image image)))
2146             ;; Sending multiple EOFs to xv doesn't work, so we only do a
2147             ;; single external face.
2148             (when (stringp gnus-article-x-face-command)
2149               (setq x-faces (list (car x-faces))))
2150             (while (and (setq face (pop x-faces))
2151                         gnus-article-x-face-command
2152                         (or force
2153                             ;; Check whether this face is censored.
2154                             (not gnus-article-x-face-too-ugly)
2155                             (and gnus-article-x-face-too-ugly from
2156                                  (not (string-match gnus-article-x-face-too-ugly
2157                                                     from)))))
2158               ;; We display the face.
2159               (if (symbolp gnus-article-x-face-command)
2160                   ;; The command is a lisp function, so we call it.
2161                   (if (gnus-functionp gnus-article-x-face-command)
2162                       (funcall gnus-article-x-face-command face)
2163                     (error "%s is not a function" gnus-article-x-face-command))
2164                 ;; The command is a string, so we interpret the command
2165                 ;; as a, well, command, and fork it off.
2166                 (let ((process-connection-type nil))
2167                   (process-kill-without-query
2168                    (start-process
2169                     "article-x-face" nil shell-file-name shell-command-switch
2170                     gnus-article-x-face-command))
2171                   (with-temp-buffer
2172                     (insert face)
2173                     (process-send-region "article-x-face"
2174                                          (point-min) (point-max)))
2175                   (process-send-eof "article-x-face"))))))))))
2176
2177 (defun article-decode-mime-words ()
2178   "Decode all MIME-encoded words in the article."
2179   (interactive)
2180   (save-excursion
2181     (set-buffer gnus-article-buffer)
2182     (let ((inhibit-point-motion-hooks t)
2183           buffer-read-only
2184           (mail-parse-charset gnus-newsgroup-charset)
2185           (mail-parse-ignored-charsets
2186            (save-excursion (set-buffer gnus-summary-buffer)
2187                            gnus-newsgroup-ignored-charsets)))
2188       (mail-decode-encoded-word-region (point-min) (point-max)))))
2189
2190 (defun article-decode-charset (&optional prompt)
2191   "Decode charset-encoded text in the article.
2192 If PROMPT (the prefix), prompt for a coding system to use."
2193   (interactive "P")
2194   (let ((inhibit-point-motion-hooks t) (case-fold-search t)
2195         buffer-read-only
2196         (mail-parse-charset gnus-newsgroup-charset)
2197         (mail-parse-ignored-charsets
2198          (save-excursion (condition-case nil
2199                              (set-buffer gnus-summary-buffer)
2200                            (error))
2201                          gnus-newsgroup-ignored-charsets))
2202         ct cte ctl charset format)
2203     (save-excursion
2204       (save-restriction
2205         (article-narrow-to-head)
2206         (setq ct (message-fetch-field "Content-Type" t)
2207               cte (message-fetch-field "Content-Transfer-Encoding" t)
2208               ctl (and ct (ignore-errors
2209                             (mail-header-parse-content-type ct)))
2210               charset (cond
2211                        (prompt
2212                         (mm-read-coding-system "Charset to decode: "))
2213                        (ctl
2214                         (mail-content-type-get ctl 'charset)))
2215               format (and ctl (mail-content-type-get ctl 'format)))
2216         (when cte
2217           (setq cte (mail-header-strip cte)))
2218         (if (and ctl (not (string-match "/" (car ctl))))
2219             (setq ctl nil))
2220         (goto-char (point-max)))
2221       (forward-line 1)
2222       (save-restriction
2223         (narrow-to-region (point) (point-max))
2224         (when (and (eq mail-parse-charset 'gnus-decoded)
2225                    (eq (mm-body-7-or-8) '8bit))
2226           ;; The text code could have been decoded.
2227           (setq charset mail-parse-charset))
2228         (when (and (or (not ctl)
2229                        (equal (car ctl) "text/plain"))
2230                    (not format)) ;; article with format will decode later.
2231           (mm-decode-body
2232            charset (and cte (intern (downcase
2233                                      (gnus-strip-whitespace cte))))
2234            (car ctl)))))))
2235
2236 (defun article-decode-encoded-words ()
2237   "Remove encoded-word encoding from headers."
2238   (let (buffer-read-only)
2239     (let ((charset (save-excursion
2240                      (set-buffer gnus-summary-buffer)
2241                      default-mime-charset)))
2242       (mime-decode-header-in-buffer charset))))
2243
2244 (defun article-decode-group-name ()
2245   "Decode group names in `Newsgroups:'."
2246   (let ((inhibit-point-motion-hooks t)
2247         buffer-read-only
2248         (method (gnus-find-method-for-group gnus-newsgroup-name)))
2249     (when (and (or gnus-group-name-charset-method-alist
2250                    gnus-group-name-charset-group-alist)
2251                (gnus-buffer-live-p gnus-original-article-buffer))
2252       (when (nnmail-fetch-field "Newsgroups")
2253         (nnheader-replace-header "Newsgroups"
2254                                  (gnus-decode-newsgroups
2255                                   (with-current-buffer
2256                                       gnus-original-article-buffer
2257                                     (nnmail-fetch-field "Newsgroups"))
2258                                   gnus-newsgroup-name method)))
2259       (when (nnmail-fetch-field "Followup-To")
2260         (nnheader-replace-header "Followup-To"
2261                                  (gnus-decode-newsgroups
2262                                   (with-current-buffer
2263                                       gnus-original-article-buffer
2264                                     (nnmail-fetch-field "Followup-To"))
2265                                   gnus-newsgroup-name method))))))
2266
2267 (defun article-de-quoted-unreadable (&optional force read-charset)
2268   "Translate a quoted-printable-encoded article.
2269 If FORCE, decode the article whether it is marked as quoted-printable
2270 or not.
2271 If READ-CHARSET, ask for a coding system."
2272   (interactive (list 'force current-prefix-arg))
2273   (save-excursion
2274     (let ((buffer-read-only nil) type charset)
2275       (if (gnus-buffer-live-p gnus-original-article-buffer)
2276           (with-current-buffer gnus-original-article-buffer
2277             (setq type
2278                   (gnus-fetch-field "content-transfer-encoding"))
2279             (let* ((ct (gnus-fetch-field "content-type"))
2280                    (ctl (and ct
2281                              (ignore-errors
2282                                (mail-header-parse-content-type ct)))))
2283               (setq charset (and ctl
2284                                  (mail-content-type-get ctl 'charset)))
2285               (if (stringp charset)
2286                   (setq charset (intern (downcase charset)))))))
2287       (if read-charset
2288           (setq charset (mm-read-coding-system "Charset: " charset)))
2289       (unless charset
2290         (setq charset gnus-newsgroup-charset))
2291       (when (or force
2292                 (and type (let ((case-fold-search t))
2293                             (string-match "quoted-printable" type))))
2294         (article-goto-body)
2295         (quoted-printable-decode-region
2296          (point) (point-max) (mm-charset-to-coding-system charset))))))
2297
2298 (defun article-de-base64-unreadable (&optional force read-charset)
2299   "Translate a base64 article.
2300 If FORCE, decode the article whether it is marked as base64 not.
2301 If READ-CHARSET, ask for a coding system."
2302   (interactive (list 'force current-prefix-arg))
2303   (save-excursion
2304     (let ((buffer-read-only nil) type charset)
2305       (if (gnus-buffer-live-p gnus-original-article-buffer)
2306           (with-current-buffer gnus-original-article-buffer
2307             (setq type
2308                   (gnus-fetch-field "content-transfer-encoding"))
2309             (let* ((ct (gnus-fetch-field "content-type"))
2310                    (ctl (and ct
2311                              (ignore-errors
2312                                (mail-header-parse-content-type ct)))))
2313               (setq charset (and ctl
2314                                  (mail-content-type-get ctl 'charset)))
2315               (if (stringp charset)
2316                   (setq charset (intern (downcase charset)))))))
2317       (if read-charset
2318           (setq charset (mm-read-coding-system "Charset: " charset)))
2319       (unless charset
2320         (setq charset gnus-newsgroup-charset))
2321       (when (or force
2322                 (and type (let ((case-fold-search t))
2323                             (string-match "base64" type))))
2324         (article-goto-body)
2325         (save-restriction
2326           (narrow-to-region (point) (point-max))
2327           (base64-decode-region (point-min) (point-max))
2328           (mm-decode-coding-region
2329            (point-min) (point-max) (mm-charset-to-coding-system charset)))))))
2330
2331 (eval-when-compile
2332   (require 'rfc1843))
2333
2334 (defun article-decode-HZ ()
2335   "Translate a HZ-encoded article."
2336   (interactive)
2337   (require 'rfc1843)
2338   (save-excursion
2339     (let ((buffer-read-only nil))
2340       (rfc1843-decode-region (point-min) (point-max)))))
2341
2342 (defun article-unsplit-urls ()
2343   "Remove the newlines that some other mailers insert into URLs."
2344   (interactive)
2345   (save-excursion
2346     (let ((buffer-read-only nil))
2347       (goto-char (point-min))
2348       (while (re-search-forward
2349               "^\\(\\(https?\\|ftp\\)://\\S-+\\) *\n\\(\\S-+\\)" nil t)
2350         (replace-match "\\1\\3" t)))
2351     (when (and gnus-display-mime-function (interactive-p))
2352       (funcall gnus-display-mime-function))))
2353
2354
2355 (defun article-wash-html (&optional read-charset)
2356   "Format an HTML article.
2357 If READ-CHARSET, ask for a coding system."
2358   (interactive "P")
2359   (save-excursion
2360     (let ((buffer-read-only nil)
2361           charset)
2362       (when (gnus-buffer-live-p gnus-original-article-buffer)
2363         (with-current-buffer gnus-original-article-buffer
2364           (let* ((ct (gnus-fetch-field "content-type"))
2365                  (ctl (and ct
2366                            (ignore-errors
2367                              (mail-header-parse-content-type ct)))))
2368             (setq charset (and ctl
2369                                (mail-content-type-get ctl 'charset)))
2370             (when (stringp charset)
2371               (setq charset (intern (downcase charset)))))))
2372       (when read-charset
2373         (setq charset (mm-read-coding-system "Charset: " charset)))
2374       (unless charset
2375         (setq charset gnus-newsgroup-charset))
2376       (article-goto-body)
2377       (save-window-excursion
2378         (save-restriction
2379           (narrow-to-region (point) (point-max))
2380           (let* ((func (or gnus-article-wash-function mm-text-html-renderer))
2381                  (entry (assq func mm-text-html-washer-alist)))
2382             (when entry
2383               (setq func (cdr entry)))
2384             (cond
2385              ((gnus-functionp func)
2386               (funcall func))
2387              (t
2388               (apply (car func) (cdr func))))))))))
2389
2390 (defun gnus-article-wash-html-with-w3 ()
2391   "Wash the current buffer with w3."
2392   (mm-setup-w3)
2393   (let ((w3-strict-width (window-width))
2394         (url-standalone-mode t)
2395         (url-gateway-unplugged t)
2396         (w3-honor-stylesheets nil))
2397     (condition-case ()
2398         (w3-region (point-min) (point-max))
2399       (error))))
2400
2401 (defun gnus-article-wash-html-with-w3m ()
2402   "Wash the current buffer with emacs-w3m."
2403   (mm-setup-w3m)
2404   (save-restriction
2405     (narrow-to-region (point) (point-max))
2406     (let ((w3m-safe-url-regexp (if mm-inline-text-html-with-images
2407                                    nil
2408                                  "\\`cid:"))
2409           (w3m-display-inline-images mm-inline-text-html-with-images)
2410           w3m-force-redisplay)
2411       (w3m-region (point-min) (point-max)))
2412     (when mm-inline-text-html-with-w3m-keymap
2413       (add-text-properties
2414        (point-min) (point-max)
2415        (nconc (mm-w3m-local-map-property)
2416               '(mm-inline-text-html-with-w3m t))))))
2417
2418 (defun article-hide-list-identifiers ()
2419   "Remove list identifies from the Subject header.
2420 The `gnus-list-identifiers' variable specifies what to do."
2421   (interactive)
2422   (let ((inhibit-point-motion-hooks t)
2423         (regexp (if (consp gnus-list-identifiers)
2424                     (mapconcat 'identity gnus-list-identifiers " *\\|")
2425                   gnus-list-identifiers))
2426         buffer-read-only)
2427     (when regexp
2428       (save-excursion
2429         (save-restriction
2430           (article-narrow-to-head)
2431           (goto-char (point-min))
2432           (while (re-search-forward
2433                   (concat "^Subject: +\\(R[Ee]: +\\)*\\(" regexp " *\\)")
2434                   nil t)
2435             (delete-region (match-beginning 2) (match-end 0))
2436             (beginning-of-line))
2437           (when (re-search-forward
2438                  "^Subject: +\\(\\(R[Ee]: +\\)+\\)R[Ee]: +" nil t)
2439             (delete-region (match-beginning 1) (match-end 1))))))))
2440
2441 (defun article-hide-pgp ()
2442   "Remove any PGP headers and signatures in the current article."
2443   (interactive)
2444   (save-excursion
2445     (save-restriction
2446       (let ((inhibit-point-motion-hooks t)
2447             buffer-read-only beg end)
2448         (article-goto-body)
2449         ;; Hide the "header".
2450         (when (re-search-forward "^-----BEGIN PGP SIGNED MESSAGE-----\n" nil t)
2451           (gnus-add-wash-type 'pgp)
2452           (delete-region (match-beginning 0) (match-end 0))
2453           ;; Remove armor headers (rfc2440 6.2)
2454           (delete-region (point) (or (re-search-forward "^[ \t]*\n" nil t)
2455                                      (point)))
2456           (setq beg (point))
2457           ;; Hide the actual signature.
2458           (and (search-forward "\n-----BEGIN PGP SIGNATURE-----\n" nil t)
2459                (setq end (1+ (match-beginning 0)))
2460                (delete-region
2461                 end
2462                 (if (search-forward "\n-----END PGP SIGNATURE-----\n" nil t)
2463                     (match-end 0)
2464                   ;; Perhaps we shouldn't hide to the end of the buffer
2465                   ;; if there is no end to the signature?
2466                   (point-max))))
2467           ;; Hide "- " PGP quotation markers.
2468           (when (and beg end)
2469             (narrow-to-region beg end)
2470             (goto-char (point-min))
2471             (while (re-search-forward "^- " nil t)
2472               (delete-region
2473                (match-beginning 0) (match-end 0)))
2474             (widen))
2475           (gnus-run-hooks 'gnus-article-hide-pgp-hook))))))
2476
2477 (defun article-hide-pem (&optional arg)
2478   "Toggle hiding of any PEM headers and signatures in the current article.
2479 If given a negative prefix, always show; if given a positive prefix,
2480 always hide."
2481   (interactive (gnus-article-hidden-arg))
2482   (unless (gnus-article-check-hidden-text 'pem arg)
2483     (save-excursion
2484       (let (buffer-read-only end)
2485         (goto-char (point-min))
2486         ;; Hide the horrendously ugly "header".
2487         (when (and (search-forward
2488                     "\n-----BEGIN PRIVACY-ENHANCED MESSAGE-----\n"
2489                     nil t)
2490                    (setq end (1+ (match-beginning 0))))
2491           (gnus-add-wash-type 'pem)
2492           (gnus-article-hide-text-type
2493            end
2494            (if (search-forward "\n\n" nil t)
2495                (match-end 0)
2496              (point-max))
2497            'pem)
2498           ;; Hide the trailer as well
2499           (when (search-forward "\n-----END PRIVACY-ENHANCED MESSAGE-----\n"
2500                                 nil t)
2501             (gnus-article-hide-text-type
2502              (match-beginning 0) (match-end 0) 'pem)))))))
2503
2504 (defun article-strip-banner ()
2505   "Strip the banner specified by the `banner' group parameter."
2506   (interactive)
2507   (save-excursion
2508     (save-restriction
2509       (let ((inhibit-point-motion-hooks t)
2510             (banner (gnus-parameter-banner gnus-newsgroup-name))
2511             (gnus-signature-limit nil)
2512             buffer-read-only beg end)
2513         (when (and gnus-article-address-banner-alist
2514                    (not banner))
2515           (setq banner
2516                 (let ((from (save-restriction
2517                               (widen)
2518                               (article-narrow-to-head)
2519                               (mail-fetch-field "from"))))
2520                   (when (and from
2521                              (setq from
2522                                    (caar (mail-header-parse-addresses from))))
2523                     (catch 'found
2524                       (dolist (pair gnus-article-address-banner-alist)
2525                         (when (string-match (car pair) from)
2526                           (throw 'found (cdr pair)))))))))
2527         (when banner
2528           (article-goto-body)
2529           (cond
2530            ((eq banner 'signature)
2531             (when (gnus-article-narrow-to-signature)
2532               (widen)
2533               (forward-line -1)
2534               (delete-region (point) (point-max))))
2535            ((symbolp banner)
2536             (if (setq banner (cdr (assq banner gnus-article-banner-alist)))
2537                 (while (re-search-forward banner nil t)
2538                   (delete-region (match-beginning 0) (match-end 0)))))
2539            ((stringp banner)
2540             (while (re-search-forward banner nil t)
2541               (delete-region (match-beginning 0) (match-end 0))))))))))
2542
2543 (defun article-babel ()
2544   "Translate article using an online translation service."
2545   (interactive)
2546   (require 'babel)
2547   (save-excursion
2548     (set-buffer gnus-article-buffer)
2549     (when (article-goto-body)
2550       (let* ((buffer-read-only nil)
2551              (start (point))
2552              (end (point-max))
2553              (orig (buffer-substring start end))
2554              (trans (babel-as-string orig)))
2555         (save-restriction
2556           (narrow-to-region start end)
2557           (delete-region start end)
2558           (insert trans))))))
2559
2560 (defun article-hide-signature (&optional arg)
2561   "Hide the signature in the current article.
2562 If given a negative prefix, always show; if given a positive prefix,
2563 always hide."
2564   (interactive (gnus-article-hidden-arg))
2565   (save-excursion
2566     (save-restriction
2567       (if (interactive-p)
2568           (progn
2569             (widen)
2570             (article-goto-body))
2571         (goto-char (point-min)))
2572       (unless (gnus-article-check-hidden-text 'signature arg)
2573         (let ((buffer-read-only nil)
2574               (button (point)))
2575           (while (setq button (text-property-any button (point-max)
2576                                                  'gnus-callback
2577                                                  'gnus-signature-toggle))
2578             (setq button (text-property-not-all button (point-max)
2579                                                 'gnus-callback
2580                                                 'gnus-signature-toggle))
2581             (when (and button (not (eobp)))
2582               (gnus-article-hide-text-type
2583                (1+ button)
2584                (next-single-property-change (1+ button) 'mime-view-entity
2585                                             nil (point-max))
2586                'signature)))))))
2587   (gnus-set-mode-line 'article))
2588
2589 (defun article-strip-headers-in-body ()
2590   "Strip offensive headers from bodies."
2591   (interactive)
2592   (save-excursion
2593     (article-goto-body)
2594     (let ((case-fold-search t))
2595       (when (looking-at "x-no-archive:")
2596         (gnus-delete-line)))))
2597
2598 (defun article-strip-leading-blank-lines ()
2599   "Remove all blank lines from the beginning of the article."
2600   (interactive)
2601   (save-excursion
2602     (let ((inhibit-point-motion-hooks t)
2603           buffer-read-only)
2604       (when (article-goto-body)
2605         (while (and (not (eobp))
2606                     (looking-at "[ \t]*$"))
2607           (gnus-delete-line))))))
2608
2609 (defun article-narrow-to-head ()
2610   "Narrow the buffer to the head of the message.
2611 Point is left at the beginning of the narrowed-to region."
2612   (narrow-to-region
2613    (goto-char (point-min))
2614    (if (search-forward "\n\n" nil 1)
2615        (1- (point))
2616      (point-max)))
2617   (goto-char (point-min)))
2618
2619 (defun article-goto-body ()
2620   "Place point at the start of the body."
2621   (goto-char (point-min))
2622   (cond
2623    ;; This variable is only bound when dealing with separate
2624    ;; MIME body parts.
2625    (article-goto-body-goes-to-point-min-p
2626     t)
2627    ((search-forward "\n\n" nil t)
2628     t)
2629    (t
2630     (goto-char (point-max))
2631     nil)))
2632
2633 (defun article-strip-multiple-blank-lines ()
2634   "Replace consecutive blank lines with one empty line."
2635   (interactive)
2636   (save-excursion
2637     (let ((inhibit-point-motion-hooks t)
2638           buffer-read-only)
2639       ;; First make all blank lines empty.
2640       (article-goto-body)
2641       (while (re-search-forward "^[ \t]+$" nil t)
2642         (unless (gnus-annotation-in-region-p
2643                  (match-beginning 0) (match-end 0))
2644           (replace-match "" nil t)))
2645       ;; Then replace multiple empty lines with a single empty line.
2646       (article-goto-body)
2647       (while (re-search-forward "\n\n\\(\n+\\)" nil t)
2648         (unless (gnus-annotation-in-region-p
2649                  (match-beginning 0) (match-end 0))
2650           (delete-region (match-beginning 1) (match-end 1)))))))
2651
2652 (defun article-strip-leading-space ()
2653   "Remove all white space from the beginning of the lines in the article."
2654   (interactive)
2655   (save-excursion
2656     (let ((inhibit-point-motion-hooks t)
2657           buffer-read-only)
2658       (article-goto-body)
2659       (while (re-search-forward "^[ \t]+" nil t)
2660         (replace-match "" t t)))))
2661
2662 (defun article-strip-trailing-space ()
2663   "Remove all white space from the end of the lines in the article."
2664   (interactive)
2665   (save-excursion
2666     (let ((inhibit-point-motion-hooks t)
2667           buffer-read-only)
2668       (article-goto-body)
2669       (while (re-search-forward "[ \t]+$" nil t)
2670         (replace-match "" t t)))))
2671
2672 (defun article-strip-blank-lines ()
2673   "Strip leading, trailing and multiple blank lines."
2674   (interactive)
2675   (article-strip-leading-blank-lines)
2676   (article-remove-trailing-blank-lines)
2677   (article-strip-multiple-blank-lines))
2678
2679 (defun article-strip-all-blank-lines ()
2680   "Strip all blank lines."
2681   (interactive)
2682   (save-excursion
2683     (let ((inhibit-point-motion-hooks t)
2684           buffer-read-only)
2685       (article-goto-body)
2686       (while (re-search-forward "^[ \t]*\n" nil t)
2687         (replace-match "" t t)))))
2688
2689 (defun gnus-article-narrow-to-signature ()
2690   "Narrow to the signature; return t if a signature is found, else nil."
2691   (let ((inhibit-point-motion-hooks t))
2692     (when (gnus-article-search-signature)
2693       (forward-line 1)
2694       ;; Check whether we have some limits to what we consider
2695       ;; to be a signature.
2696       (let ((limits (if (listp gnus-signature-limit) gnus-signature-limit
2697                       (list gnus-signature-limit)))
2698             limit limited)
2699         (while (setq limit (pop limits))
2700           (if (or (and (integerp limit)
2701                        (< (- (point-max) (point)) limit))
2702                   (and (floatp limit)
2703                        (< (count-lines (point) (point-max)) limit))
2704                   (and (gnus-functionp limit)
2705                        (funcall limit))
2706                   (and (stringp limit)
2707                        (not (re-search-forward limit nil t))))
2708               ()                        ; This limit did not succeed.
2709             (setq limited t
2710                   limits nil)))
2711         (unless limited
2712           (narrow-to-region (point) (point-max))
2713           t)))))
2714
2715 (defun gnus-article-search-signature ()
2716   "Search the current buffer for the signature separator.
2717 Put point at the beginning of the signature separator."
2718   (let ((cur (point)))
2719     (goto-char (point-max))
2720     (if (if (stringp gnus-signature-separator)
2721             (re-search-backward gnus-signature-separator nil t)
2722           (let ((seps gnus-signature-separator))
2723             (while (and seps
2724                         (not (re-search-backward (car seps) nil t)))
2725               (pop seps))
2726             seps))
2727         t
2728       (goto-char cur)
2729       nil)))
2730
2731 (defun gnus-article-hidden-arg ()
2732   "Return the current prefix arg as a number, or 0 if no prefix."
2733   (list (if current-prefix-arg
2734             (prefix-numeric-value current-prefix-arg)
2735           0)))
2736
2737 (defun gnus-article-check-hidden-text (type arg)
2738   "Return nil if hiding is necessary.
2739 Arg can be nil or a number.  nil and positive means hide, negative
2740 means show, 0 means toggle."
2741   (save-excursion
2742     (save-restriction
2743       (let ((hide (gnus-article-hidden-text-p type)))
2744         (cond
2745          ((or (null arg)
2746               (> arg 0))
2747           nil)
2748          ((< arg 0)
2749           (gnus-article-show-hidden-text type)
2750           t)
2751          (t
2752           (if (eq hide 'hidden)
2753               (progn
2754                 (gnus-article-show-hidden-text type)
2755                 t)
2756             nil)))))))
2757
2758 (defun gnus-article-hidden-text-p (type)
2759   "Say whether the current buffer contains hidden text of type TYPE."
2760   (let ((pos (text-property-any (point-min) (point-max) 'article-type type)))
2761     (while (and pos
2762                 (not (get-text-property pos 'invisible))
2763                 (not (get-text-property pos 'dummy-invisible)))
2764       (setq pos
2765             (text-property-any (1+ pos) (point-max) 'article-type type)))
2766     (if pos
2767         'hidden
2768       nil)))
2769
2770 (defun gnus-article-show-hidden-text (type &optional dummy)
2771   "Show all hidden text of type TYPE.
2772 Originally it is hide instead of DUMMY."
2773   (let ((buffer-read-only nil)
2774         (inhibit-point-motion-hooks t))
2775     (gnus-remove-text-properties-when
2776      'article-type type
2777      (point-min) (point-max)
2778      (cons 'article-type (cons type
2779                                gnus-hidden-properties)))
2780     (gnus-delete-wash-type type)))
2781
2782 (defconst article-time-units
2783   `((year . ,(* 365.25 24 60 60))
2784     (week . ,(* 7 24 60 60))
2785     (day . ,(* 24 60 60))
2786     (hour . ,(* 60 60))
2787     (minute . 60)
2788     (second . 1))
2789   "Mapping from time units to seconds.")
2790
2791 (defun gnus-article-forward-header ()
2792   "Move point to the start of the next header.
2793 If the current header is a continuation header, this can be several
2794 lines forward."
2795   (let ((ended nil))
2796     (while (not ended)
2797       (forward-line 1)
2798       (if (looking-at "[ \t]+[^ \t]")
2799           (forward-line 1)
2800         (setq ended t)))))
2801
2802 (defun article-date-ut (&optional type highlight header)
2803   "Convert DATE date to universal time in the current article.
2804 If TYPE is `local', convert to local time; if it is `lapsed', output
2805 how much time has lapsed since DATE.  For `lapsed', the value of
2806 `gnus-article-date-lapsed-new-header' says whether the \"X-Sent:\" header
2807 should replace the \"Date:\" one, or should be added below it."
2808   (interactive (list 'ut t))
2809   (let* ((header (or header
2810                      (and (eq 1 (point-min))
2811                           (mail-header-date (save-excursion
2812                                               (set-buffer gnus-summary-buffer)
2813                                               gnus-current-headers)))
2814                      (message-fetch-field "date")
2815                      ""))
2816          (date (if (vectorp header) (mail-header-date header)
2817                  header))
2818          (inhibit-point-motion-hooks t)
2819          bface eface date-pos)
2820     (when (and date (not (string= date "")))
2821       (save-excursion
2822         (save-restriction
2823           (article-narrow-to-head)
2824           (when (or (and (eq type 'lapsed)
2825                          gnus-article-date-lapsed-new-header
2826                          ;; Attempt to get the face of X-Sent first.
2827                          (re-search-forward "^X-Sent:[ \t]" nil t))
2828                     (re-search-forward "^Date:[ \t]" nil t)
2829                     ;; If Date is missing, try again for X-Sent.
2830                     (re-search-forward "^X-Sent:[ \t]" nil t))
2831             (setq bface (get-text-property (gnus-point-at-bol) 'face)
2832                   date (or (get-text-property (gnus-point-at-bol)
2833                                               'original-date)
2834                            date)
2835                   eface (get-text-property (1- (gnus-point-at-eol))
2836                                            'face)))
2837           (let ((buffer-read-only nil))
2838             ;; Delete any old X-Sent headers.
2839             (when (setq date-pos
2840                         (text-property-any (point-min) (point-max)
2841                                            'article-date-lapsed t))
2842               (goto-char (setq date-pos (set-marker (make-marker) date-pos)))
2843               (delete-region (match-beginning 0)
2844                              (progn (forward-line 1) (point))))
2845             (goto-char (point-min))
2846             ;; Delete any old Date headers.
2847             (while (re-search-forward "^Date:[ \t]" nil t)
2848               (unless date-pos
2849                 (setq date-pos (match-beginning 0)))
2850               (unless (and (eq type 'lapsed)
2851                            gnus-article-date-lapsed-new-header)
2852                 (delete-region (match-beginning 0)
2853                                (progn (message-next-header) (point)))))
2854             (if date-pos
2855                 (progn
2856                   (goto-char date-pos)
2857                   (unless (bolp)
2858                     ;; Possibly, Date has been deleted.
2859                     (insert "\n"))
2860                   (when (and (eq type 'lapsed)
2861                              gnus-article-date-lapsed-new-header
2862                              (looking-at "Date:"))
2863                     (forward-line 1)))
2864               (goto-char (point-min)))
2865             (insert (article-make-date-line date type))
2866             (when (eq type 'lapsed)
2867               (put-text-property (gnus-point-at-bol) (point)
2868                                  'article-date-lapsed t))
2869             (insert "\n")
2870             (forward-line -1)
2871             ;; Do highlighting.
2872             (when (looking-at "\\([^:]+\\): *\\(.*\\)$")
2873               (put-text-property (match-beginning 1) (1+ (match-end 1))
2874                                  'original-date date)
2875               (put-text-property (match-beginning 1) (1+ (match-end 1))
2876                                  'face bface)
2877               (put-text-property (match-beginning 2) (match-end 2)
2878                                  'face eface))))))))
2879
2880 (defun article-make-date-line (date type)
2881   "Return a DATE line of TYPE."
2882   (unless (memq type '(local ut original user iso8601 lapsed english))
2883     (error "Unknown conversion type: %s" type))
2884   (condition-case ()
2885       (let ((time (date-to-time date)))
2886         (cond
2887          ;; Convert to the local timezone.
2888          ((eq type 'local)
2889           (let ((tz (car (current-time-zone time))))
2890             (format "Date: %s %s%02d%02d" (current-time-string time)
2891                     (if (> tz 0) "+" "-") (/ (abs tz) 3600)
2892                     (/ (% (abs tz) 3600) 60))))
2893          ;; Convert to Universal Time.
2894          ((eq type 'ut)
2895           (concat "Date: "
2896                   (current-time-string
2897                    (let* ((e (parse-time-string date))
2898                           (tm (apply 'encode-time e))
2899                           (ms (car tm))
2900                           (ls (- (cadr tm) (car (current-time-zone time)))))
2901                      (cond ((< ls 0) (list (1- ms) (+ ls 65536)))
2902                            ((> ls 65535) (list (1+ ms) (- ls 65536)))
2903                            (t (list ms ls)))))
2904                   " UT"))
2905          ;; Get the original date from the article.
2906          ((eq type 'original)
2907           (concat "Date: " (if (string-match "\n+$" date)
2908                                (substring date 0 (match-beginning 0))
2909                              date)))
2910          ;; Let the user define the format.
2911          ((eq type 'user)
2912           (let ((format (or (condition-case nil
2913                                 (with-current-buffer gnus-summary-buffer
2914                                   gnus-article-time-format)
2915                               (error nil))
2916                             gnus-article-time-format)))
2917             (if (gnus-functionp format)
2918                 (funcall format time)
2919               (concat "Date: " (format-time-string format time)))))
2920          ;; ISO 8601.
2921          ((eq type 'iso8601)
2922           (let ((tz (car (current-time-zone time))))
2923             (concat
2924              "Date: "
2925              (format-time-string "%Y%m%dT%H%M%S" time)
2926              (format "%s%02d%02d"
2927                      (if (> tz 0) "+" "-") (/ (abs tz) 3600)
2928                      (/ (% (abs tz) 3600) 60)))))
2929          ;; Do an X-Sent lapsed format.
2930          ((eq type 'lapsed)
2931           ;; If the date is seriously mangled, the timezone functions are
2932           ;; liable to bug out, so we ignore all errors.
2933           (let* ((now (current-time))
2934                  (real-time (subtract-time now time))
2935                  (real-sec (and real-time
2936                                 (+ (* (float (car real-time)) 65536)
2937                                    (cadr real-time))))
2938                  (sec (and real-time (abs real-sec)))
2939                  num prev)
2940             (cond
2941              ((null real-time)
2942               "X-Sent: Unknown")
2943              ((zerop sec)
2944               "X-Sent: Now")
2945              (t
2946               (concat
2947                "X-Sent: "
2948                ;; This is a bit convoluted, but basically we go
2949                ;; through the time units for years, weeks, etc,
2950                ;; and divide things to see whether that results
2951                ;; in positive answers.
2952                (mapconcat
2953                 (lambda (unit)
2954                   (if (zerop (setq num (ffloor (/ sec (cdr unit)))))
2955                       ;; The (remaining) seconds are too few to
2956                       ;; be divided into this time unit.
2957                       ""
2958                     ;; It's big enough, so we output it.
2959                     (setq sec (- sec (* num (cdr unit))))
2960                     (prog1
2961                         (concat (if prev ", " "") (int-to-string
2962                                                    (floor num))
2963                                 " " (symbol-name (car unit))
2964                                 (if (> num 1) "s" ""))
2965                       (setq prev t))))
2966                 article-time-units "")
2967                ;; If dates are odd, then it might appear like the
2968                ;; article was sent in the future.
2969                (if (> real-sec 0)
2970                    " ago"
2971                  " in the future"))))))
2972          ;; Display the date in proper English
2973          ((eq type 'english)
2974           (let ((dtime (decode-time time)))
2975             (concat
2976              "Date: the "
2977              (number-to-string (nth 3 dtime))
2978              (let ((digit (% (nth 3 dtime) 10)))
2979                (cond
2980                 ((memq (nth 3 dtime) '(11 12 13)) "th")
2981                 ((= digit 1) "st")
2982                 ((= digit 2) "nd")
2983                 ((= digit 3) "rd")
2984                 (t "th")))
2985              " of "
2986              (nth (1- (nth 4 dtime)) gnus-english-month-names)
2987              " "
2988              (number-to-string (nth 5 dtime))
2989              " at "
2990              (format "%02d" (nth 2 dtime))
2991              ":"
2992              (format "%02d" (nth 1 dtime)))))))
2993     (error
2994      (format "Date: %s (from T-gnus)" date))))
2995
2996 (defun article-date-local (&optional highlight)
2997   "Convert the current article date to the local timezone."
2998   (interactive (list t))
2999   (article-date-ut 'local highlight))
3000
3001 (defun article-date-english (&optional highlight)
3002   "Convert the current article date to something that is proper English."
3003   (interactive (list t))
3004   (article-date-ut 'english highlight))
3005
3006 (defun article-date-original (&optional highlight)
3007   "Convert the current article date to what it was originally.
3008 This is only useful if you have used some other date conversion
3009 function and want to see what the date was before converting."
3010   (interactive (list t))
3011   (article-date-ut 'original highlight))
3012
3013 (defun article-date-lapsed (&optional highlight)
3014   "Convert the current article date to time lapsed since it was sent."
3015   (interactive (list t))
3016   (article-date-ut 'lapsed highlight))
3017
3018 (defun article-update-date-lapsed ()
3019   "Function to be run from a timer to update the lapsed time line."
3020   (let (deactivate-mark)
3021     (save-excursion
3022       (ignore-errors
3023         (walk-windows
3024          (lambda (w)
3025            (set-buffer (window-buffer w))
3026            (when (eq major-mode 'gnus-article-mode)
3027              (goto-char (point-min))
3028              (when (re-search-forward "^X-Sent:" nil t)
3029                (article-date-lapsed t))))
3030          nil 'visible)))))
3031
3032 (defun gnus-start-date-timer (&optional n)
3033   "Start a timer to update the X-Sent header in the article buffers.
3034 The numerical prefix says how frequently (in seconds) the function
3035 is to run."
3036   (interactive "p")
3037   (unless n
3038     (setq n 1))
3039   (gnus-stop-date-timer)
3040   (setq article-lapsed-timer
3041         (nnheader-run-at-time 1 n 'article-update-date-lapsed)))
3042
3043 (defun gnus-stop-date-timer ()
3044   "Stop the X-Sent timer."
3045   (interactive)
3046   (when article-lapsed-timer
3047     (nnheader-cancel-timer article-lapsed-timer)
3048     (setq article-lapsed-timer nil)))
3049
3050 (defun article-date-user (&optional highlight)
3051   "Convert the current article date to the user-defined format.
3052 This format is defined by the `gnus-article-time-format' variable."
3053   (interactive (list t))
3054   (article-date-ut 'user highlight))
3055
3056 (defun article-date-iso8601 (&optional highlight)
3057   "Convert the current article date to ISO8601."
3058   (interactive (list t))
3059   (article-date-ut 'iso8601 highlight))
3060
3061 ;; (defun article-show-all ()
3062 ;;   "Show all hidden text in the article buffer."
3063 ;;   (interactive)
3064 ;;   (save-excursion
3065 ;;     (widen)
3066 ;;     (let ((buffer-read-only nil))
3067 ;;       (gnus-article-unhide-text (point-min) (point-max))
3068 ;;       (gnus-remove-text-with-property 'gnus-prev)
3069 ;;       (gnus-remove-text-with-property 'gnus-next))))
3070
3071 (defun article-show-all-headers ()
3072   "Show all hidden headers in the article buffer."
3073   (interactive)
3074   (save-excursion
3075     (save-restriction
3076       (widen)
3077       (article-narrow-to-head)
3078       (let ((buffer-read-only nil))
3079         (gnus-article-unhide-text (point-min) (point-max))))))
3080
3081 (defun article-remove-leading-whitespace ()
3082   "Remove excessive whitespace from all headers."
3083   (interactive)
3084   (save-excursion
3085     (save-restriction
3086       (let ((buffer-read-only nil))
3087         (article-narrow-to-head)
3088         (goto-char (point-min))
3089         (while (re-search-forward "^[^ :]+: \\([ \t]+\\)" nil t)
3090           (delete-region (match-beginning 1) (match-end 1)))))))
3091
3092 (defun article-emphasize (&optional arg)
3093   "Emphasize text according to `gnus-emphasis-alist'."
3094   (interactive (gnus-article-hidden-arg))
3095   (unless (gnus-article-check-hidden-text 'emphasis arg)
3096     (save-excursion
3097       (let ((alist (or
3098                     (condition-case nil
3099                         (with-current-buffer gnus-summary-buffer
3100                           gnus-article-emphasis-alist)
3101                       (error))
3102                     gnus-emphasis-alist))
3103             (buffer-read-only nil)
3104             (props (append '(article-type emphasis)
3105                            gnus-hidden-properties))
3106             regexp elem beg invisible visible face)
3107         (article-goto-body)
3108         (setq beg (point))
3109         (while (setq elem (pop alist))
3110           (goto-char beg)
3111           (setq regexp (car elem)
3112                 invisible (nth 1 elem)
3113                 visible (nth 2 elem)
3114                 face (nth 3 elem))
3115           (while (re-search-forward regexp nil t)
3116             (when (and (match-beginning visible) (match-beginning invisible))
3117               (gnus-article-hide-text
3118                (match-beginning invisible) (match-end invisible) props)
3119               (gnus-article-unhide-text-type
3120                (match-beginning visible) (match-end visible) 'emphasis)
3121               (gnus-put-overlay-excluding-newlines
3122                (match-beginning visible) (match-end visible) 'face face)
3123               (gnus-add-wash-type 'emphasis)
3124               (goto-char (match-end invisible)))))))))
3125
3126 (defun gnus-article-setup-highlight-words (&optional highlight-words)
3127   "Setup newsgroup emphasis alist."
3128   (unless gnus-article-emphasis-alist
3129     (let ((name (and gnus-newsgroup-name
3130                      (gnus-group-real-name gnus-newsgroup-name))))
3131       (make-local-variable 'gnus-article-emphasis-alist)
3132       (setq gnus-article-emphasis-alist
3133             (nconc
3134              (let ((alist gnus-group-highlight-words-alist) elem highlight)
3135                (while (setq elem (pop alist))
3136                  (when (and name (string-match (car elem) name))
3137                    (setq alist nil
3138                          highlight (copy-sequence (cdr elem)))))
3139                highlight)
3140              (copy-sequence highlight-words)
3141              (if gnus-newsgroup-name
3142                  (copy-sequence (gnus-group-find-parameter
3143                                  gnus-newsgroup-name 'highlight-words t)))
3144              gnus-emphasis-alist)))))
3145
3146 (eval-when-compile
3147   (defvar gnus-summary-article-menu)
3148   (defvar gnus-summary-post-menu))
3149
3150 ;;; Saving functions.
3151
3152 (defun gnus-article-save (save-buffer file &optional num)
3153   "Save the currently selected article."
3154   (unless gnus-save-all-headers
3155     ;; Remove headers according to `gnus-saved-headers'.
3156     (let ((gnus-visible-headers
3157            (or gnus-saved-headers gnus-visible-headers))
3158           (gnus-article-buffer save-buffer))
3159       (save-excursion
3160         (set-buffer save-buffer)
3161         (article-hide-headers 1 t))))
3162   (save-window-excursion
3163     (if (not gnus-default-article-saver)
3164         (error "No default saver is defined")
3165       ;; !!! Magic!  The saving functions all save
3166       ;; `gnus-save-article-buffer' (or so they think), but we
3167       ;; bind that variable to our save-buffer.
3168       (set-buffer gnus-article-buffer)
3169       (let* ((gnus-save-article-buffer save-buffer)
3170              (filename
3171               (cond
3172                ((not gnus-prompt-before-saving) 'default)
3173                ((eq gnus-prompt-before-saving 'always) nil)
3174                (t file)))
3175              (gnus-number-of-articles-to-be-saved
3176               (when (eq gnus-prompt-before-saving t)
3177                 num)))                  ; Magic
3178         (set-buffer gnus-article-current-summary)
3179         (funcall gnus-default-article-saver filename)))))
3180
3181 (defun gnus-read-save-file-name (prompt &optional filename
3182                                         function group headers variable)
3183   (let ((default-name
3184           (funcall function group headers (symbol-value variable)))
3185         result)
3186     (setq result
3187           (expand-file-name
3188            (cond
3189             ((eq filename 'default)
3190              default-name)
3191             ((eq filename t)
3192              default-name)
3193             (filename filename)
3194             (t
3195              (let* ((split-name (gnus-get-split-value gnus-split-methods))
3196                     (prompt
3197                      (format prompt
3198                              (if (and gnus-number-of-articles-to-be-saved
3199                                       (> gnus-number-of-articles-to-be-saved 1))
3200                                  (format "these %d articles"
3201                                          gnus-number-of-articles-to-be-saved)
3202                                "this article")))
3203                     (file
3204                      ;; Let the split methods have their say.
3205                      (cond
3206                       ;; No split name was found.
3207                       ((null split-name)
3208                        (read-file-name
3209                         (concat prompt " (default "
3210                                 (file-name-nondirectory default-name) ") ")
3211                         (file-name-directory default-name)
3212                         default-name))
3213                       ;; A single group name is returned.
3214                       ((stringp split-name)
3215                        (setq default-name
3216                              (funcall function split-name headers
3217                                       (symbol-value variable)))
3218                        (read-file-name
3219                         (concat prompt " (default "
3220                                 (file-name-nondirectory default-name) ") ")
3221                         (file-name-directory default-name)
3222                         default-name))
3223                       ;; A single split name was found
3224                       ((= 1 (length split-name))
3225                        (let* ((name (expand-file-name
3226                                      (car split-name)
3227                                      gnus-article-save-directory))
3228                               (dir (cond ((file-directory-p name)
3229                                           (file-name-as-directory name))
3230                                          ((file-exists-p name) name)
3231                                          (t gnus-article-save-directory))))
3232                          (read-file-name
3233                           (concat prompt " (default " name ") ")
3234                           dir name)))
3235                       ;; A list of splits was found.
3236                       (t
3237                        (setq split-name (nreverse split-name))
3238                        (let (result)
3239                          (let ((file-name-history
3240                                 (nconc split-name file-name-history)))
3241                            (setq result
3242                                  (expand-file-name
3243                                   (read-file-name
3244                                    (concat prompt " (`M-p' for defaults) ")
3245                                    gnus-article-save-directory
3246                                    (car split-name))
3247                                   gnus-article-save-directory)))
3248                          (car (push result file-name-history)))))))
3249                ;; Create the directory.
3250                (gnus-make-directory (file-name-directory file))
3251                ;; If we have read a directory, we append the default file name.
3252                (when (file-directory-p file)
3253                  (setq file (expand-file-name (file-name-nondirectory
3254                                                default-name)
3255                                               (file-name-as-directory file))))
3256                ;; Possibly translate some characters.
3257                (nnheader-translate-file-chars file))))))
3258     (gnus-make-directory (file-name-directory result))
3259     (set variable result)))
3260
3261 (defun gnus-article-archive-name (group)
3262   "Return the first instance of an \"Archive-name\" in the current buffer."
3263   (let ((case-fold-search t))
3264     (when (re-search-forward "archive-name: *\\([^ \n\t]+\\)[ \t]*$" nil t)
3265       (nnheader-concat gnus-article-save-directory
3266                        (match-string 1)))))
3267
3268 (defun gnus-article-nndoc-name (group)
3269   "If GROUP is an nndoc group, return the name of the parent group."
3270   (when (eq (car (gnus-find-method-for-group group)) 'nndoc)
3271     (gnus-group-get-parameter group 'save-article-group)))
3272
3273 (defun gnus-summary-save-in-rmail (&optional filename)
3274   "Append this article to Rmail file.
3275 Optional argument FILENAME specifies file name.
3276 Directory to save to is default to `gnus-article-save-directory'."
3277   (setq filename (gnus-read-save-file-name
3278                   "Save %s in rmail file:" filename
3279                   gnus-rmail-save-name gnus-newsgroup-name
3280                   gnus-current-headers 'gnus-newsgroup-last-rmail))
3281   (gnus-eval-in-buffer-window gnus-save-article-buffer
3282     (save-excursion
3283       (save-restriction
3284         (widen)
3285         (gnus-output-to-rmail filename))))
3286   filename)
3287
3288 (defun gnus-summary-save-in-mail (&optional filename)
3289   "Append this article to Unix mail file.
3290 Optional argument FILENAME specifies file name.
3291 Directory to save to is default to `gnus-article-save-directory'."
3292   (setq filename (gnus-read-save-file-name
3293                   "Save %s in Unix mail file:" filename
3294                   gnus-mail-save-name gnus-newsgroup-name
3295                   gnus-current-headers 'gnus-newsgroup-last-mail))
3296   (gnus-eval-in-buffer-window gnus-save-article-buffer
3297     (save-excursion
3298       (save-restriction
3299         (widen)
3300         (if (and (file-readable-p filename)
3301                  (mail-file-babyl-p filename))
3302             (rmail-output-to-rmail-file filename t)
3303           (gnus-output-to-mail filename)))))
3304   filename)
3305
3306 (defun gnus-summary-save-in-file (&optional filename overwrite)
3307   "Append this article to file.
3308 Optional argument FILENAME specifies file name.
3309 Directory to save to is default to `gnus-article-save-directory'."
3310   (setq filename (gnus-read-save-file-name
3311                   "Save %s in file:" filename
3312                   gnus-file-save-name gnus-newsgroup-name
3313                   gnus-current-headers 'gnus-newsgroup-last-file))
3314   (gnus-eval-in-buffer-window gnus-save-article-buffer
3315     (save-excursion
3316       (save-restriction
3317         (widen)
3318         (when (and overwrite
3319                    (file-exists-p filename))
3320           (delete-file filename))
3321         (gnus-output-to-file filename))))
3322   filename)
3323
3324 (defun gnus-summary-write-to-file (&optional filename)
3325   "Write this article to a file, overwriting it if the file exists.
3326 Optional argument FILENAME specifies file name.
3327 The directory to save in defaults to `gnus-article-save-directory'."
3328   (gnus-summary-save-in-file nil t))
3329
3330 (defun gnus-summary-save-body-in-file (&optional filename)
3331   "Append this article body to a file.
3332 Optional argument FILENAME specifies file name.
3333 The directory to save in defaults to `gnus-article-save-directory'."
3334   (setq filename (gnus-read-save-file-name
3335                   "Save %s body in file:" filename
3336                   gnus-file-save-name gnus-newsgroup-name
3337                   gnus-current-headers 'gnus-newsgroup-last-file))
3338   (gnus-eval-in-buffer-window gnus-save-article-buffer
3339     (save-excursion
3340       (save-restriction
3341         (widen)
3342         (when (article-goto-body)
3343           (narrow-to-region (point) (point-max)))
3344         (gnus-output-to-file filename))))
3345   filename)
3346
3347 (defun gnus-summary-save-in-pipe (&optional command)
3348   "Pipe this article to subprocess."
3349   (setq command
3350         (cond ((and (eq command 'default)
3351                     gnus-last-shell-command)
3352                gnus-last-shell-command)
3353               ((stringp command)
3354                command)
3355               (t (read-string
3356                   (format
3357                    "Shell command on %s: "
3358                    (if (and gnus-number-of-articles-to-be-saved
3359                             (> gnus-number-of-articles-to-be-saved 1))
3360                        (format "these %d articles"
3361                                gnus-number-of-articles-to-be-saved)
3362                      "this article"))
3363                   gnus-last-shell-command))))
3364   (when (string-equal command "")
3365     (if gnus-last-shell-command
3366         (setq command gnus-last-shell-command)
3367       (error "A command is required")))
3368   (gnus-eval-in-buffer-window gnus-article-buffer
3369     (save-restriction
3370       (widen)
3371       (shell-command-on-region (point-min) (point-max) command nil)))
3372   (setq gnus-last-shell-command command))
3373
3374 (defun gnus-summary-pipe-to-muttprint (&optional command)
3375   "Pipe this article to muttprint."
3376   (setq command (read-string
3377                  "Print using command: " gnus-summary-muttprint-program
3378                  nil gnus-summary-muttprint-program))
3379   (gnus-summary-save-in-pipe command))
3380
3381 ;;; Article file names when saving.
3382
3383 (defun gnus-capitalize-newsgroup (newsgroup)
3384   "Capitalize NEWSGROUP name."
3385   (when (not (zerop (length newsgroup)))
3386     (concat (char-to-string (upcase (aref newsgroup 0)))
3387             (substring newsgroup 1))))
3388
3389 (defun gnus-Numeric-save-name (newsgroup headers &optional last-file)
3390   "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE.
3391 If variable `gnus-use-long-file-name' is non-nil, it is ~/News/News.group/num.
3392 Otherwise, it is like ~/News/news/group/num."
3393   (let ((default
3394           (expand-file-name
3395            (concat (if (gnus-use-long-file-name 'not-save)
3396                        (gnus-capitalize-newsgroup newsgroup)
3397                      (gnus-newsgroup-directory-form newsgroup))
3398                    "/" (int-to-string (mail-header-number headers)))
3399            gnus-article-save-directory)))
3400     (if (and last-file
3401              (string-equal (file-name-directory default)
3402                            (file-name-directory last-file))
3403              (string-match "^[0-9]+$" (file-name-nondirectory last-file)))
3404         default
3405       (or last-file default))))
3406
3407 (defun gnus-numeric-save-name (newsgroup headers &optional last-file)
3408   "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE.
3409 If variable `gnus-use-long-file-name' is non-nil, it is
3410 ~/News/news.group/num.  Otherwise, it is like ~/News/news/group/num."
3411   (let ((default
3412           (expand-file-name
3413            (concat (if (gnus-use-long-file-name 'not-save)
3414                        newsgroup
3415                      (gnus-newsgroup-directory-form newsgroup))
3416                    "/" (int-to-string (mail-header-number headers)))
3417            gnus-article-save-directory)))
3418     (if (and last-file
3419              (string-equal (file-name-directory default)
3420                            (file-name-directory last-file))
3421              (string-match "^[0-9]+$" (file-name-nondirectory last-file)))
3422         default
3423       (or last-file default))))
3424
3425 (defun gnus-plain-save-name (newsgroup headers &optional last-file)
3426   "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE.
3427 If variable `gnus-use-long-file-name' is non-nil, it is
3428 ~/News/news.group.  Otherwise, it is like ~/News/news/group/news."
3429   (or last-file
3430       (expand-file-name
3431        (if (gnus-use-long-file-name 'not-save)
3432            newsgroup
3433          (file-relative-name
3434           (expand-file-name "news" (gnus-newsgroup-directory-form newsgroup))
3435           default-directory))
3436        gnus-article-save-directory)))
3437
3438 (defun gnus-sender-save-name (newsgroup headers &optional last-file)
3439   "Generate file name from sender."
3440   (let ((from (mail-header-from headers)))
3441     (expand-file-name
3442      (if (and from (string-match "\\([^ <]+\\)@" from))
3443          (match-string 1 from)
3444        "nobody")
3445      gnus-article-save-directory)))
3446
3447 (defun article-verify-x-pgp-sig ()
3448   "Verify X-PGP-Sig."
3449   (interactive)
3450   (if (gnus-buffer-live-p gnus-original-article-buffer)
3451       (let ((sig (with-current-buffer gnus-original-article-buffer
3452                    (gnus-fetch-field "X-PGP-Sig")))
3453             items info headers)
3454         (when (and sig
3455                    mml2015-use
3456                    (mml2015-clear-verify-function))
3457           (with-temp-buffer
3458             (insert-buffer-substring gnus-original-article-buffer)
3459             (setq items (split-string sig))
3460             (message-narrow-to-head)
3461             (let ((inhibit-point-motion-hooks t)
3462                   (case-fold-search t))
3463               ;; Don't verify multiple headers.
3464               (setq headers (mapconcat (lambda (header)
3465                                          (concat header ": "
3466                                                  (mail-fetch-field header) "\n"))
3467                                        (split-string (nth 1 items) ",") "")))
3468             (delete-region (point-min) (point-max))
3469             (insert "-----BEGIN PGP SIGNED MESSAGE-----\n\n")
3470             (insert "X-Signed-Headers: " (nth 1 items) "\n")
3471             (insert headers)
3472             (widen)
3473             (forward-line)
3474             (while (not (eobp))
3475               (if (looking-at "^-")
3476                   (insert "- "))
3477               (forward-line))
3478             (insert "\n-----BEGIN PGP SIGNATURE-----\n")
3479             (insert "Version: " (car items) "\n\n")
3480             (insert (mapconcat 'identity (cddr items) "\n"))
3481             (insert "\n-----END PGP SIGNATURE-----\n")
3482             (let ((mm-security-handle (list (format "multipart/signed"))))
3483               (mml2015-clean-buffer)
3484               (let ((coding-system-for-write (or gnus-newsgroup-charset
3485                                                  'iso-8859-1)))
3486                 (funcall (mml2015-clear-verify-function)))
3487               (setq info
3488                     (or (mm-handle-multipart-ctl-parameter
3489                          mm-security-handle 'gnus-details)
3490                         (mm-handle-multipart-ctl-parameter
3491                          mm-security-handle 'gnus-info)))))
3492           (when info
3493             (let (buffer-read-only bface eface)
3494               (save-restriction
3495                 (message-narrow-to-head)
3496                 (goto-char (point-max))
3497                 (forward-line -1)
3498                 (setq bface (get-text-property (gnus-point-at-bol) 'face)
3499                       eface (get-text-property (1- (gnus-point-at-eol)) 'face))
3500                 (message-remove-header "X-Gnus-PGP-Verify")
3501                 (if (re-search-forward "^X-PGP-Sig:" nil t)
3502                     (forward-line)
3503                   (goto-char (point-max)))
3504                 (narrow-to-region (point) (point))
3505                 (insert "X-Gnus-PGP-Verify: " info "\n")
3506                 (goto-char (point-min))
3507                 (forward-line)
3508                 (while (not (eobp))
3509                   (if (not (looking-at "^[ \t]"))
3510                       (insert " "))
3511                   (forward-line))
3512                 ;; Do highlighting.
3513                 (goto-char (point-min))
3514                 (when (looking-at "\\([^:]+\\): *")
3515                   (put-text-property (match-beginning 1) (1+ (match-end 1))
3516                                      'face bface)
3517                   (put-text-property (match-end 0) (point-max)
3518                                      'face eface)))))))))
3519
3520 (defun article-verify-cancel-lock ()
3521   "Verify Cancel-Lock header."
3522   (interactive)
3523   (if (gnus-buffer-live-p gnus-original-article-buffer)
3524       (canlock-verify gnus-original-article-buffer)))
3525
3526 (defun article-monafy ()
3527   "Display body part with mona font."
3528   (interactive)
3529   (unless (if (featurep 'xemacs)
3530               (find-face 'gnus-mona-face)
3531             (facep 'gnus-mona-face))
3532     (require 'navi2ch-mona)
3533     (set-face-font (make-face 'gnus-mona-face) navi2ch-mona-font))
3534   (save-excursion
3535     (let ((buffer-read-only nil))
3536       (article-goto-body)
3537       (gnus-overlay-put
3538        (gnus-make-overlay (point) (point-max))
3539        'face 'gnus-mona-face))))
3540
3541 (eval-and-compile
3542   (mapcar
3543    (lambda (func)
3544      (let (afunc gfunc)
3545        (if (consp func)
3546            (setq afunc (car func)
3547                  gfunc (cdr func))
3548          (setq afunc func
3549                gfunc (intern (format "gnus-%s" func))))
3550        (defalias gfunc
3551          (when (fboundp afunc)
3552            `(lambda (&optional interactive &rest args)
3553               ,(documentation afunc t)
3554               (interactive (list t))
3555               (save-excursion
3556                 (set-buffer gnus-article-buffer)
3557                 (if interactive
3558                     (call-interactively ',afunc)
3559                   (apply ',afunc args))))))))
3560    '(article-hide-headers
3561      article-verify-x-pgp-sig
3562      article-verify-cancel-lock
3563      article-monafy
3564      article-hide-boring-headers
3565      article-treat-overstrike
3566      article-fill-long-lines
3567      article-capitalize-sentences
3568      article-remove-cr
3569      article-remove-leading-whitespace
3570      article-display-x-face
3571      article-display-face
3572      article-de-quoted-unreadable
3573      article-de-base64-unreadable
3574      article-decode-HZ
3575      article-wash-html
3576      article-unsplit-urls
3577      article-hide-list-identifiers
3578      article-hide-pgp
3579      article-strip-banner
3580      article-babel
3581      article-hide-pem
3582      article-hide-signature
3583      article-strip-headers-in-body
3584      article-remove-trailing-blank-lines
3585      article-strip-leading-blank-lines
3586      article-strip-multiple-blank-lines
3587      article-strip-leading-space
3588      article-strip-trailing-space
3589      article-strip-blank-lines
3590      article-strip-all-blank-lines
3591      article-date-local
3592      article-date-english
3593      article-date-iso8601
3594      article-date-original
3595      article-date-ut
3596      article-decode-mime-words
3597      article-decode-charset
3598      article-decode-encoded-words
3599      article-date-user
3600      article-date-lapsed
3601      article-emphasize
3602      article-treat-dumbquotes
3603      article-normalize-headers
3604      (article-show-all-headers . gnus-article-show-all-headers)
3605 ;;      (article-show-all . gnus-article-show-all)
3606      )))
3607 \f
3608 ;;;
3609 ;;; Gnus article mode
3610 ;;;
3611
3612 (put 'gnus-article-mode 'mode-class 'special)
3613
3614 (gnus-define-keys gnus-article-mode-map
3615   " " gnus-article-goto-next-page
3616   "\177" gnus-article-goto-prev-page
3617   [delete] gnus-article-goto-prev-page
3618   [backspace] gnus-article-goto-prev-page
3619   "\C-c^" gnus-article-refer-article
3620   "h" gnus-article-show-summary
3621   "s" gnus-article-show-summary
3622   "\C-c\C-m" gnus-article-mail
3623   "?" gnus-article-describe-briefly
3624   "e" gnus-summary-edit-article
3625   "<" beginning-of-buffer
3626   ">" end-of-buffer
3627   "\C-c\C-i" gnus-info-find-node
3628   "\C-c\C-b" gnus-bug
3629   "R" gnus-article-reply-with-original
3630   "F" gnus-article-followup-with-original
3631   "\C-hk" gnus-article-describe-key
3632   "\C-hc" gnus-article-describe-key-briefly
3633
3634   "\C-d" gnus-article-read-summary-keys
3635   "\M-*" gnus-article-read-summary-keys
3636   "\M-#" gnus-article-read-summary-keys
3637   "\M-^" gnus-article-read-summary-keys
3638   "\M-g" gnus-article-read-summary-keys)
3639
3640 ;; Define almost undefined keys to `gnus-article-read-summary-keys'.
3641 (let (keys)
3642   (let ((key 32))
3643     (while (<= key 127)
3644       (push (char-to-string key) keys)
3645       (incf key))
3646     (dolist (elem (accessible-keymaps gnus-summary-mode-map))
3647       (setq key (car elem))
3648       (when (and (> (length key) 0)
3649                  (not (eq 'menu-bar (aref key 0)))
3650                  (symbolp (lookup-key gnus-summary-mode-map key)))
3651         (push key keys))))
3652   (dolist (key keys)
3653     (unless (lookup-key gnus-article-mode-map key)
3654       (define-key gnus-article-mode-map key 'gnus-article-read-summary-keys))))
3655
3656 (defun gnus-article-make-menu-bar ()
3657   (unless (boundp 'gnus-article-commands-menu)
3658     (gnus-summary-make-menu-bar))
3659   (gnus-turn-off-edit-menu 'article)
3660   (unless (boundp 'gnus-article-article-menu)
3661     (easy-menu-define
3662      gnus-article-article-menu gnus-article-mode-map ""
3663      '("Article"
3664        ["Scroll forwards" gnus-article-goto-next-page t]
3665        ["Scroll backwards" gnus-article-goto-prev-page t]
3666        ["Show summary" gnus-article-show-summary t]
3667        ["Fetch Message-ID at point" gnus-article-refer-article t]
3668        ["Mail to address at point" gnus-article-mail t]
3669        ["Send a bug report" gnus-bug t]))
3670
3671     (easy-menu-define
3672      gnus-article-treatment-menu gnus-article-mode-map ""
3673      ;; Fixme: this should use :active (and maybe :visible).
3674      '("Treatment"
3675        ["Hide headers" gnus-article-hide-headers t]
3676        ["Hide signature" gnus-article-hide-signature t]
3677        ["Hide citation" gnus-article-hide-citation t]
3678        ["Treat overstrike" gnus-article-treat-overstrike t]
3679        ["Remove carriage return" gnus-article-remove-cr t]
3680        ["Remove leading whitespace" gnus-article-remove-leading-whitespace t]
3681        ["Treat html" gnus-article-wash-html t]
3682        ["Remove newlines from within URLs" gnus-article-unsplit-urls t]
3683        ["Decode HZ" gnus-article-decode-HZ t]))
3684
3685     ;; Note "Commands" menu is defined in gnus-sum.el for consistency
3686
3687     ;; Note "Post" menu is defined in gnus-sum.el for consistency
3688
3689     (gnus-run-hooks 'gnus-article-menu-hook)))
3690
3691 ;; Fixme: do something for the Emacs tool bar in Article mode a la
3692 ;; Summary.
3693
3694 (defun gnus-article-mode ()
3695   "Major mode for displaying an article.
3696
3697 All normal editing commands are switched off.
3698
3699 The following commands are available in addition to all summary mode
3700 commands:
3701 \\<gnus-article-mode-map>
3702 \\[gnus-article-next-page]\t Scroll the article one page forwards
3703 \\[gnus-article-prev-page]\t Scroll the article one page backwards
3704 \\[gnus-article-refer-article]\t Go to the article referred to by an article id near point
3705 \\[gnus-article-show-summary]\t Display the summary buffer
3706 \\[gnus-article-mail]\t Send a reply to the address near point
3707 \\[gnus-article-describe-briefly]\t Describe the current mode briefly
3708 \\[gnus-info-find-node]\t Go to the Gnus info node"
3709   (interactive)
3710   (gnus-simplify-mode-line)
3711   (setq mode-name "Article")
3712   (setq major-mode 'gnus-article-mode)
3713   (make-local-variable 'minor-mode-alist)
3714   (unless (assq 'gnus-show-mime minor-mode-alist)
3715     (push (list 'gnus-show-mime " MIME") minor-mode-alist))
3716   (use-local-map gnus-article-mode-map)
3717   (when (gnus-visual-p 'article-menu 'menu)
3718     (gnus-article-make-menu-bar))
3719   (gnus-update-format-specifications nil 'article-mode)
3720   (set (make-local-variable 'page-delimiter) gnus-page-delimiter)
3721   (make-local-variable 'gnus-page-broken)
3722   (make-local-variable 'gnus-button-marker-list)
3723   (make-local-variable 'gnus-article-current-summary)
3724   (make-local-variable 'gnus-article-mime-handles)
3725   (make-local-variable 'gnus-article-decoded-p)
3726   (make-local-variable 'gnus-article-mime-handle-alist)
3727   (make-local-variable 'gnus-article-wash-types)
3728   (make-local-variable 'gnus-article-image-alist)
3729   (make-local-variable 'gnus-article-charset)
3730   (make-local-variable 'gnus-article-ignored-charsets)
3731   (gnus-set-default-directory)
3732   (buffer-disable-undo)
3733   (setq buffer-read-only t)
3734   (set-syntax-table gnus-article-mode-syntax-table)
3735   (gnus-run-hooks 'gnus-article-mode-hook))
3736
3737 (defun gnus-article-setup-buffer ()
3738   "Initialize the article buffer."
3739   (let* ((name (if gnus-single-article-buffer "*Article*"
3740                  (concat "*Article " gnus-newsgroup-name "*")))
3741          (original
3742           (progn (string-match "\\*Article" name)
3743                  (concat " *Original Article"
3744                          (substring name (match-end 0))))))
3745     (setq gnus-article-buffer name)
3746     (setq gnus-original-article-buffer original)
3747     (setq gnus-article-mime-handle-alist nil)
3748     ;; This might be a variable local to the summary buffer.
3749     (unless gnus-single-article-buffer
3750       (save-excursion
3751         (set-buffer gnus-summary-buffer)
3752         (setq gnus-article-buffer name)
3753         (setq gnus-original-article-buffer original)
3754         (gnus-set-global-variables)))
3755     (gnus-article-setup-highlight-words)
3756     ;; Init original article buffer.
3757     (save-excursion
3758       (set-buffer (gnus-get-buffer-create gnus-original-article-buffer))
3759       (set-buffer-multibyte t)
3760       (setq major-mode 'gnus-original-article-mode)
3761       (make-local-variable 'gnus-original-article))
3762     (if (get-buffer name)
3763         (save-excursion
3764           (set-buffer name)
3765           (when (and gnus-article-edit-mode
3766                      (buffer-modified-p)
3767                      (not
3768                       (y-or-n-p "Article mode edit in progress; discard? ")))
3769             (error "Action aborted"))
3770           (set (make-local-variable 'gnus-article-edit-mode) nil)
3771           (buffer-disable-undo)
3772           (setq buffer-read-only t)
3773           (unless (eq major-mode 'gnus-article-mode)
3774             (gnus-article-mode))
3775           (current-buffer))
3776       (save-excursion
3777         (set-buffer (gnus-get-buffer-create name))
3778         (gnus-article-mode)
3779         (make-local-variable 'gnus-summary-buffer)
3780         (gnus-summary-set-local-parameters gnus-newsgroup-name)
3781         (current-buffer)))))
3782
3783 ;; Set article window start at LINE, where LINE is the number of lines
3784 ;; from the head of the article.
3785 (defun gnus-article-set-window-start (&optional line)
3786   (set-window-start
3787    (gnus-get-buffer-window gnus-article-buffer t)
3788    (save-excursion
3789      (set-buffer gnus-article-buffer)
3790      (goto-char (point-min))
3791      (if (not line)
3792          (point-min)
3793        (gnus-message 6 "Moved to bookmark")
3794        (search-forward "\n\n" nil t)
3795        (forward-line line)
3796        (point)))))
3797
3798 ;;; @@ article filters
3799 ;;;
3800
3801 (defun gnus-article-display-mime-message ()
3802   "Article display method for MIME message."
3803   ;; called from `gnus-original-article-buffer'.
3804   (let (charset all-headers)
3805     (with-current-buffer gnus-summary-buffer
3806       (setq charset default-mime-charset
3807             all-headers gnus-have-all-headers))
3808     (make-local-variable 'default-mime-charset)
3809     (setq default-mime-charset charset)
3810     (with-current-buffer (get-buffer-create gnus-article-buffer)
3811       (make-local-variable 'default-mime-charset)
3812       (setq default-mime-charset charset))
3813     (mime-display-message mime-message-structure
3814                           gnus-article-buffer nil gnus-article-mode-map)
3815     (when all-headers
3816       (gnus-article-hide-headers nil -1)))
3817   (run-hooks 'gnus-mime-article-prepare-hook))
3818
3819 (defun gnus-article-display-traditional-message ()
3820   "Article display method for traditional message."
3821   (set-buffer gnus-article-buffer)
3822   (let (buffer-read-only)
3823     (erase-buffer)
3824     (insert-buffer-substring gnus-original-article-buffer)))
3825
3826 (defun gnus-article-make-full-mail-header (&optional number charset)
3827   "Create a new mail header structure in a raw article buffer."
3828   (unless (and number charset)
3829     (save-current-buffer
3830       (set-buffer gnus-summary-buffer)
3831       (unless number
3832         (setq number (or (cdr gnus-article-current) 0)))
3833       (unless charset
3834         (setq charset (or default-mime-charset 'x-ctext)))))
3835   (goto-char (point-min))
3836   (let ((header-end (if (search-forward "\n\n" nil t)
3837                         (1- (point))
3838                       (goto-char (point-max))))
3839         (chars (- (point-max) (point)))
3840         (lines (count-lines (point) (point-max)))
3841         (default-mime-charset charset)
3842         xref)
3843     (narrow-to-region (point-min) header-end)
3844     (setq xref (std11-fetch-field "xref"))
3845     (prog1
3846         (make-full-mail-header
3847          number
3848          (std11-fetch-field "subject")
3849          (std11-fetch-field "from")
3850          (std11-fetch-field "date")
3851          (std11-fetch-field "message-id")
3852          (std11-fetch-field "references")
3853          chars
3854          lines
3855          (when xref (concat "Xref: " xref)))
3856       (widen))))
3857
3858 (defun gnus-article-prepare (article &optional all-headers header)
3859   "Prepare ARTICLE in article mode buffer.
3860 ARTICLE should either be an article number or a Message-ID.
3861 If ARTICLE is an id, HEADER should be the article headers.
3862 If ALL-HEADERS is non-nil, no headers are hidden."
3863   (save-excursion
3864     ;; Make sure we start in a summary buffer.
3865     (unless (eq major-mode 'gnus-summary-mode)
3866       (set-buffer gnus-summary-buffer))
3867     (setq gnus-summary-buffer (current-buffer))
3868     (let* ((gnus-article (if header (mail-header-number header) article))
3869            (summary-buffer (current-buffer))
3870            (gnus-tmp-internal-hook gnus-article-internal-prepare-hook)
3871            (group gnus-newsgroup-name)
3872            result)
3873       (save-excursion
3874         (gnus-article-setup-buffer)
3875         (set-buffer gnus-article-buffer)
3876         ;; Deactivate active regions.
3877         (when (and (boundp 'transient-mark-mode)
3878                    transient-mark-mode)
3879           (setq mark-active nil))
3880         (if (not (setq result (let ((buffer-read-only nil))
3881                                 (gnus-request-article-this-buffer
3882                                  article group))))
3883             ;; There is no such article.
3884             (save-excursion
3885               (when (and (numberp article)
3886                          (not (memq article gnus-newsgroup-sparse)))
3887                 (setq gnus-article-current
3888                       (cons gnus-newsgroup-name article))
3889                 (set-buffer gnus-summary-buffer)
3890                 (setq gnus-current-article article)
3891                 (if (memq article gnus-newsgroup-undownloaded)
3892                     (progn
3893                       (gnus-summary-set-agent-mark article)
3894                       (message "Message marked for downloading"))
3895                   (gnus-summary-mark-article article gnus-canceled-mark)
3896                   (unless (memq article gnus-newsgroup-sparse)
3897                     (gnus-error 1 "No such article (may have expired or been canceled)")))))
3898           (if (or (eq result 'pseudo)
3899                   (eq result 'nneething))
3900               (progn
3901                 (save-excursion
3902                   (set-buffer summary-buffer)
3903                   (push article gnus-newsgroup-history)
3904                   (setq gnus-last-article gnus-current-article
3905                         gnus-current-article 0
3906                         gnus-current-headers nil
3907                         gnus-article-current nil)
3908                   (if (eq result 'nneething)
3909                       (gnus-configure-windows 'summary)
3910                     (gnus-configure-windows 'article))
3911                   (gnus-set-global-variables))
3912                 (let ((gnus-article-mime-handle-alist-1
3913                        gnus-article-mime-handle-alist))
3914                   (gnus-set-mode-line 'article)))
3915             ;; The result from the `request' was an actual article -
3916             ;; or at least some text that is now displayed in the
3917             ;; article buffer.
3918             (when (and (numberp article)
3919                        (not (eq article gnus-current-article)))
3920               ;; Seems like a new article has been selected.
3921               ;; `gnus-current-article' must be an article number.
3922               (save-excursion
3923                 (set-buffer summary-buffer)
3924                 (push article gnus-newsgroup-history)
3925                 (setq gnus-last-article gnus-current-article
3926                       gnus-current-article article
3927                       gnus-current-headers
3928                       (gnus-summary-article-header gnus-current-article)
3929                       gnus-article-current
3930                       (cons gnus-newsgroup-name gnus-current-article))
3931                 (unless (vectorp gnus-current-headers)
3932                   (setq gnus-current-headers nil))
3933                 (gnus-summary-goto-subject gnus-current-article)
3934                 (when (gnus-summary-show-thread)
3935                   ;; If the summary buffer really was folded, the
3936                   ;; previous goto may not actually have gone to
3937                   ;; the right article, but the thread root instead.
3938                   ;; So we go again.
3939                   (gnus-summary-goto-subject gnus-current-article))
3940                 (gnus-run-hooks 'gnus-mark-article-hook)
3941                 (gnus-set-mode-line 'summary)
3942                 (when (gnus-visual-p 'article-highlight 'highlight)
3943                   (gnus-run-hooks 'gnus-visual-mark-article-hook))
3944                 ;; Set the global newsgroup variables here.
3945                 (gnus-set-global-variables)
3946                 (setq gnus-have-all-headers
3947                       (or all-headers gnus-show-all-headers))))
3948             (save-excursion
3949               (gnus-configure-windows 'article))
3950             (when (or (numberp article)
3951                       (stringp article))
3952               (gnus-article-prepare-display)
3953               ;; Do page break.
3954               (goto-char (point-min))
3955               (setq gnus-page-broken
3956                     (when gnus-break-pages
3957                       (gnus-narrow-to-page)
3958                       t)))
3959             (let ((gnus-article-mime-handle-alist-1
3960                    gnus-article-mime-handle-alist))
3961               (gnus-set-mode-line 'article))
3962             (article-goto-body)
3963             (unless (bobp)
3964               (forward-line -1))
3965             (set-window-point (get-buffer-window (current-buffer)) (point))
3966             (gnus-configure-windows 'article)
3967             t))))))
3968
3969 (defun gnus-article-prepare-mime-display (&optional number)
3970   (goto-char (point-min))
3971   (when (re-search-forward "^[^\t ]+:" nil t)
3972     (goto-char (match-beginning 0)))
3973   (let ((entity (if (eq 1 (point-min))
3974                     (get-text-property 1 'mime-view-entity)
3975                   (get-text-property (point) 'mime-view-entity)))
3976         last-entity child-entity next type)
3977     (setq child-entity (mime-entity-children entity))
3978     (if child-entity
3979         (setq last-entity (nth (1- (length child-entity))
3980                                child-entity))
3981       (setq last-entity entity))
3982     (save-restriction
3983       (narrow-to-region (point)
3984                         (if (search-forward "\n\n" nil t)
3985                             (point)
3986                           (point-max)))
3987       (gnus-treat-article 'head)
3988       (put-text-property (point-min) (point-max) 'article-treated-header t)
3989       (goto-char (point-max)))
3990     (while (and (not (eobp)) entity)
3991       (setq next (set-marker
3992                   (make-marker)
3993                   (next-single-property-change (point) 'mime-view-entity
3994                                                nil (point-max))))
3995       (let ((types (mime-entity-content-type entity)))
3996         (while (eq 'multipart (mime-content-type-primary-type types))
3997           (setq entity (car (mime-entity-children entity))
3998                 types (mime-entity-content-type entity)))
3999         (when types
4000           (setq type (format "%s/%s"
4001                              (mime-content-type-primary-type types)
4002                              (mime-content-type-subtype types)))))
4003       (if (string-equal type "message/rfc822")
4004           (progn
4005             (setq next (point))
4006             (let ((children (mime-entity-children entity))
4007                   last-children)
4008               (when children
4009                 (setq last-children (nth (1- (length children)) children))
4010                 (while
4011                     (and
4012                      (not (eq last-children
4013                               (get-text-property next 'mime-view-entity)))
4014                      (setq next
4015                            (next-single-property-change next
4016                                                         'mime-view-entity
4017                                                         nil (point-max)))))))
4018             (setq next (next-single-property-change next 'mime-view-entity
4019                                                     nil (point-max)))
4020             (save-restriction
4021               (narrow-to-region (point) next)
4022               (gnus-article-prepare-mime-display)
4023               (goto-char (point-max)))
4024             (setq entity (get-text-property (point) 'mime-view-entity)))
4025         (save-restriction
4026           (narrow-to-region (point) next)
4027           ;; Kludge. We have to count true number, but for now,
4028           ;; part number is here only to achieve `last'.
4029           (gnus-treat-article nil 1
4030                               (if (eq entity last-entity)
4031                                   1 2)
4032                               type)
4033           (goto-char (point-max)))
4034         (setq entity (get-text-property next 'mime-view-entity))))))
4035
4036 ;;;###autoload
4037 (defun gnus-article-prepare-display ()
4038   "Make the current buffer look like a nice article."
4039   (let ((gnus-article-buffer (current-buffer))
4040         buffer-read-only)
4041     (unless (eq major-mode 'gnus-article-mode)
4042       (gnus-article-mode))
4043     (setq buffer-read-only nil
4044           gnus-button-marker-list nil
4045           gnus-article-wash-types nil
4046           gnus-article-image-alist nil)
4047     (save-restriction
4048       (widen)
4049       (static-if (featurep 'xemacs)
4050           (map-extents (lambda (extent maparg) (delete-extent extent)))
4051         (let ((lists (overlay-lists)))
4052           (dolist (overlay (nconc (car lists) (cdr lists)))
4053             (delete-overlay overlay)))))
4054     (gnus-run-hooks 'gnus-tmp-internal-hook))
4055   (let ((show-mime (unless (member gnus-newsgroup-name '("nndraft:delayed"
4056                                                          "nndraft:drafts"))
4057                      gnus-show-mime))
4058         (inhibit-read-only t))
4059     (set-buffer gnus-original-article-buffer)
4060     ;; Display message.
4061     (setq mime-message-structure gnus-current-headers)
4062     (mime-buffer-entity-set-buffer-internal mime-message-structure
4063                                             gnus-original-article-buffer)
4064     (mime-entity-set-representation-type-internal mime-message-structure
4065                                                   'mime-buffer-entity)
4066     (luna-send mime-message-structure 'initialize-instance
4067                mime-message-structure)
4068     (if show-mime
4069         (let (mime-display-header-hook mime-display-text/plain-hook)
4070           (funcall gnus-article-display-method-for-mime))
4071       (funcall gnus-article-display-method-for-traditional))
4072     ;; Call the treatment functions.
4073     (save-restriction
4074       (widen)
4075       (if show-mime
4076           (gnus-article-prepare-mime-display)
4077         (narrow-to-region (goto-char (point-min))
4078                           (if (search-forward "\n\n" nil t)
4079                               (point)
4080                             (point-max)))
4081         (gnus-treat-article 'head)
4082         (put-text-property (point-min) (point-max) 'article-treated-header t)
4083         (goto-char (point-max))
4084         (widen)
4085         (narrow-to-region (point) (point-max))
4086         (gnus-treat-article nil))
4087       (put-text-property (point-min) (point-max) 'read-only nil)))
4088   (gnus-run-hooks 'gnus-article-prepare-hook))
4089
4090 (defun gnus-article-decode-article-as-default-mime-charset ()
4091   "Decode an article as `default-mime-charset'.  It won't work if the
4092 value of the variable `gnus-show-mime' is non-nil."
4093   (unless (or gnus-show-mime
4094               (member gnus-newsgroup-name '("nndraft:delayed"
4095                                             "nndraft:drafts")))
4096     (set (make-local-variable 'default-mime-charset)
4097          (with-current-buffer gnus-summary-buffer
4098            default-mime-charset))
4099     (decode-mime-charset-region (point-min) (point-max)
4100                                 default-mime-charset)))
4101
4102 ;;;
4103 ;;; Gnus MIME viewing functions
4104 ;;;
4105
4106 (defvar gnus-mime-button-line-format "%{%([%p. %d%T]%)%}%e\n"
4107   "Format of the MIME buttons.
4108
4109 Valid specifiers include:
4110 %t  The MIME type
4111 %T  MIME type, along with additional info
4112 %n  The `name' parameter
4113 %d  The description, if any
4114 %l  The length of the encoded part
4115 %p  The part identifier number
4116 %e  Dots if the part isn't displayed
4117
4118 General format specifiers can also be used.  See Info node
4119 `(gnus)Formatting Variables'.")
4120
4121 (defvar gnus-mime-button-line-format-alist
4122   '((?t gnus-tmp-type ?s)
4123     (?T gnus-tmp-type-long ?s)
4124     (?n gnus-tmp-name ?s)
4125     (?d gnus-tmp-description ?s)
4126     (?p gnus-tmp-id ?s)
4127     (?l gnus-tmp-length ?d)
4128     (?e gnus-tmp-dots ?s)))
4129
4130 (defvar gnus-mime-button-commands
4131   '((gnus-article-press-button "\r" "Toggle Display")
4132     (gnus-mime-view-part "v" "View Interactively...")
4133     (gnus-mime-view-part-as-type "t" "View As Type...")
4134     (gnus-mime-view-part-as-charset "C" "View As charset...")
4135     (gnus-mime-save-part "o" "Save...")
4136     (gnus-mime-save-part-and-strip "\C-o" "Save and Strip")
4137     (gnus-mime-copy-part "c" "View As Text, In Other Buffer")
4138     (gnus-mime-inline-part "i" "View As Text, In This Buffer")
4139     (gnus-mime-view-part-internally "E" "View Internally")
4140     (gnus-mime-view-part-externally "e" "View Externally")
4141     (gnus-mime-print-part "p" "Print")
4142     (gnus-mime-pipe-part "|" "Pipe To Command...")
4143     (gnus-mime-action-on-part "." "Take action on the part")))
4144
4145 (defun gnus-article-mime-part-status ()
4146   (with-current-buffer gnus-article-buffer
4147     (let ((entity (get-text-property (point-min) 'mime-view-entity))
4148           children)
4149       (if (and entity
4150                (setq children (mime-entity-children entity))
4151                (setq children (length children)))
4152           (if (eq 1 children)
4153               " (1 part)"
4154             (format " (%d parts)" children))
4155         ""))))
4156
4157 (defvar gnus-mime-button-map
4158   (let ((map (make-sparse-keymap)))
4159     (unless (>= (string-to-number emacs-version) 21)
4160       ;; XEmacs doesn't care.
4161       (set-keymap-parent map gnus-article-mode-map))
4162     (define-key map gnus-mouse-2 'gnus-article-push-button)
4163     (define-key map gnus-down-mouse-3 'gnus-mime-button-menu)
4164     (dolist (c gnus-mime-button-commands)
4165       (define-key map (cadr c) (car c)))
4166     map))
4167
4168 (defun gnus-mime-button-menu (event)
4169   "Construct a context-sensitive menu of MIME commands."
4170   (interactive "e")
4171   (save-window-excursion
4172     (let ((pos (event-start event)))
4173       (select-window (posn-window pos))
4174       (goto-char (posn-point pos))
4175       (gnus-article-check-buffer)
4176       (let ((response (x-popup-menu
4177                        t `("MIME Part"
4178                            ("" ,@(mapcar (lambda (c)
4179                                            (cons (caddr c) (car c)))
4180                                          gnus-mime-button-commands))))))
4181         (if response
4182             (call-interactively response))))))
4183
4184 (defun gnus-mime-view-all-parts (&optional handles)
4185   "View all the MIME parts."
4186   (interactive)
4187   (save-current-buffer
4188     (set-buffer gnus-article-buffer)
4189     (let ((handles (or handles gnus-article-mime-handles))
4190           (mail-parse-charset gnus-newsgroup-charset)
4191           (mail-parse-ignored-charsets
4192            (with-current-buffer gnus-summary-buffer
4193              gnus-newsgroup-ignored-charsets)))
4194       (when handles
4195         (mm-remove-parts handles)
4196         (goto-char (point-min))
4197         (or (search-forward "\n\n") (goto-char (point-max)))
4198         (let (buffer-read-only)
4199           (delete-region (point) (point-max))
4200           (mm-display-parts handles))))))
4201
4202 (defun gnus-mime-save-part-and-strip ()
4203   "Save the MIME part under point then replace it with an external body."
4204   (interactive)
4205   (gnus-article-check-buffer)
4206   (let* ((data (get-text-property (point) 'gnus-data))
4207          file param
4208          (handles gnus-article-mime-handles))
4209     (if (mm-multiple-handles gnus-article-mime-handles)
4210         (error "This function is not implemented"))
4211     (setq file (and data (mm-save-part data)))
4212     (when file
4213       (with-current-buffer (mm-handle-buffer data)
4214         (erase-buffer)
4215         (insert "Content-Type: " (mm-handle-media-type data))
4216         (mml-insert-parameter-string (cdr (mm-handle-type data))
4217                                      '(charset))
4218         (insert "\n")
4219         (insert "Content-ID: " (message-make-message-id) "\n")
4220         (insert "Content-Transfer-Encoding: binary\n")
4221         (insert "\n"))
4222       (setcdr data
4223               (cdr (mm-make-handle nil
4224                                    `("message/external-body"
4225                                      (access-type . "LOCAL-FILE")
4226                                      (name . ,file)))))
4227       (set-buffer gnus-summary-buffer)
4228       (gnus-article-edit-article
4229        `(lambda ()
4230           (erase-buffer)
4231           (let ((mail-parse-charset (or gnus-article-charset
4232                                         ',gnus-newsgroup-charset))
4233                 (mail-parse-ignored-charsets
4234                  (or gnus-article-ignored-charsets
4235                      ',gnus-newsgroup-ignored-charsets))
4236                 (mbl mml-buffer-list))
4237             (setq mml-buffer-list nil)
4238             (insert-buffer gnus-original-article-buffer)
4239             (mime-to-mml ',handles)
4240             (setq gnus-article-mime-handles nil)
4241             (let ((mbl1 mml-buffer-list))
4242               (setq mml-buffer-list mbl)
4243               (set (make-local-variable 'mml-buffer-list) mbl1))
4244             ;; LOCAL argument of add-hook differs between GNU Emacs
4245             ;; and XEmacs. make-local-hook makes sure they are local.
4246             (make-local-hook 'kill-buffer-hook)
4247             (add-hook 'kill-buffer-hook 'mml-destroy-buffers t t)))
4248        `(lambda (no-highlight)
4249           (let ((mail-parse-charset (or gnus-article-charset
4250                                         ',gnus-newsgroup-charset))
4251                 (message-options message-options)
4252                 (message-options-set-recipient)
4253                 (mail-parse-ignored-charsets
4254                  (or gnus-article-ignored-charsets
4255                      ',gnus-newsgroup-ignored-charsets)))
4256             (mml-to-mime)
4257             (mml-destroy-buffers)
4258             (remove-hook 'kill-buffer-hook
4259                          'mml-destroy-buffers t)
4260             (kill-local-variable 'mml-buffer-list))
4261           (gnus-summary-edit-article-done
4262            ,(or (mail-header-references gnus-current-headers) "")
4263            ,(gnus-group-read-only-p)
4264            ,gnus-summary-buffer no-highlight))))))
4265
4266 (defun gnus-mime-save-part ()
4267   "Save the MIME part under point."
4268   (interactive)
4269   (gnus-article-check-buffer)
4270   (let ((data (get-text-property (point) 'gnus-data)))
4271     (when data
4272       (mm-save-part data))))
4273
4274 (defun gnus-mime-pipe-part ()
4275   "Pipe the MIME part under point to a process."
4276   (interactive)
4277   (gnus-article-check-buffer)
4278   (let ((data (get-text-property (point) 'gnus-data)))
4279     (when data
4280       (mm-pipe-part data))))
4281
4282 (defun gnus-mime-view-part ()
4283   "Interactively choose a viewing method for the MIME part under point."
4284   (interactive)
4285   (gnus-article-check-buffer)
4286   (let ((data (get-text-property (point) 'gnus-data)))
4287     (when data
4288       (setq gnus-article-mime-handles
4289             (mm-merge-handles
4290              gnus-article-mime-handles (setq data (copy-sequence data))))
4291       (mm-interactively-view-part data))))
4292
4293 (defun gnus-mime-view-part-as-type-internal ()
4294   (gnus-article-check-buffer)
4295   (let* ((name (mail-content-type-get
4296                 (mm-handle-type (get-text-property (point) 'gnus-data))
4297                 'name))
4298          (def-type (and name (mm-default-file-encoding name))))
4299     (and def-type (cons def-type 0))))
4300
4301 (defun gnus-mime-view-part-as-type (&optional mime-type)
4302   "Choose a MIME media type, and view the part as such."
4303   (interactive)
4304   (unless mime-type
4305     (setq mime-type (completing-read
4306                      "View as MIME type: "
4307                      (mapcar #'list (mailcap-mime-types))
4308                      nil nil
4309                      (gnus-mime-view-part-as-type-internal))))
4310   (gnus-article-check-buffer)
4311   (let ((handle (get-text-property (point) 'gnus-data)))
4312     (when handle
4313       (setq handle
4314             (mm-make-handle (mm-handle-buffer handle)
4315                             (cons mime-type (cdr (mm-handle-type handle)))
4316                             (mm-handle-encoding handle)
4317                             (mm-handle-undisplayer handle)
4318                             (mm-handle-disposition handle)
4319                             (mm-handle-description handle)
4320                             nil
4321                             (mm-handle-id handle)))
4322       (setq gnus-article-mime-handles
4323             (mm-merge-handles gnus-article-mime-handles handle))
4324       (gnus-mm-display-part handle))))
4325
4326 (eval-when-compile
4327   (require 'jka-compr))
4328
4329 ;; jka-compr.el uses a "sh -c" to direct stderr to err-file, but these days
4330 ;; emacs can do that itself.
4331 ;;
4332 (defun gnus-mime-jka-compr-maybe-uncompress ()
4333   "Uncompress the current buffer if `auto-compression-mode' is enabled.
4334 The uncompress method used is derived from `buffer-file-name'."
4335   (when (and (fboundp 'jka-compr-installed-p)
4336              (jka-compr-installed-p))
4337     (let ((info (jka-compr-get-compression-info buffer-file-name)))
4338       (when info
4339         (let ((basename (file-name-nondirectory buffer-file-name))
4340               (args     (jka-compr-info-uncompress-args    info))
4341               (prog     (jka-compr-info-uncompress-program info))
4342               (message  (jka-compr-info-uncompress-message info))
4343               (err-file (jka-compr-make-temp-name)))
4344           (if message
4345               (message "%s %s..." message basename))
4346           (unwind-protect
4347               (unless (memq (apply 'call-process-region
4348                                    (point-min) (point-max) 
4349                                    prog
4350                                    t (list t err-file) nil
4351                                    args)
4352                             jka-compr-acceptable-retval-list)
4353                 (jka-compr-error prog args basename message err-file))
4354             (jka-compr-delete-temp-file err-file)))))))
4355
4356 (defun gnus-mime-copy-part (&optional handle)
4357   "Put the MIME part under point into a new buffer."
4358   (interactive)
4359   (gnus-article-check-buffer)
4360   (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
4361          (contents (and handle (mm-get-part handle)))
4362          (base (and handle
4363                     (file-name-nondirectory
4364                      (or
4365                       (mail-content-type-get (mm-handle-type handle) 'name)
4366                       (mail-content-type-get (mm-handle-disposition handle)
4367                                              'filename)
4368                       "*decoded*"))))
4369          (buffer (and base (generate-new-buffer base))))
4370     (when contents
4371       (switch-to-buffer buffer)
4372       (insert contents)
4373       ;; We do it this way to make `normal-mode' set the appropriate mode.
4374       (unwind-protect
4375           (progn
4376             (setq buffer-file-name (expand-file-name base))
4377             (gnus-mime-jka-compr-maybe-uncompress)
4378             (normal-mode))
4379         (setq buffer-file-name nil))
4380       (goto-char (point-min)))))
4381
4382 (defun gnus-mime-print-part (&optional handle filename)
4383   "Print the MIME part under point."
4384   (interactive (list nil (ps-print-preprint current-prefix-arg)))
4385   (gnus-article-check-buffer)
4386   (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
4387          (contents (and handle (mm-get-part handle)))
4388          (file (mm-make-temp-file (expand-file-name "mm." mm-tmp-directory)))
4389          (printer (mailcap-mime-info (mm-handle-type handle) "print")))
4390     (when contents
4391         (if printer
4392             (unwind-protect
4393                 (progn
4394                   (with-temp-file file
4395                     (insert contents))
4396                   (call-process shell-file-name nil
4397                                 (generate-new-buffer " *mm*")
4398                                 nil
4399                                 shell-command-switch
4400                                 (mm-mailcap-command
4401                                  printer file (mm-handle-type handle))))
4402               (delete-file file))
4403           (with-temp-buffer
4404             (insert contents)
4405             (gnus-print-buffer))
4406           (ps-despool filename)))))
4407
4408 (defun gnus-mime-inline-part (&optional handle arg)
4409   "Insert the MIME part under point into the current buffer."
4410   (interactive (list nil current-prefix-arg))
4411   (gnus-article-check-buffer)
4412   (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
4413          contents charset
4414          (b (point))
4415          buffer-read-only)
4416     (when handle
4417       (if (and (not arg) (mm-handle-undisplayer handle))
4418           (mm-remove-part handle)
4419         (setq contents (mm-get-part handle))
4420         (cond
4421          ((not arg)
4422           (setq charset (or (mail-content-type-get
4423                              (mm-handle-type handle) 'charset)
4424                             gnus-newsgroup-charset)))
4425          ((numberp arg)
4426           (if (mm-handle-undisplayer handle)
4427               (mm-remove-part handle))
4428           (setq charset
4429                 (or (cdr (assq arg
4430                                gnus-summary-show-article-charset-alist))
4431                     (mm-read-coding-system "Charset: ")))))
4432         (forward-line 2)
4433         (mm-insert-inline handle
4434                           (if (and charset
4435                                    (setq charset (mm-charset-to-coding-system
4436                                                   charset))
4437                                    (not (eq charset 'ascii)))
4438                               (mm-decode-coding-string contents charset)
4439                             contents))
4440         (goto-char b)))))
4441
4442 (defun gnus-mime-view-part-as-charset (&optional handle arg)
4443   "Insert the MIME part under point into the current buffer using the
4444 specified charset."
4445   (interactive (list nil current-prefix-arg))
4446   (gnus-article-check-buffer)
4447   (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
4448          contents charset
4449          (b (point))
4450          buffer-read-only)
4451     (when handle
4452       (if (mm-handle-undisplayer handle)
4453           (mm-remove-part handle))
4454       (let ((gnus-newsgroup-charset
4455              (or (cdr (assq arg
4456                             gnus-summary-show-article-charset-alist))
4457                  (mm-read-coding-system "Charset: ")))
4458             (gnus-newsgroup-ignored-charsets 'gnus-all))
4459         (gnus-article-press-button)))))
4460
4461 (defun gnus-mime-view-part-externally (&optional handle)
4462   "View the MIME part under point with an external viewer."
4463   (interactive)
4464   (gnus-article-check-buffer)
4465   (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
4466          (mm-user-display-methods nil)
4467          (mm-inlined-types nil)
4468          (mail-parse-charset gnus-newsgroup-charset)
4469          (mail-parse-ignored-charsets
4470           (save-excursion (set-buffer gnus-summary-buffer)
4471                           gnus-newsgroup-ignored-charsets)))
4472     (when handle
4473       (if (mm-handle-undisplayer handle)
4474           (mm-remove-part handle)
4475         (mm-display-part handle)))))
4476
4477 (defun gnus-mime-view-part-internally (&optional handle)
4478   "View the MIME part under point with an internal viewer.
4479 If no internal viewer is available, use an external viewer."
4480   (interactive)
4481   (gnus-article-check-buffer)
4482   (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
4483          (mm-inlined-types '(".*"))
4484          (mm-inline-large-images t)
4485          (mail-parse-charset gnus-newsgroup-charset)
4486          (mail-parse-ignored-charsets
4487           (save-excursion (set-buffer gnus-summary-buffer)
4488                           gnus-newsgroup-ignored-charsets)))
4489     (when handle
4490       (if (mm-handle-undisplayer handle)
4491           (mm-remove-part handle)
4492         (mm-display-part handle)))))
4493
4494 (defun gnus-mime-action-on-part (&optional action)
4495   "Do something with the MIME attachment at \(point\)."
4496   (interactive
4497    (list (completing-read "Action: " gnus-mime-action-alist)))
4498   (gnus-article-check-buffer)
4499   (let ((action-pair (assoc action gnus-mime-action-alist)))
4500     (if action-pair
4501         (funcall (cdr action-pair)))))
4502
4503 (defun gnus-article-part-wrapper (n function)
4504   (save-current-buffer
4505     (set-buffer gnus-article-buffer)
4506     (when (> n (length gnus-article-mime-handle-alist))
4507       (error "No such part"))
4508     (gnus-article-goto-part n)
4509     (let ((handle (cdr (assq n gnus-article-mime-handle-alist))))
4510       (funcall function handle))))
4511
4512 (defun gnus-article-pipe-part (n)
4513   "Pipe MIME part N, which is the numerical prefix."
4514   (interactive "p")
4515   (gnus-article-part-wrapper n 'mm-pipe-part))
4516
4517 (defun gnus-article-save-part (n)
4518   "Save MIME part N, which is the numerical prefix."
4519   (interactive "p")
4520   (gnus-article-part-wrapper n 'mm-save-part))
4521
4522 (defun gnus-article-interactively-view-part (n)
4523   "View MIME part N interactively, which is the numerical prefix."
4524   (interactive "p")
4525   (gnus-article-part-wrapper n 'mm-interactively-view-part))
4526
4527 (defun gnus-article-copy-part (n)
4528   "Copy MIME part N, which is the numerical prefix."
4529   (interactive "p")
4530   (gnus-article-part-wrapper n 'gnus-mime-copy-part))
4531
4532 (defun gnus-article-view-part-as-charset (n)
4533   "Copy MIME part N, which is the numerical prefix."
4534   (interactive "p")
4535   (gnus-article-part-wrapper n 'gnus-mime-view-part-as-charset))
4536
4537 (defun gnus-article-view-part-externally (n)
4538   "View MIME part N externally, which is the numerical prefix."
4539   (interactive "p")
4540   (gnus-article-part-wrapper n 'gnus-mime-view-part-externally))
4541
4542 (defun gnus-article-inline-part (n)
4543   "Inline MIME part N, which is the numerical prefix."
4544   (interactive "p")
4545   (gnus-article-part-wrapper n 'gnus-mime-inline-part))
4546
4547 (defun gnus-article-mime-match-handle-first (condition)
4548   (if condition
4549       (let ((alist gnus-article-mime-handle-alist) ihandle n)
4550         (while (setq ihandle (pop alist))
4551           (if (and (cond
4552                     ((functionp condition)
4553                      (funcall condition (cdr ihandle)))
4554                     ((eq condition 'undisplayed)
4555                      (not (or (mm-handle-undisplayer (cdr ihandle))
4556                               (equal (mm-handle-media-type (cdr ihandle))
4557                                      "multipart/alternative"))))
4558                     ((eq condition 'undisplayed-alternative)
4559                      (not (mm-handle-undisplayer (cdr ihandle))))
4560                     (t t))
4561                    (gnus-article-goto-part (car ihandle))
4562                    (or (not n) (< (car ihandle) n)))
4563               (setq n (car ihandle))))
4564         (or n 1))
4565     1))
4566
4567 (defun gnus-article-view-part (&optional n)
4568   "View MIME part N, which is the numerical prefix."
4569   (interactive "P")
4570   (save-current-buffer
4571     (set-buffer gnus-article-buffer)
4572     (or (numberp n) (setq n (gnus-article-mime-match-handle-first
4573                              gnus-article-mime-match-handle-function)))
4574     (when (> n (length gnus-article-mime-handle-alist))
4575       (error "No such part"))
4576     (let ((handle (cdr (assq n gnus-article-mime-handle-alist))))
4577       (when (gnus-article-goto-part n)
4578         (if (equal (car handle) "multipart/alternative")
4579             (gnus-article-press-button)
4580           (when (eq (gnus-mm-display-part handle) 'internal)
4581             (gnus-set-window-start)))))))
4582
4583 (defsubst gnus-article-mime-total-parts ()
4584   (if (bufferp (car gnus-article-mime-handles))
4585       1 ;; single part
4586     (1- (length gnus-article-mime-handles))))
4587
4588 (defun gnus-mm-display-part (handle)
4589   "Display HANDLE and fix MIME button."
4590   (let ((id (get-text-property (point) 'gnus-part))
4591         (point (point))
4592         buffer-read-only)
4593     (forward-line 1)
4594     (prog1
4595         (let ((window (selected-window))
4596               (mail-parse-charset gnus-newsgroup-charset)
4597               (mail-parse-ignored-charsets
4598                (if (gnus-buffer-live-p gnus-summary-buffer)
4599                    (save-excursion
4600                      (set-buffer gnus-summary-buffer)
4601                      gnus-newsgroup-ignored-charsets)
4602                  nil)))
4603           (save-excursion
4604             (unwind-protect
4605                 (let ((win (gnus-get-buffer-window (current-buffer) t))
4606                       (beg (point)))
4607                   (when win
4608                     (select-window win))
4609                   (goto-char point)
4610                   (forward-line)
4611                   (if (mm-handle-displayed-p handle)
4612                       ;; This will remove the part.
4613                       (mm-display-part handle)
4614                     (save-restriction
4615                       (narrow-to-region (point)
4616                                         (if (eobp) (point) (1+ (point))))
4617                       (mm-display-part handle)
4618                       ;; We narrow to the part itself and
4619                       ;; then call the treatment functions.
4620                       (goto-char (point-min))
4621                       (forward-line 1)
4622                       (narrow-to-region (point) (point-max))
4623                       (gnus-treat-article
4624                        nil id
4625                        (gnus-article-mime-total-parts)
4626                        (mm-handle-media-type handle)))))
4627               (if (window-live-p window)
4628                   (select-window window)))))
4629       (goto-char point)
4630       (delete-region (gnus-point-at-bol) (progn (forward-line 1) (point)))
4631       (gnus-insert-mime-button
4632        handle id (list (mm-handle-displayed-p handle)))
4633       (goto-char point))))
4634
4635 (defun gnus-article-goto-part (n)
4636   "Go to MIME part N."
4637   (let ((point (text-property-any (point-min) (point-max) 'gnus-part n)))
4638     (when point
4639       (goto-char point))))
4640
4641 (defun gnus-insert-mime-button (handle gnus-tmp-id &optional displayed)
4642   (let ((gnus-tmp-name
4643          (or (mail-content-type-get (mm-handle-type handle) 'name)
4644              (mail-content-type-get (mm-handle-disposition handle) 'filename)
4645              (mail-content-type-get (mm-handle-type handle) 'url)
4646              ""))
4647         (gnus-tmp-type (mm-handle-media-type handle))
4648         (gnus-tmp-description
4649          (mail-decode-encoded-word-string (or (mm-handle-description handle)
4650                                               "")))
4651         (gnus-tmp-dots
4652          (if (if displayed (car displayed)
4653                (mm-handle-displayed-p handle))
4654              "" "..."))
4655         (gnus-tmp-length (with-current-buffer (mm-handle-buffer handle)
4656                            (buffer-size)))
4657         gnus-tmp-type-long b e)
4658     (when (string-match ".*/" gnus-tmp-name)
4659       (setq gnus-tmp-name (replace-match "" t t gnus-tmp-name)))
4660     (setq gnus-tmp-type-long (concat gnus-tmp-type
4661                                      (and (not (equal gnus-tmp-name ""))
4662                                           (concat "; " gnus-tmp-name))))
4663     (unless (equal gnus-tmp-description "")
4664       (setq gnus-tmp-type-long (concat " --- " gnus-tmp-type-long)))
4665     (unless (bolp)
4666       (insert "\n"))
4667     (setq b (point))
4668     (gnus-eval-format
4669      gnus-mime-button-line-format gnus-mime-button-line-format-alist
4670      `(,@(gnus-local-map-property gnus-mime-button-map)
4671          gnus-callback gnus-mm-display-part
4672          gnus-part ,gnus-tmp-id
4673          article-type annotation
4674          gnus-data ,handle))
4675     (setq e (point))
4676     (widget-convert-button
4677      'link b e
4678      :mime-handle handle
4679      :action 'gnus-widget-press-button
4680      :button-keymap gnus-mime-button-map
4681      :help-echo
4682      (lambda (widget/window &optional overlay pos)
4683        ;; Needed to properly clear the message due to a bug in
4684        ;; wid-edit (XEmacs only).
4685        (if (boundp 'help-echo-owns-message)
4686            (setq help-echo-owns-message t))
4687        (format
4688         "%S: %s the MIME part; %S: more options"
4689         (aref gnus-mouse-2 0)
4690         ;; XEmacs will get a single widget arg; Emacs 21 will get
4691         ;; window, overlay, position.
4692         (if (mm-handle-displayed-p
4693              (if overlay
4694                  (with-current-buffer (gnus-overlay-buffer overlay)
4695                    (widget-get (widget-at (gnus-overlay-start overlay))
4696                                :mime-handle))
4697                (widget-get widget/window :mime-handle)))
4698             "hide" "show")
4699         (aref gnus-down-mouse-3 0))))))
4700
4701 (defun gnus-widget-press-button (elems el)
4702   (goto-char (widget-get elems :from))
4703   (gnus-article-press-button))
4704
4705 (defvar gnus-displaying-mime nil)
4706
4707 (defun gnus-display-mime (&optional ihandles)
4708   "Display the MIME parts."
4709   (save-excursion
4710     (save-selected-window
4711       (let ((window (get-buffer-window gnus-article-buffer))
4712             (point (point)))
4713         (when window
4714           (select-window window)
4715           ;; We have to do this since selecting the window
4716           ;; may change the point.  So we set the window point.
4717           (set-window-point window point)))
4718       (let* ((handles (or ihandles (mm-dissect-buffer
4719                                     nil gnus-article-loose-mime)
4720                           (mm-uu-dissect)))
4721              buffer-read-only handle name type b e display)
4722         (when (and (not ihandles)
4723                    (not gnus-displaying-mime))
4724           ;; Top-level call; we clean up.
4725           (when gnus-article-mime-handles
4726             (mm-destroy-parts gnus-article-mime-handles)
4727             (setq gnus-article-mime-handle-alist nil));; A trick.
4728           (setq gnus-article-mime-handles handles)
4729           ;; We allow users to glean info from the handles.
4730           (when gnus-article-mime-part-function
4731             (gnus-mime-part-function handles)))
4732         (if (and handles
4733                  (or (not (stringp (car handles)))
4734                      (cdr handles)))
4735             (progn
4736               (when (and (not ihandles)
4737                          (not gnus-displaying-mime))
4738                 ;; Clean up for mime parts.
4739                 (article-goto-body)
4740                 (delete-region (point) (point-max)))
4741               (let ((gnus-displaying-mime t))
4742                 (gnus-mime-display-part handles)))
4743           (save-restriction
4744             (article-goto-body)
4745             (narrow-to-region (point) (point-max))
4746             (gnus-treat-article nil 1 1)
4747             (widen)))
4748         (unless ihandles
4749           ;; Highlight the headers.
4750           (save-excursion
4751             (save-restriction
4752               (article-goto-body)
4753               (narrow-to-region (point-min) (point))
4754               (gnus-treat-article 'head))))))))
4755
4756 (defvar gnus-mime-display-multipart-as-mixed nil)
4757 (defvar gnus-mime-display-multipart-alternative-as-mixed nil)
4758 (defvar gnus-mime-display-multipart-related-as-mixed nil)
4759
4760 (defun gnus-mime-display-part (handle)
4761   (cond
4762    ;; Single part.
4763    ((not (stringp (car handle)))
4764     (gnus-mime-display-single handle))
4765    ;; User-defined multipart
4766    ((cdr (assoc (car handle) gnus-mime-multipart-functions))
4767     (funcall (cdr (assoc (car handle) gnus-mime-multipart-functions))
4768              handle))
4769    ;; multipart/alternative
4770    ((and (equal (car handle) "multipart/alternative")
4771          (not (or gnus-mime-display-multipart-as-mixed
4772                   gnus-mime-display-multipart-alternative-as-mixed)))
4773     (let ((id (1+ (length gnus-article-mime-handle-alist))))
4774       (push (cons id handle) gnus-article-mime-handle-alist)
4775       (gnus-mime-display-alternative (cdr handle) nil nil id)))
4776    ;; multipart/related
4777    ((and (equal (car handle) "multipart/related")
4778          (not (or gnus-mime-display-multipart-as-mixed
4779                   gnus-mime-display-multipart-related-as-mixed)))
4780     ;;;!!!We should find the start part, but we just default
4781     ;;;!!!to the first part.
4782     ;;(gnus-mime-display-part (cadr handle))
4783     ;;;!!! Most multipart/related is an HTML message plus images.
4784     ;;;!!! Unfortunately we are unable to let W3 display those
4785     ;;;!!! included images, so we just display it as a mixed multipart.
4786     ;;(gnus-mime-display-mixed (cdr handle))
4787     ;;;!!! No, w3 can display everything just fine.
4788     (gnus-mime-display-part (cadr handle)))
4789    ((equal (car handle) "multipart/signed")
4790     (gnus-add-wash-type 'signed)
4791     (gnus-mime-display-security handle))
4792    ((equal (car handle) "multipart/encrypted")
4793     (gnus-add-wash-type 'encrypted)
4794     (gnus-mime-display-security handle))
4795    ;; Other multiparts are handled like multipart/mixed.
4796    (t
4797     (gnus-mime-display-mixed (cdr handle)))))
4798
4799 (defun gnus-mime-part-function (handles)
4800   (if (stringp (car handles))
4801       (mapcar 'gnus-mime-part-function (cdr handles))
4802     (funcall gnus-article-mime-part-function handles)))
4803
4804 (defun gnus-mime-display-mixed (handles)
4805   (mapcar 'gnus-mime-display-part handles))
4806
4807 (defun gnus-mime-display-single (handle)
4808   (let ((type (mm-handle-media-type handle))
4809         (ignored gnus-ignored-mime-types)
4810         (not-attachment t)
4811         (move nil)
4812         display text)
4813     (catch 'ignored
4814       (progn
4815         (while ignored
4816           (when (string-match (pop ignored) type)
4817             (throw 'ignored nil)))
4818         (if (and (setq not-attachment
4819                        (and (not (mm-inline-override-p handle))
4820                             (or (not (mm-handle-disposition handle))
4821                                 (equal (car (mm-handle-disposition handle))
4822                                        "inline")
4823                                 (mm-attachment-override-p handle))))
4824                  (mm-automatic-display-p handle)
4825                  (or (and
4826                       (mm-inlinable-p handle)
4827                       (mm-inlined-p handle))
4828                      (mm-automatic-external-display-p type)))
4829             (setq display t)
4830           (when (equal (mm-handle-media-supertype handle) "text")
4831             (setq text t)))
4832         (let ((id (1+ (length gnus-article-mime-handle-alist)))
4833               beg)
4834           (push (cons id handle) gnus-article-mime-handle-alist)
4835           (when (or (not display)
4836                     (not (gnus-unbuttonized-mime-type-p type)))
4837             ;(gnus-article-insert-newline)
4838             (gnus-insert-mime-button
4839              handle id (list (or display (and not-attachment text))))
4840             (gnus-article-insert-newline)
4841             ;(gnus-article-insert-newline)
4842             ;; Remember modify the number of forward lines.
4843             (setq move t))
4844           (setq beg (point))
4845           (cond
4846            (display
4847             (when move
4848               (forward-line -1)
4849               (setq beg (point)))
4850             (let ((mail-parse-charset gnus-newsgroup-charset)
4851                   (mail-parse-ignored-charsets
4852                    (save-excursion (condition-case ()
4853                                        (set-buffer gnus-summary-buffer)
4854                                      (error))
4855                                    gnus-newsgroup-ignored-charsets)))
4856               (mm-display-part handle t))
4857             (goto-char (point-max)))
4858            ((and text not-attachment)
4859             (when move
4860               (forward-line -1)
4861               (setq beg (point)))
4862             (gnus-article-insert-newline)
4863             (mm-insert-inline handle (mm-get-part handle))
4864             (goto-char (point-max))))
4865           ;; Do highlighting.
4866           (save-excursion
4867             (save-restriction
4868               (narrow-to-region beg (point))
4869               (gnus-treat-article
4870                nil id
4871                (gnus-article-mime-total-parts)
4872                (mm-handle-media-type handle)))))))))
4873
4874 (defun gnus-unbuttonized-mime-type-p (type)
4875   "Say whether TYPE is to be unbuttonized."
4876   (unless gnus-inhibit-mime-unbuttonizing
4877     (when (catch 'found
4878             (let ((types gnus-unbuttonized-mime-types))
4879               (while types
4880                 (when (string-match (pop types) type)
4881                   (throw 'found t)))))
4882       (not (catch 'found
4883              (let ((types gnus-buttonized-mime-types))
4884                (while types
4885                  (when (string-match (pop types) type)
4886                    (throw 'found t)))))))))
4887
4888 (defun gnus-article-insert-newline ()
4889   "Insert a newline, but mark it as undeletable."
4890   (gnus-put-text-property
4891    (point) (progn (insert "\n") (point)) 'gnus-undeletable t))
4892
4893 (defun gnus-mime-display-alternative (handles &optional preferred ibegend id)
4894   (let* ((preferred (or preferred (mm-preferred-alternative handles)))
4895          (ihandles handles)
4896          (point (point))
4897          handle buffer-read-only from props begend not-pref)
4898     (save-window-excursion
4899       (save-restriction
4900         (when ibegend
4901           (narrow-to-region (car ibegend)
4902                             (or (cdr ibegend)
4903                                 (progn
4904                                   (goto-char (car ibegend))
4905                                   (forward-line 2)
4906                                   (point))))
4907           (delete-region (point-min) (point-max))
4908           (mm-remove-parts handles))
4909         (setq begend (list (point-marker)))
4910         ;; Do the toggle.
4911         (unless (setq not-pref (cadr (member preferred ihandles)))
4912           (setq not-pref (car ihandles)))
4913         (when (or ibegend
4914                   (not preferred)
4915                   (not (gnus-unbuttonized-mime-type-p
4916                         "multipart/alternative")))
4917           (gnus-add-text-properties
4918            (setq from (point))
4919            (progn
4920              (insert (format "%d.  " id))
4921              (point))
4922            `(gnus-callback
4923              (lambda (handles)
4924                (unless ,(not ibegend)
4925                  (setq gnus-article-mime-handle-alist
4926                        ',gnus-article-mime-handle-alist))
4927                (gnus-mime-display-alternative
4928                 ',ihandles ',not-pref ',begend ,id))
4929              ,@(gnus-local-map-property gnus-mime-button-map)
4930              ,gnus-mouse-face-prop ,gnus-article-mouse-face
4931              face ,gnus-article-button-face
4932              gnus-part ,id
4933              gnus-data ,handle))
4934           (widget-convert-button 'link from (point)
4935                                  :action 'gnus-widget-press-button
4936                                  :button-keymap gnus-widget-button-keymap)
4937           ;; Do the handles
4938           (while (setq handle (pop handles))
4939             (gnus-add-text-properties
4940              (setq from (point))
4941              (progn
4942                (insert (format "(%c) %-18s"
4943                                (if (equal handle preferred) ?* ? )
4944                                (mm-handle-media-type handle)))
4945                (point))
4946              `(gnus-callback
4947                (lambda (handles)
4948                  (unless ,(not ibegend)
4949                    (setq gnus-article-mime-handle-alist
4950                          ',gnus-article-mime-handle-alist))
4951                  (gnus-mime-display-alternative
4952                   ',ihandles ',handle ',begend ,id))
4953                ,@(gnus-local-map-property gnus-mime-button-map)
4954                ,gnus-mouse-face-prop ,gnus-article-mouse-face
4955                face ,gnus-article-button-face
4956                gnus-part ,id
4957                gnus-data ,handle))
4958             (widget-convert-button 'link from (point)
4959                                    :action 'gnus-widget-press-button
4960                                    :button-keymap gnus-widget-button-keymap)
4961             (insert "  "))
4962           (insert "\n\n"))
4963         (when preferred
4964           (if (stringp (car preferred))
4965               (gnus-display-mime preferred)
4966             (let ((mail-parse-charset gnus-newsgroup-charset)
4967                   (mail-parse-ignored-charsets
4968                    (save-excursion (set-buffer gnus-summary-buffer)
4969                                    gnus-newsgroup-ignored-charsets)))
4970               (mm-display-part preferred)
4971               ;; Do highlighting.
4972               (save-excursion
4973                 (save-restriction
4974                   (narrow-to-region (car begend) (point-max))
4975                   (gnus-treat-article
4976                    nil (length gnus-article-mime-handle-alist)
4977                    (gnus-article-mime-total-parts)
4978                    (mm-handle-media-type handle))))))
4979           (goto-char (point-max))
4980           (setcdr begend (point-marker)))))
4981     (when ibegend
4982       (goto-char point))))
4983
4984 (defconst gnus-article-wash-status-strings
4985   (let ((alist '((cite "c" "Possible hidden citation text"
4986                        " " "All citation text visible")
4987                  (headers "h" "Hidden headers"
4988                           " " "All headers visible.")
4989                  (pgp "p" "Encrypted or signed message status hidden"
4990                       " " "No hidden encryption nor digital signature status")
4991                  (signature "s" "Signature has been hidden"
4992                             " " "Signature is visible")
4993                  (overstrike "o" "Overstrike (^H) characters applied"
4994                              " " "No overstrike characters applied")
4995                  (gnus-show-mime "m" "Mime processing is activated"
4996                                  " " "Mime processing is not activated")
4997                  (emphasis "e" "/*_Emphasis_*/ characters applied"
4998                            " " "No /*_emphasis_*/ characters applied")))
4999         result)
5000     (dolist (entry alist result)
5001       (let ((key (nth 0 entry))
5002             (on (copy-sequence (nth 1 entry)))
5003             (on-help (nth 2 entry))
5004             (off (copy-sequence (nth 3 entry)))
5005             (off-help (nth 4 entry)))
5006         (put-text-property 0 1 'help-echo on-help on)
5007         (put-text-property 0 1 'help-echo off-help off)
5008         (push (list key on off) result))))
5009   "Alist of strings describing wash status in the mode line.
5010 Each entry has the form (KEY ON OF), where the KEY is a symbol
5011 representing the particular washing function, ON is the string to use
5012 in the article mode line when the washing function is active, and OFF
5013 is the string to use when it is inactive.")
5014
5015 (defun gnus-article-wash-status-entry (key value)
5016   (let ((entry (assoc key gnus-article-wash-status-strings)))
5017     (if value (nth 1 entry) (nth 2 entry))))
5018
5019 (defun gnus-article-wash-status ()
5020   "Return a string which display status of article washing."
5021   (save-excursion
5022     (set-buffer gnus-article-buffer)
5023     (let ((cite (memq 'cite gnus-article-wash-types))
5024           (headers (memq 'headers gnus-article-wash-types))
5025           (boring (memq 'boring-headers gnus-article-wash-types))
5026           (pgp (memq 'pgp gnus-article-wash-types))
5027           (pem (memq 'pem gnus-article-wash-types))
5028           (signed (memq 'signed gnus-article-wash-types))
5029           (encrypted (memq 'encrypted gnus-article-wash-types))
5030           (signature (memq 'signature gnus-article-wash-types))
5031           (overstrike (memq 'overstrike gnus-article-wash-types))
5032           (emphasis (memq 'emphasis gnus-article-wash-types)))
5033       (concat
5034        (gnus-article-wash-status-entry 'cite cite)
5035        (gnus-article-wash-status-entry 'headers (or headers boring))
5036        (gnus-article-wash-status-entry 'pgp (or pgp pem signed encrypted))
5037        (gnus-article-wash-status-entry 'signature signature)
5038        (gnus-article-wash-status-entry 'overstrike overstrike)
5039        (gnus-article-wash-status-entry 'gnus-show-mime gnus-show-mime)
5040        (gnus-article-wash-status-entry 'emphasis emphasis)))))
5041
5042 (defun gnus-add-wash-type (type)
5043   "Add a washing of TYPE to the current status."
5044   (add-to-list 'gnus-article-wash-types type))
5045
5046 (defun gnus-delete-wash-type (type)
5047   "Add a washing of TYPE to the current status."
5048   (setq gnus-article-wash-types (delq type gnus-article-wash-types)))
5049
5050 (defun gnus-add-image (category image)
5051   "Add IMAGE of CATEGORY to the list of displayed images."
5052   (let ((entry (assq category gnus-article-image-alist)))
5053     (unless entry
5054       (setq entry (list category))
5055       (push entry gnus-article-image-alist))
5056     (nconc entry (list image))))
5057
5058 (defun gnus-delete-images (category)
5059   "Delete all images in CATEGORY."
5060   (let ((entry (assq category gnus-article-image-alist)))
5061     (dolist (image (cdr entry))
5062       (gnus-remove-image image))
5063     (setq gnus-article-image-alist (delq entry gnus-article-image-alist))
5064     (gnus-delete-wash-type category)))
5065
5066 (defalias 'gnus-article-hide-headers-if-wanted 'gnus-article-maybe-hide-headers)
5067
5068 (defun gnus-article-maybe-hide-headers ()
5069   "Hide unwanted headers if `gnus-have-all-headers' is nil.
5070 Provided for backwards compatibility."
5071   (when (and (or (not (gnus-buffer-live-p gnus-summary-buffer))
5072                  (not (save-excursion (set-buffer gnus-summary-buffer)
5073                                       gnus-have-all-headers)))
5074              (not gnus-inhibit-hiding))
5075     (gnus-article-hide-headers)))
5076
5077 ;;; Article savers.
5078
5079 (defun gnus-output-to-file (file-name)
5080   "Append the current article to a file named FILE-NAME."
5081   (let ((artbuf (current-buffer)))
5082     (with-temp-buffer
5083       (insert-buffer-substring artbuf)
5084       ;; Append newline at end of the buffer as separator, and then
5085       ;; save it to file.
5086       (goto-char (point-max))
5087       (insert "\n")
5088       (let ((file-name-coding-system nnmail-pathname-coding-system)
5089             (pathname-coding-system nnmail-pathname-coding-system))
5090         (write-region-as-binary (point-min) (point-max) file-name 'append))
5091       t)))
5092
5093 (defun gnus-narrow-to-page (&optional arg)
5094   "Narrow the article buffer to a page.
5095 If given a numerical ARG, move forward ARG pages."
5096   (interactive "P")
5097   (setq arg (if arg (prefix-numeric-value arg) 0))
5098   (save-excursion
5099     (set-buffer gnus-article-buffer)
5100     (goto-char (point-min))
5101     (widen)
5102     ;; Remove any old next/prev buttons.
5103     (when (gnus-visual-p 'page-marker)
5104       (let ((buffer-read-only nil))
5105         (gnus-remove-text-with-property 'gnus-prev)
5106         (gnus-remove-text-with-property 'gnus-next)))
5107     (when
5108         (cond ((< arg 0)
5109                (re-search-backward page-delimiter nil 'move (1+ (abs arg))))
5110               ((> arg 0)
5111                (re-search-forward page-delimiter nil 'move arg)))
5112       (goto-char (match-end 0)))
5113     (narrow-to-region
5114      (point)
5115      (if (re-search-forward page-delimiter nil 'move)
5116          (match-beginning 0)
5117        (point)))
5118     (when (and (gnus-visual-p 'page-marker)
5119                (not (= (point-min) 1)))
5120       (save-excursion
5121         (goto-char (point-min))
5122         (gnus-insert-prev-page-button)))
5123     (when (and (gnus-visual-p 'page-marker)
5124                (< (+ (point-max) 2) (buffer-size)))
5125       (save-excursion
5126         (goto-char (point-max))
5127         (gnus-insert-next-page-button)))))
5128
5129 ;; Article mode commands
5130
5131 (defun gnus-article-goto-next-page ()
5132   "Show the next page of the article."
5133   (interactive)
5134   (when (gnus-article-next-page)
5135     (goto-char (point-min))
5136     (gnus-article-read-summary-keys nil (gnus-character-to-event ?n))))
5137
5138 (defun gnus-article-goto-prev-page ()
5139   "Show the next page of the article."
5140   (interactive)
5141   (if (bobp) (gnus-article-read-summary-keys nil (gnus-character-to-event ?p))
5142     (gnus-article-prev-page nil)))
5143
5144 (defun gnus-article-next-page (&optional lines)
5145   "Show the next page of the current article.
5146 If end of article, return non-nil.  Otherwise return nil.
5147 Argument LINES specifies lines to be scrolled up."
5148   (interactive "p")
5149   (let ((start (window-start))
5150         end-of-buffer end-of-page)
5151     (save-excursion
5152       (move-to-window-line -1)
5153       (if (<= (point) start)
5154           (progn
5155             (forward-line 2)
5156             (setq start (point)))
5157         (forward-line 1)
5158         (setq start nil))
5159       (unless (or (cond ((eq (1+ (buffer-size)) (point))
5160                          (and (pos-visible-in-window-p)
5161                               (setq end-of-buffer t)))
5162                         ((eobp)
5163                          (setq end-of-page t)))
5164                   (not lines))
5165         (move-to-window-line lines)
5166         (unless (search-backward "\n\n" nil t)
5167           (setq start (point)))))
5168     (cond (end-of-buffer t)
5169           (end-of-page
5170            (gnus-narrow-to-page 1)
5171            nil)
5172           (t
5173            (if start
5174                (set-window-start (selected-window) start)
5175              (let (window-pixel-scroll-increment)
5176                (scroll-up lines)))
5177            nil))))
5178
5179 (defun gnus-article-prev-page (&optional lines)
5180   "Show previous page of current article.
5181 Argument LINES specifies lines to be scrolled down."
5182   (interactive "p")
5183   (let (beginning-of-buffer beginning-of-page)
5184     (save-excursion
5185       (move-to-window-line 0)
5186       (cond ((eq 1 (point))
5187              (setq beginning-of-buffer t))
5188             ((bobp)
5189              (setq beginning-of-page t))))
5190     (cond (beginning-of-buffer)
5191           (beginning-of-page
5192            (gnus-narrow-to-page -1))
5193           (t
5194            (condition-case nil
5195                (let (window-pixel-scroll-increment)
5196                  (scroll-down lines))
5197              (beginning-of-buffer
5198               (goto-char (point-min))))))))
5199
5200 (defun gnus-article-refer-article ()
5201   "Read article specified by message-id around point."
5202   (interactive)
5203   (let ((point (point)))
5204     (search-forward ">" nil t)          ;Move point to end of "<....>".
5205     (if (re-search-backward "\\(<[^<> \t\n]+>\\)" nil t)
5206         (let ((message-id (match-string 1)))
5207           (goto-char point)
5208           (set-buffer gnus-summary-buffer)
5209           (gnus-summary-refer-article message-id))
5210       (goto-char (point))
5211       (error "No references around point"))))
5212
5213 (defun gnus-article-show-summary ()
5214   "Reconfigure windows to show summary buffer."
5215   (interactive)
5216   (if (not (gnus-buffer-live-p gnus-summary-buffer))
5217       (error "There is no summary buffer for this article buffer")
5218     (gnus-article-set-globals)
5219     (gnus-configure-windows 'article)
5220     (gnus-summary-goto-subject gnus-current-article)
5221     (gnus-summary-position-point)))
5222
5223 (defun gnus-article-describe-briefly ()
5224   "Describe article mode commands briefly."
5225   (interactive)
5226   (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")))
5227
5228 (defun gnus-article-summary-command ()
5229   "Execute the last keystroke in the summary buffer."
5230   (interactive)
5231   (let ((obuf (current-buffer))
5232         (owin (current-window-configuration))
5233         func)
5234     (switch-to-buffer gnus-article-current-summary 'norecord)
5235     (setq func (lookup-key (current-local-map) (this-command-keys)))
5236     (call-interactively func)
5237     (set-buffer obuf)
5238     (set-window-configuration owin)
5239     (set-window-point (get-buffer-window (current-buffer)) (point))))
5240
5241 (defun gnus-article-summary-command-nosave ()
5242   "Execute the last keystroke in the summary buffer."
5243   (interactive)
5244   (let (func)
5245     (pop-to-buffer gnus-article-current-summary 'norecord)
5246     (setq func (lookup-key (current-local-map) (this-command-keys)))
5247     (call-interactively func)))
5248
5249 (defun gnus-article-check-buffer ()
5250   "Beep if not in an article buffer."
5251   (unless (eq (get-buffer gnus-article-buffer) (current-buffer))
5252     (error "Command invoked outside of a Gnus article buffer")))
5253
5254 (defun gnus-article-read-summary-keys (&optional arg key not-restore-window)
5255   "Read a summary buffer key sequence and execute it from the article buffer."
5256   (interactive "P")
5257   (gnus-article-check-buffer)
5258   (let ((nosaves
5259          '("q" "Q"  "c" "r" "\C-c\C-f" "m"  "a" "f"
5260            "Zc" "ZC" "ZE" "ZJ" "ZQ" "ZZ" "Zn" "ZR" "ZG" "ZN" "ZP"
5261            "=" "^" "\M-^" "|"))
5262         (nosave-but-article
5263          '("A\r"))
5264         (nosave-in-article
5265          '("\C-d"))
5266         (up-to-top
5267          '("n" "Gn" "p" "Gp"))
5268         keys new-sum-point)
5269     (save-excursion
5270       (set-buffer gnus-article-current-summary)
5271       (let (gnus-pick-mode)
5272         (push (or key last-command-event) unread-command-events)
5273         (setq keys (static-if (featurep 'xemacs)
5274                        (events-to-keys (read-key-sequence nil))
5275                      (read-key-sequence nil)))))
5276     (message "")
5277
5278     (if (or (member keys nosaves)
5279             (member keys nosave-but-article)
5280             (member keys nosave-in-article))
5281         (let (func)
5282           (save-window-excursion
5283             (pop-to-buffer gnus-article-current-summary 'norecord)
5284             ;; We disable the pick minor mode commands.
5285             (let (gnus-pick-mode)
5286               (setq func (lookup-key (current-local-map) keys))))
5287           (if (or (not func)
5288                   (numberp func))
5289               (ding)
5290             (unless (member keys nosave-in-article)
5291               (set-buffer gnus-article-current-summary))
5292             (call-interactively func)
5293             (setq new-sum-point (point)))
5294           (when (member keys nosave-but-article)
5295             (pop-to-buffer gnus-article-buffer 'norecord)))
5296       ;; These commands should restore window configuration.
5297       (let ((obuf (current-buffer))
5298             (owin (current-window-configuration))
5299             (opoint (point))
5300             (summary gnus-article-current-summary)
5301             func in-buffer selected)
5302         (if not-restore-window
5303             (pop-to-buffer summary 'norecord)
5304           (switch-to-buffer summary 'norecord))
5305         (setq in-buffer (current-buffer))
5306         ;; We disable the pick minor mode commands.
5307         (if (and (setq func (let (gnus-pick-mode)
5308                               (lookup-key (current-local-map) keys)))
5309                  (functionp func))
5310             (progn
5311               (call-interactively func)
5312               (setq new-sum-point (point))
5313               (when (eq in-buffer (current-buffer))
5314                 (setq selected (gnus-summary-select-article))
5315                 (set-buffer obuf)
5316                 (unless not-restore-window
5317                   (set-window-configuration owin))
5318                 (when (eq selected 'old)
5319                   (article-goto-body)
5320                   (set-window-start (get-buffer-window (current-buffer))
5321                                     1)
5322                   (set-window-point (get-buffer-window (current-buffer))
5323                                     (point)))
5324                 (let ((win (get-buffer-window gnus-article-current-summary)))
5325                   (when win
5326                     (set-window-point win new-sum-point))))    )
5327           (switch-to-buffer gnus-article-buffer)
5328           (ding))))))
5329
5330 (defun gnus-article-describe-key (key)
5331   "Display documentation of the function invoked by KEY.  KEY is a string."
5332   (interactive "kDescribe key: ")
5333   (gnus-article-check-buffer)
5334   (if (eq (key-binding key) 'gnus-article-read-summary-keys)
5335       (save-excursion
5336         (set-buffer gnus-article-current-summary)
5337         (let (gnus-pick-mode)
5338           (if (featurep 'xemacs)
5339               (progn
5340                 (push (elt key 0) unread-command-events)
5341                 (setq key (events-to-keys
5342                            (read-key-sequence "Describe key: "))))
5343             (setq unread-command-events
5344                   (mapcar
5345                    (lambda (x) (if (>= x 128) (list 'meta (- x 128)) x))
5346                    key))
5347             (setq key (read-key-sequence "Describe key: "))))
5348         (describe-key key))
5349     (describe-key key)))
5350
5351 (defun gnus-article-describe-key-briefly (key &optional insert)
5352   "Display documentation of the function invoked by KEY.  KEY is a string."
5353   (interactive "kDescribe key: \nP")
5354   (gnus-article-check-buffer)
5355   (if (eq (key-binding key) 'gnus-article-read-summary-keys)
5356       (save-excursion
5357         (set-buffer gnus-article-current-summary)
5358         (let (gnus-pick-mode)
5359           (if (featurep 'xemacs)
5360               (progn
5361                 (push (elt key 0) unread-command-events)
5362                 (setq key (events-to-keys
5363                            (read-key-sequence "Describe key: "))))
5364             (setq unread-command-events
5365                   (mapcar
5366                    (lambda (x) (if (>= x 128) (list 'meta (- x 128)) x))
5367                    key))
5368             (setq key (read-key-sequence "Describe key: "))))
5369         (describe-key-briefly key insert))
5370     (describe-key-briefly key insert)))
5371
5372 (defun gnus-article-reply-with-original (&optional wide)
5373   "Start composing a reply mail to the current message.
5374 The text in the region will be yanked.  If the region isn't active,
5375 the entire article will be yanked."
5376   (interactive "P")
5377   (let ((article (cdr gnus-article-current)) cont)
5378     (if (not (mark t))
5379         (with-current-buffer gnus-summary-buffer
5380           (gnus-summary-reply (list (list article)) wide))
5381       (setq cont (buffer-substring (point) (mark t)))
5382       ;; Deactivate active regions.
5383       (when (and (boundp 'transient-mark-mode)
5384                  transient-mark-mode)
5385         (setq mark-active nil))
5386       (with-current-buffer gnus-summary-buffer
5387         (gnus-summary-reply
5388          (list (list article cont)) wide)))))
5389
5390 (defun gnus-article-followup-with-original ()
5391   "Compose a followup to the current article.
5392 The text in the region will be yanked.  If the region isn't active,
5393 the entire article will be yanked."
5394   (interactive)
5395   (let ((article (cdr gnus-article-current)) cont)
5396       (if (not (mark t))
5397           (with-current-buffer gnus-summary-buffer
5398             (gnus-summary-followup (list (list article))))
5399         (setq cont (buffer-substring (point) (mark t)))
5400         ;; Deactivate active regions.
5401         (when (and (boundp 'transient-mark-mode)
5402                    transient-mark-mode)
5403           (setq mark-active nil))
5404         (with-current-buffer gnus-summary-buffer
5405           (gnus-summary-followup
5406            (list (list article cont)))))))
5407
5408 (defun gnus-article-hide (&optional arg force)
5409   "Hide all the gruft in the current article.
5410 This means that PGP stuff, signatures, cited text and (some)
5411 headers will be hidden.
5412 If given a prefix, show the hidden text instead."
5413   (interactive (append (gnus-article-hidden-arg) (list 'force)))
5414   (gnus-article-hide-headers arg)
5415   (gnus-article-hide-list-identifiers arg)
5416   (gnus-article-hide-pgp arg)
5417   (gnus-article-hide-citation-maybe arg force)
5418   (gnus-article-hide-signature arg))
5419
5420 (defun gnus-article-maybe-highlight ()
5421   "Do some article highlighting if article highlighting is requested."
5422   (when (gnus-visual-p 'article-highlight 'highlight)
5423     (gnus-article-highlight-some)))
5424
5425 (defun gnus-check-group-server ()
5426   ;; Make sure the connection to the server is alive.
5427   (unless (gnus-server-opened
5428            (gnus-find-method-for-group gnus-newsgroup-name))
5429     (gnus-check-server (gnus-find-method-for-group gnus-newsgroup-name))
5430     (gnus-request-group gnus-newsgroup-name t)))
5431
5432 (eval-when-compile
5433   (autoload 'nneething-get-file-name "nneething"))
5434
5435 (defun gnus-request-article-this-buffer (article group)
5436   "Get an article and insert it into this buffer."
5437   (let (do-update-line sparse-header)
5438     (prog1
5439         (save-excursion
5440           (erase-buffer)
5441           (gnus-kill-all-overlays)
5442           (setq group (or group gnus-newsgroup-name))
5443
5444           ;; Using `gnus-request-article' directly will insert the article into
5445           ;; `nntp-server-buffer' - so we'll save some time by not having to
5446           ;; copy it from the server buffer into the article buffer.
5447
5448           ;; We only request an article by message-id when we do not have the
5449           ;; headers for it, so we'll have to get those.
5450           (when (stringp article)
5451             (gnus-read-header article))
5452
5453           ;; If the article number is negative, that means that this article
5454           ;; doesn't belong in this newsgroup (possibly), so we find its
5455           ;; message-id and request it by id instead of number.
5456           (when (and (numberp article)
5457                      gnus-summary-buffer
5458                      (get-buffer gnus-summary-buffer)
5459                      (gnus-buffer-exists-p gnus-summary-buffer))
5460             (save-excursion
5461               (set-buffer gnus-summary-buffer)
5462               (let ((header (gnus-summary-article-header article)))
5463                 (when (< article 0)
5464                   (cond
5465                    ((memq article gnus-newsgroup-sparse)
5466                     ;; This is a sparse gap article.
5467                     (setq do-update-line article)
5468                     (setq article (mail-header-id header))
5469                     (setq sparse-header (gnus-read-header article))
5470                     (setq gnus-newsgroup-sparse
5471                           (delq article gnus-newsgroup-sparse)))
5472                    ((vectorp header)
5473                     ;; It's a real article.
5474                     (setq article (mail-header-id header)))
5475                    (t
5476                     ;; It is an extracted pseudo-article.
5477                     (setq article 'pseudo)
5478                     (gnus-request-pseudo-article header))))
5479
5480                 (let ((method (gnus-find-method-for-group
5481                                gnus-newsgroup-name)))
5482                   (when (and (eq (car method) 'nneething)
5483                              (vectorp header))
5484                     (let ((dir (nneething-get-file-name
5485                                 (mail-header-id header))))
5486                       (when (and (stringp dir)
5487                                  (file-directory-p dir))
5488                         (setq article 'nneething)
5489                         (gnus-group-enter-directory dir))))))))
5490
5491           (cond
5492            ;; Refuse to select canceled articles.
5493            ((and (numberp article)
5494                  gnus-summary-buffer
5495                  (get-buffer gnus-summary-buffer)
5496                  (gnus-buffer-exists-p gnus-summary-buffer)
5497                  (eq (cdr (save-excursion
5498                             (set-buffer gnus-summary-buffer)
5499                             (assq article gnus-newsgroup-reads)))
5500                      gnus-canceled-mark))
5501             nil)
5502            ;; We first check `gnus-original-article-buffer'.
5503            ((and (get-buffer gnus-original-article-buffer)
5504                  (numberp article)
5505                  (save-excursion
5506                    (set-buffer gnus-original-article-buffer)
5507                    (and (equal (car gnus-original-article) group)
5508                         (eq (cdr gnus-original-article) article))))
5509             (insert-buffer-substring gnus-original-article-buffer)
5510             'article)
5511            ;; Check the backlog.
5512            ((and gnus-keep-backlog
5513                  (gnus-backlog-request-article group article (current-buffer)))
5514             'article)
5515            ;; Check asynchronous pre-fetch.
5516            ((gnus-async-request-fetched-article group article (current-buffer))
5517             (gnus-async-prefetch-next group article gnus-summary-buffer)
5518             (when (and (numberp article) gnus-keep-backlog)
5519               (gnus-backlog-enter-article group article (current-buffer)))
5520             'article)
5521            ;; Check the cache.
5522            ((and gnus-use-cache
5523                  (numberp article)
5524                  (gnus-cache-request-article article group))
5525             'article)
5526            ;; Check the agent cache.
5527            ((and gnus-agent gnus-agent-cache gnus-plugged
5528                  (numberp article)
5529                  (gnus-agent-request-article article group))
5530             'article)
5531            ;; Get the article and put into the article buffer.
5532            ((or (stringp article)
5533                 (numberp article))
5534             (let ((gnus-override-method gnus-override-method)
5535                   (methods (and (stringp article)
5536                                 gnus-refer-article-method))
5537                   (backend (car (gnus-find-method-for-group
5538                                  gnus-newsgroup-name)))
5539                   result
5540                   (buffer-read-only nil))
5541               (if (or (not (listp methods))
5542                       (and (symbolp (car methods))
5543                            (assq (car methods) nnoo-definition-alist)))
5544                   (setq methods (list methods)))
5545               (when (and (null gnus-override-method)
5546                          methods)
5547                 (setq gnus-override-method (pop methods)))
5548               (while (not result)
5549                 (when (eq gnus-override-method 'current)
5550                   (setq gnus-override-method
5551                         (with-current-buffer gnus-summary-buffer
5552                           gnus-current-select-method)))
5553                 (erase-buffer)
5554                 (gnus-kill-all-overlays)
5555                 (let ((gnus-newsgroup-name group))
5556                   (gnus-check-group-server))
5557                 (cond
5558                  ((gnus-request-article article group (current-buffer))
5559                   (when (numberp article)
5560                     (gnus-async-prefetch-next group article
5561                                               gnus-summary-buffer)
5562                     (when gnus-keep-backlog
5563                       (gnus-backlog-enter-article
5564                        group article (current-buffer))))
5565                   (setq result 'article))
5566                  (methods
5567                   (setq gnus-override-method (pop methods)))
5568                  ((not (string-match "^400 "
5569                                      (nnheader-get-report backend)))
5570                   ;; If we get 400 server disconnect, reconnect and
5571                   ;; retry; otherwise, assume the article has expired.
5572                   (setq result 'done))))
5573               (and (eq result 'article) 'article)))
5574            ;; It was a pseudo.
5575            (t article)))
5576
5577       ;; Associate this article with the current summary buffer.
5578       (setq gnus-article-current-summary gnus-summary-buffer)
5579
5580       ;; Take the article from the original article buffer
5581       ;; and place it in the buffer it's supposed to be in.
5582       (when (and (get-buffer gnus-article-buffer)
5583                  (equal (buffer-name (current-buffer))
5584                         (buffer-name (get-buffer gnus-article-buffer))))
5585         (save-excursion
5586           (if (get-buffer gnus-original-article-buffer)
5587               (set-buffer gnus-original-article-buffer)
5588             (set-buffer (gnus-get-buffer-create gnus-original-article-buffer))
5589             (buffer-disable-undo)
5590             (setq major-mode 'gnus-original-article-mode)
5591             (setq buffer-read-only t))
5592           (let (buffer-read-only)
5593             (erase-buffer)
5594             (insert-buffer-substring gnus-article-buffer))
5595           (setq gnus-original-article (cons group article)))
5596
5597         ;; Decode charsets.
5598         (run-hooks 'gnus-article-decode-hook)
5599         ;; Mark article as decoded or not.
5600         (setq gnus-article-decoded-p gnus-article-decode-hook))
5601
5602       ;; Update sparse articles.
5603       (when (and do-update-line
5604                  (or (numberp article)
5605                      (stringp article)))
5606         (let ((buf (current-buffer)))
5607           (set-buffer gnus-summary-buffer)
5608           (gnus-summary-update-article do-update-line sparse-header)
5609           (gnus-summary-goto-subject do-update-line nil t)
5610           (set-window-point (gnus-get-buffer-window (current-buffer) t)
5611                             (point))
5612           (set-buffer buf))))))
5613
5614 ;;;
5615 ;;; Article editing
5616 ;;;
5617
5618 (defcustom gnus-article-edit-mode-hook nil
5619   "Hook run in article edit mode buffers."
5620   :group 'gnus-article-various
5621   :type 'hook)
5622
5623 (defcustom gnus-article-edit-article-setup-function
5624   'gnus-article-mime-edit-article-setup
5625   "Function called to setup an editing article buffer."
5626   :group 'gnus-article-various
5627   :type 'function)
5628
5629 (defvar gnus-article-edit-done-function nil)
5630
5631 (defvar gnus-article-edit-mode-map nil)
5632 (defvar gnus-article-edit-mode nil)
5633
5634 ;; Should we be using derived.el for this?
5635 (unless gnus-article-edit-mode-map
5636   (setq gnus-article-edit-mode-map (make-keymap))
5637   (set-keymap-parent gnus-article-edit-mode-map text-mode-map)
5638
5639   (gnus-define-keys gnus-article-edit-mode-map
5640     "\C-c?"    describe-mode
5641     "\C-c\C-c" gnus-article-edit-done
5642     "\C-c\C-k" gnus-article-edit-exit
5643     "\C-c\C-f\C-t" message-goto-to
5644     "\C-c\C-f\C-o" message-goto-from
5645     "\C-c\C-f\C-b" message-goto-bcc
5646     ;;"\C-c\C-f\C-w" message-goto-fcc
5647     "\C-c\C-f\C-c" message-goto-cc
5648     "\C-c\C-f\C-s" message-goto-subject
5649     "\C-c\C-f\C-r" message-goto-reply-to
5650     "\C-c\C-f\C-n" message-goto-newsgroups
5651     "\C-c\C-f\C-d" message-goto-distribution
5652     "\C-c\C-f\C-f" message-goto-followup-to
5653     "\C-c\C-f\C-m" message-goto-mail-followup-to
5654     "\C-c\C-f\C-k" message-goto-keywords
5655     "\C-c\C-f\C-u" message-goto-summary
5656     "\C-c\C-f\C-i" message-insert-or-toggle-importance
5657     "\C-c\C-f\C-a" message-generate-unsubscribed-mail-followup-to
5658     "\C-c\C-b" message-goto-body
5659     "\C-c\C-i" message-goto-signature
5660
5661     "\C-c\C-t" message-insert-to
5662     "\C-c\C-n" message-insert-newsgroups
5663     "\C-c\C-o" message-sort-headers
5664     "\C-c\C-e" message-elide-region
5665     "\C-c\C-v" message-delete-not-region
5666     "\C-c\C-z" message-kill-to-signature
5667     "\M-\r" message-newline-and-reformat
5668     "\C-c\C-a" mml-attach-file
5669     "\C-a" message-beginning-of-line
5670     "\t" message-tab
5671     "\M-;" comment-region)
5672
5673   (gnus-define-keys (gnus-article-edit-wash-map
5674                      "\C-c\C-w" gnus-article-edit-mode-map)
5675     "f" gnus-article-edit-full-stops))
5676
5677 (easy-menu-define
5678   gnus-article-edit-mode-field-menu gnus-article-edit-mode-map ""
5679   '("Field"
5680     ["Fetch To" message-insert-to t]
5681     ["Fetch Newsgroups" message-insert-newsgroups t]
5682     "----"
5683     ["To" message-goto-to t]
5684     ["From" message-goto-from t]
5685     ["Subject" message-goto-subject t]
5686     ["Cc" message-goto-cc t]
5687     ["Reply-To" message-goto-reply-to t]
5688     ["Summary" message-goto-summary t]
5689     ["Keywords" message-goto-keywords t]
5690     ["Newsgroups" message-goto-newsgroups t]
5691     ["Followup-To" message-goto-followup-to t]
5692     ["Mail-Followup-To" message-goto-mail-followup-to t]
5693     ["Distribution" message-goto-distribution t]
5694     ["Body" message-goto-body t]
5695     ["Signature" message-goto-signature t]))
5696
5697 (define-derived-mode gnus-article-edit-mode text-mode "Article Edit"
5698   "Major mode for editing articles.
5699 This is an extended text-mode.
5700
5701 \\{gnus-article-edit-mode-map}"
5702   (make-local-variable 'gnus-article-edit-done-function)
5703   (make-local-variable 'gnus-prev-winconf)
5704   (set (make-local-variable 'font-lock-defaults)
5705        '(message-font-lock-keywords t))
5706   (set (make-local-variable 'mail-header-separator) "")
5707   (set (make-local-variable 'gnus-article-edit-mode) t)
5708   (easy-menu-add message-mode-field-menu message-mode-map)
5709   (setq buffer-read-only nil)
5710   (buffer-enable-undo)
5711   (widen))
5712
5713 (defun gnus-article-edit (&optional force)
5714   "Edit the current article.
5715 This will have permanent effect only in mail groups.
5716 If FORCE is non-nil, allow editing of articles even in read-only
5717 groups."
5718   (interactive "P")
5719   (when (and (not force)
5720              (gnus-group-read-only-p))
5721     (error "The current newsgroup does not support article editing"))
5722   (gnus-article-date-original)
5723   (gnus-article-edit-article
5724    'ignore
5725    `(lambda (no-highlight)
5726       'ignore
5727       (gnus-summary-edit-article-done
5728        ,(or (mail-header-references gnus-current-headers) "")
5729        ,(gnus-group-read-only-p) ,gnus-summary-buffer no-highlight))))
5730
5731 (defun gnus-article-edit-article (start-func exit-func)
5732   "Start editing the contents of the current article buffer."
5733   (let ((winconf (current-window-configuration)))
5734     (set-buffer gnus-article-buffer)
5735     (gnus-article-edit-mode)
5736     (funcall start-func)
5737     (set-buffer-modified-p nil)
5738     (gnus-configure-windows 'edit-article)
5739     (setq gnus-article-edit-done-function exit-func)
5740     (setq gnus-prev-winconf winconf)
5741     (when gnus-article-edit-article-setup-function
5742       (funcall gnus-article-edit-article-setup-function))
5743     (gnus-message 6 "C-c C-c to end edits; C-c C-k to exit")))
5744
5745 (defun gnus-article-edit-done (&optional arg)
5746   "Update the article edits and exit."
5747   (interactive "P")
5748   (let ((func gnus-article-edit-done-function)
5749         (buf (current-buffer))
5750         (start (window-start))
5751         (p (point))
5752         (winconf gnus-prev-winconf))
5753     (remove-hook 'gnus-article-mode-hook
5754                  'gnus-article-mime-edit-article-unwind)
5755     (widen) ;; Widen it in case that users narrowed the buffer.
5756     (funcall func arg)
5757     (set-buffer buf)
5758     ;; The cache and backlog have to be flushed somewhat.
5759     (when gnus-keep-backlog
5760       (gnus-backlog-remove-article
5761        (car gnus-article-current) (cdr gnus-article-current)))
5762     ;; Flush original article as well.
5763     (save-excursion
5764       (when (get-buffer gnus-original-article-buffer)
5765         (set-buffer gnus-original-article-buffer)
5766         (setq gnus-original-article nil)))
5767     (when gnus-use-cache
5768       (gnus-cache-update-article
5769        (car gnus-article-current) (cdr gnus-article-current)))
5770     ;; We remove all text props from the article buffer.
5771     (kill-all-local-variables)
5772     (gnus-set-text-properties (point-min) (point-max) nil)
5773     (gnus-article-mode)
5774     (set-window-configuration winconf)
5775     (set-buffer buf)
5776     (set-window-start (get-buffer-window buf) start)
5777     (set-window-point (get-buffer-window buf) (point))))
5778
5779 (defun gnus-article-edit-exit ()
5780   "Exit the article editing without updating."
5781   (interactive)
5782   (when (or (not (buffer-modified-p))
5783             (yes-or-no-p "Article modified; kill anyway? "))
5784     (let ((curbuf (current-buffer))
5785           (p (point))
5786           (window-start (window-start)))
5787       (erase-buffer)
5788       (if (gnus-buffer-live-p gnus-original-article-buffer)
5789           (insert-buffer-substring gnus-original-article-buffer))
5790       (let ((winconf gnus-prev-winconf))
5791         (kill-all-local-variables)
5792         (gnus-article-mode)
5793         (set-window-configuration winconf)
5794         ;; Tippy-toe some to make sure that point remains where it was.
5795         (save-current-buffer
5796           (set-buffer curbuf)
5797           (set-window-start (get-buffer-window (current-buffer)) window-start)
5798           (goto-char p))))))
5799
5800 (defun gnus-article-edit-full-stops ()
5801   "Interactively repair spacing at end of sentences."
5802   (interactive)
5803   (save-excursion
5804     (goto-char (point-min))
5805     (search-forward-regexp "^$" nil t)
5806     (let ((case-fold-search nil))
5807       (query-replace-regexp "\\([.!?][])}]* \\)\\([[({A-Z]\\)" "\\1 \\2"))))
5808
5809 ;;;
5810 ;;; Article editing with MIME-Edit
5811 ;;;
5812
5813 (defcustom gnus-article-mime-edit-article-setup-hook nil
5814   "Hook run after setting up a MIME editing article buffer."
5815   :group 'gnus-article-various
5816   :type 'hook)
5817
5818 (defun gnus-article-mime-edit-article-unwind ()
5819   "Unwind `gnus-article-buffer' if article editing was given up."
5820   (remove-hook 'gnus-article-mode-hook 'gnus-article-mime-edit-article-unwind)
5821   (when (featurep 'font-lock)
5822     (setq font-lock-defaults nil)
5823     (font-lock-mode -1))
5824   (when mime-edit-mode-flag
5825     (mime-edit-exit 'nomime 'no-error)
5826     (message "")))
5827
5828 (defun gnus-article-mime-edit-article-setup ()
5829   "Convert current buffer to MIME-Edit buffer and turn on MIME-Edit mode
5830 after replacing with the original article."
5831   (setq gnus-show-mime t)
5832   (setq gnus-article-edit-done-function
5833         `(lambda (&rest args)
5834            (when mime-edit-mode-flag
5835              (let (mime-edit-insert-user-agent-field)
5836                (mime-edit-exit))
5837              (message ""))
5838            (goto-char (point-min))
5839            (let (case-fold-search)
5840              (when (re-search-forward
5841                     (format "^%s$" (regexp-quote mail-header-separator))
5842                     nil t)
5843                (replace-match "")))
5844            (apply ,gnus-article-edit-done-function args)
5845            (insert
5846             (prog1
5847                 (buffer-substring-no-properties (point-min) (point-max))
5848               (set-buffer (get-buffer-create gnus-original-article-buffer))
5849               (erase-buffer)))
5850            (setq gnus-current-headers (gnus-article-make-full-mail-header))
5851            (set-buffer gnus-article-buffer)
5852            (gnus-article-prepare-display)))
5853   (substitute-key-definition 'gnus-article-edit-done
5854                              'gnus-article-mime-edit-done
5855                              gnus-article-edit-mode-map)
5856   (substitute-key-definition 'gnus-article-edit-exit
5857                              'gnus-article-mime-edit-exit
5858                              gnus-article-edit-mode-map)
5859   (erase-buffer)
5860   (insert-buffer-substring gnus-original-article-buffer)
5861   (unless (member (with-current-buffer gnus-summary-buffer
5862                     gnus-newsgroup-name)
5863                   '("nndraft:delayed" "nndraft:drafts"))
5864     (let ((ofn (symbol-function 'mime-edit-decode-single-part-in-buffer)))
5865       (fset 'mime-edit-decode-single-part-in-buffer
5866             (lambda (&rest args)
5867               (if (let ((content-type (car args)))
5868                     (and (eq 'message (mime-content-type-primary-type
5869                                        content-type))
5870                          (eq 'rfc822 (mime-content-type-subtype
5871                                       content-type))))
5872                   (setcar (cdr args) 'not-decode-text))
5873               (apply ofn args)))
5874       (unwind-protect
5875           (mime-edit-again)
5876         (fset 'mime-edit-decode-single-part-in-buffer ofn))))
5877   (when (featurep 'font-lock)
5878     (set (make-local-variable 'font-lock-defaults)
5879          '(message-font-lock-keywords t))
5880     (font-lock-set-defaults)
5881     (turn-on-font-lock))
5882   (set-buffer-modified-p nil)
5883   (delete-other-windows)
5884   (add-hook 'gnus-article-mode-hook 'gnus-article-mime-edit-article-unwind)
5885   (gnus-run-hooks 'gnus-article-mime-edit-article-setup-hook))
5886
5887 (defun gnus-article-mime-edit-done (&optional arg)
5888   "Update the article MIME edits and exit."
5889   (interactive "P")
5890   (when (featurep 'font-lock)
5891     (setq font-lock-defaults nil)
5892     (font-lock-mode -1))
5893   (let ((inhibit-read-only t))
5894     (gnus-article-edit-done arg)))
5895
5896 (defun gnus-article-mime-edit-exit ()
5897   "Exit the article MIME editing without updating."
5898   (interactive)
5899   (when (or (not (buffer-modified-p))
5900             (yes-or-no-p "Article modified; kill anyway? "))
5901     (when (featurep 'font-lock)
5902       (setq font-lock-defaults nil)
5903       (font-lock-mode -1))
5904     (when mime-edit-mode-flag
5905       (let (mime-edit-insert-user-agent-field)
5906         (mime-edit-exit))
5907       (message ""))
5908     (goto-char (point-min))
5909     (let (case-fold-search)
5910       (when (re-search-forward
5911              (format "^%s$" (regexp-quote mail-header-separator)) nil t)
5912         (replace-match "")))
5913     (let ((winconf gnus-prev-winconf))
5914       (insert (prog1
5915                   (buffer-substring-no-properties (point-min) (point-max))
5916                 (set-buffer (get-buffer-create gnus-original-article-buffer))
5917                 (erase-buffer)))
5918       (setq gnus-current-headers (gnus-article-make-full-mail-header))
5919       (set-buffer gnus-article-buffer)
5920       (gnus-article-prepare-display)
5921       (set-window-configuration winconf))))
5922
5923 ;;;
5924 ;;; Article highlights
5925 ;;;
5926
5927 ;; Written by Per Abrahamsen <abraham@iesd.auc.dk>.
5928
5929 ;;; Internal Variables:
5930
5931 (defcustom gnus-button-url-regexp
5932   (if (string-match "[[:digit:]]" "1") ;; support POSIX?
5933       "\\b\\(\\(www\\.\\|\\(s?https?\\|ftp\\|file\\|gopher\\|news\\|telnet\\|wais\\|mailto\\|info\\):\\)\\(//[-a-z0-9_.]+:[0-9]*\\)?[-a-z0-9_=!?#$@~`%&*+|\\/:;.,[:word:]]+[-a-z0-9_=#$@~`%&*+|\\/[:word:]]\\)"
5934     "\\b\\(\\(www\\.\\|\\(s?https?\\|ftp\\|file\\|gopher\\|news\\|telnet\\|wais\\|mailto\\|info\\):\\)\\(//[-a-z0-9_.]+:[0-9]*\\)?\\([-a-z0-9_=!?#$@~`%&*+|\\/:;.,]\\|\\w\\)+\\([-a-z0-9_=#$@~`%&*+|\\/]\\|\\w\\)\\)")
5935   "Regular expression that matches URLs."
5936   :group 'gnus-article-buttons
5937   :type 'regexp)
5938
5939 (defcustom gnus-button-valid-fqdn-regexp
5940   (concat "[a-z0-9][-.a-z0-9]+\\." ;; [hostname.subdomain.]domain.
5941           ;; valid TLDs:
5942           "\\([a-z][a-z]" ;; two letter country TDLs
5943           "\\|biz\\|com\\|edu\\|gov\\|int\\|mil\\|net\\|org"
5944           "\\|aero\\|coop\\|info\\|name\\|museum"
5945           "\\|arpa\\|pro\\|uucp\\|bitnet\\|bofh" ;; old style?
5946           "\\)")
5947   "Regular expression that matches a valid FQDN."
5948   :group 'gnus-article-buttons
5949   :type 'regexp)
5950
5951 (defcustom gnus-button-man-handler 'manual-entry
5952   "Function to use for displaying man pages.
5953 The function must take at least one argument with a string naming the
5954 man page."
5955   :type '(choice (function-item :tag "Man" manual-entry)
5956                  (function-item :tag "Woman" woman)
5957                  (function :tag "Other"))
5958   :group 'gnus-article-buttons)
5959
5960 (defcustom gnus-ctan-url "http://tug.ctan.org/tex-archive/"
5961   "Top directory of a CTAN \(Comprehensive TeX Archive Network\) archive.
5962 If the default site is too slow, try to find a CTAN mirror, see
5963 <URL:http://tug.ctan.org/tex-archive/CTAN.sites?action=/index.html>.  See also
5964 the variable `gnus-button-handle-ctan'."
5965   :group 'gnus-article-buttons
5966   :link '(custom-manual "(gnus)Group Parameters")
5967   :type '(choice (const "http://www.tex.ac.uk/tex-archive/")
5968                  (const "http://tug.ctan.org/tex-archive/")
5969                  (const "http://www.dante.de/CTAN/")
5970                  (string :tag "Other")))
5971
5972 (defcustom gnus-button-ctan-handler 'browse-url
5973   "Function to use for displaying CTAN links.
5974 The function must take one argument, the string naming the URL."
5975   :type '(choice (function-item :tag "Browse Url" browse-url)
5976                  (function :tag "Other"))
5977   :group 'gnus-article-buttons)
5978
5979 (defcustom gnus-button-handle-ctan-bogus-regexp "^/?tex-archive/\\|^/"
5980   "Bogus strings removed from CTAN URLs."
5981   :group 'gnus-article-buttons
5982   :type '(choice (const "^/?tex-archive/\\|/")
5983                  (regexp :tag "Other")))
5984
5985 (defcustom gnus-button-mid-or-mail-regexp
5986   (concat "\\b\\(<?[a-z0-9][^<>\")!;:,{}\n\t ]*@"
5987           gnus-button-valid-fqdn-regexp
5988           ">?\\)\\b")
5989   "Regular expression that matches a message ID or a mail address."
5990   :group 'gnus-article-buttons
5991   :type 'regexp)
5992
5993 (defcustom gnus-button-prefer-mid-or-mail 'guess
5994   "What to do when the button on a string as \"foo123@bar.com\" is pushed.
5995 Strings like this can be either a message ID or a mail address.  If the
5996 variable is set to the symbol `ask', query the user what do do.  If it is the
5997 symbol `guess', Gnus will do a guess and query the user what do do if it is
5998 ambiguous.  See the variable `gnus-button-guessed-mid-regexp' for details
5999 concerning the guessing.  If it is one of the sybols `mid' or `mail', Gnus
6000 will always assume that the string is a message ID or a mail address,
6001 respectivly."
6002   ;; FIXME: doc-string could/should be improved.
6003   :group 'gnus-article-buttons
6004   :type '(choice (const ask)
6005                  (const guess)
6006                  (const mid)
6007                  (const mail)))
6008
6009 (defcustom gnus-button-guessed-mid-regexp
6010   (concat
6011    "^<?\\(slrn\\|Pine\\.\\)"
6012    "\\|\\.fsf@\\|\\.fsf_-_@\\|\\.ln@"
6013    "\\|@4ax\\.com\\|@ID-[0-9]+\\.[a-zA-Z]+\\.dfncis\\.de"
6014           "\\|^<?.*[0-9].*[0-9].*[0-9].*[0-9].*[0-9].*[0-9].*@")
6015   "Regular expression that matches message IDs and not mail addresses."
6016   ;; TODO: Incorporate more matches from
6017   ;; <URL:http://piology.org/perl/id-or-mail.pl.html>. I.e. translate the
6018   ;; Perl-REs to Elisp-REs.
6019   :group 'gnus-article-buttons
6020   :type 'regexp)
6021
6022 (defun gnus-button-handle-mid-or-mail (mid-or-mail)
6023   (let* ((pref gnus-button-prefer-mid-or-mail)
6024          (url-mid (concat "news" ":" mid-or-mail))
6025          (url-mailto (concat "mailto" ":" mid-or-mail)))
6026     (gnus-message 9 "mid-or-mail=%s" mid-or-mail)
6027     ;; If it looks like a MID (well known readers or servers) use 'mid,
6028     ;; otherwise 'ask the user.
6029     (if (eq pref 'guess)
6030         (if (string-match gnus-button-guessed-mid-regexp mid-or-mail)
6031             (setq pref 'mid)
6032           (setq pref 'ask)))
6033     (if (eq pref 'ask)
6034         (save-window-excursion
6035           (if (y-or-n-p (concat "Is <" mid-or-mail "> a mail address? "))
6036               (setq pref 'mail)
6037             (setq pref 'mid))))
6038     (cond ((eq pref 'mid)
6039            (gnus-message 9 "calling `gnus-button-handle-news' %s" url-mid)
6040            (gnus-button-handle-news url-mid))
6041           ((eq pref 'mail)
6042            (gnus-message 9 "calling `gnus-url-mailto'  %s" url-mailto)
6043            (gnus-url-mailto url-mailto)))))
6044
6045 (defun gnus-button-handle-custom (url)
6046   "Follow a Custom URL."
6047   (customize-apropos (gnus-url-unhex-string url)))
6048
6049 (defvar gnus-button-handle-describe-prefix "^\\(C-h\\|<?[Ff]1>?\\)")
6050
6051 (defun gnus-button-handle-describe-function (url)
6052   "Call describe-function when pushing the corresponding URL button."
6053   (describe-function
6054    (intern
6055     (gnus-replace-in-string url gnus-button-handle-describe-prefix ""))))
6056
6057 (defun gnus-button-handle-describe-variable (url)
6058   "Call describe-variable when pushing the corresponding URL button."
6059   (describe-variable
6060    (intern
6061     (gnus-replace-in-string url gnus-button-handle-describe-prefix ""))))
6062
6063 ;; FIXME: Is is possible to implement this?  Else it should be removed here
6064 ;; and in `gnus-button-alist'.
6065 (defun gnus-button-handle-describe-key (url)
6066   "Call describe-key when pushing the corresponding URL button."
6067   (error "not implemented"))
6068
6069 (defun gnus-button-handle-apropos (url)
6070   "Call apropos when pushing the corresponding URL button."
6071   (apropos (gnus-replace-in-string url gnus-button-handle-describe-prefix "")))
6072
6073 (defun gnus-button-handle-apropos-command (url)
6074   "Call apropos when pushing the corresponding URL button."
6075   (apropos-command
6076    (gnus-replace-in-string url gnus-button-handle-describe-prefix "")))
6077
6078 (defun gnus-button-handle-apropos-variable (url)
6079   "Call apropos when pushing the corresponding URL button."
6080   (funcall
6081    (if (fboundp 'apropos-variable) 'apropos-variable 'apropos)
6082    (gnus-replace-in-string url gnus-button-handle-describe-prefix "")))
6083
6084 (defun gnus-button-handle-apropos-documentation (url)
6085   "Call apropos when pushing the corresponding URL button."
6086   (funcall
6087    (if (fboundp 'apropos-documentation) 'apropos-documentation 'apropos)
6088    (gnus-replace-in-string url gnus-button-handle-describe-prefix "")))
6089
6090 (defun gnus-button-handle-ctan (url)
6091   "Call `browse-url' when pushing a CTAN URL button."
6092   (funcall
6093    gnus-button-ctan-handler
6094    (concat
6095     gnus-ctan-url
6096     (gnus-replace-in-string url gnus-button-handle-ctan-bogus-regexp ""))))
6097
6098 (defcustom gnus-button-tex-level 5
6099   "*Integer that says how many TeX-related buttons Gnus will show.
6100 The higher the number, the more buttons will appear and the more false
6101 positives are possible.  Note that you can set this variable local to
6102 specifific groups.  Setting it higher in TeX groups is probably a good idea.
6103 See Info node `(gnus)Group Parameters' and the variable `gnus-parameters' on
6104 how to set variables in specific groups."
6105   :group 'gnus-article-buttons
6106   :link '(custom-manual "(gnus)Group Parameters")
6107   :type 'integer)
6108
6109 (defcustom gnus-button-man-level 5
6110   "*Integer that says how many man-related buttons Gnus will show.
6111 The higher the number, the more buttons will appear and the more false
6112 positives are possible.  Note that you can set this variable local to
6113 specifific groups.  Setting it higher in Unix groups is probably a good idea.
6114 See Info node `(gnus)Group Parameters' and the variable `gnus-parameters' on
6115 how to set variables in specific groups."
6116   :group 'gnus-article-buttons
6117   :link '(custom-manual "(gnus)Group Parameters")
6118   :type 'integer)
6119
6120 (defcustom gnus-button-emacs-level 5
6121   "*Integer that says how many emacs-related buttons Gnus will show.
6122 The higher the number, the more buttons will appear and the more false
6123 positives are possible.  Note that you can set this variable local to
6124 specifific groups.  Setting it higher in Emacs or Gnus related groups is
6125 probably a good idea.  See Info node `(gnus)Group Parameters' and the variable
6126 `gnus-parameters' on how to set variables in specific groups."
6127   :group 'gnus-article-buttons
6128   :link '(custom-manual "(gnus)Group Parameters")
6129   :type 'integer)
6130
6131 (defcustom gnus-button-mail-level 5
6132   "*Integer that says how many buttons for message IDs or mail addresses will appear.
6133 The higher the number, the more buttons will appear and the more false
6134 positives are possible."
6135   :group 'gnus-article-buttons
6136   :type 'integer)
6137
6138 (defcustom gnus-button-alist
6139   '(("<\\(url:[>\n\t ]*?\\)?\\(nntp\\|news\\):[>\n\t ]*\\([^>\n\t ]*@[^>\n\t ]*\\)>"
6140      0 t gnus-button-handle-news 3)
6141     ("\\b\\(nntp\\|news\\):\\([^>\n\t ]*@[^>)!;:,\n\t ]*\\)" 0 t
6142      gnus-button-handle-news 2)
6143     ("\\(\\b<\\(url:[>\n\t ]*\\)?news:[>\n\t ]*\\(//\\)?\\([^>\n\t ]*\\)>\\)"
6144      1 t
6145      gnus-button-fetch-group 4)
6146     ("\\bnews:\\(//\\)?\\([^'\">\n\t ]+\\)" 0 t gnus-button-fetch-group 2)
6147     ("\\bin\\( +article\\| +message\\)? +\\(<\\([^\n @<>]+@[^\n @<>]+\\)>\\)" 2
6148      t gnus-button-message-id 3)
6149     ("\\(<URL: *\\)mailto: *\\([^> \n\t]+\\)>" 0 t gnus-url-mailto 2)
6150     ("mailto:\\([-a-z.@_+0-9%=?]+\\)" 0 t gnus-url-mailto 1)
6151     ("\\bmailto:\\([^ \n\t]+\\)" 0 t gnus-url-mailto 1)
6152     ;; CTAN
6153     ("\\bCTAN:[ \t\n]*\\([^>)!;:,\n\t ]*\\)" 0 (>= gnus-button-tex-level 1)
6154      gnus-button-handle-ctan 1)
6155     ;; This is info
6156     ("\\binfo:\\(//\\)?\\([^'\">\n\t ]+\\)" 0
6157      (>= gnus-button-emacs-level 1) gnus-button-handle-info 2)
6158     ;; This is custom
6159     ("\\bcustom:\\(//\\)?\\([^'\">\n\t ]+\\)" 0
6160      (>= gnus-button-emacs-level 5) gnus-button-handle-custom 2)
6161     ("M-x[ \t\n]customize-[^ ]+[ \t\n]RET[ \t\n]\\([^ ]+\\)[ \t\n]RET" 0
6162      (>= gnus-button-emacs-level 1) gnus-button-handle-custom 1)
6163     ;; Emacs help commands
6164     ("M-x[ \t\n]+apropos[ \t\n]+RET[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET"
6165      ;; regexp doesn't match arguments containing ` '.
6166      0 (>= gnus-button-emacs-level 1) gnus-button-handle-apropos 1)
6167     ("M-x[ \t\n]+apropos-command[ \t\n]+RET[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET"
6168      0 (>= gnus-button-emacs-level 1) gnus-button-handle-apropos-command 1)
6169     ("M-x[ \t\n]+apropos-variable[ \t\n]+RET[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET"
6170      0 (>= gnus-button-emacs-level 1) gnus-button-handle-apropos-variable 1)
6171     ("M-x[ \t\n]+apropos-documentation[ \t\n]+RET[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET"
6172      0 (>= gnus-button-emacs-level 1) gnus-button-handle-apropos-documentation 1)
6173     ("\\b\\(C-h\\|<?[Ff]1>?\\)[ \t\n]+f[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET"
6174      0 (>= gnus-button-emacs-level 1) gnus-button-handle-describe-function 2)
6175     ("\\b\\(C-h\\|<?[Ff]1>?\\)[ \t\n]+v[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET"
6176      0 (>= gnus-button-emacs-level 1) gnus-button-handle-describe-variable 2)
6177     ("\\b\\(C-h\\|<?[Ff]1>?\\)[ \t\n]+k[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+" 0
6178      ;; this regexp needs to be fixed!
6179      (>= gnus-button-emacs-level 9) gnus-button-handle-describe-key 2)
6180     ;; This is how URLs _should_ be embedded in text...
6181     ("<URL: *\\([^<>]*\\)>" 1 t gnus-button-embedded-url 1)
6182     ;; Raw URLs.
6183     (gnus-button-url-regexp 0 t browse-url 0)
6184     ;; man pages
6185     ("\\b\\([a-z][a-z]+\\)([1-9])\\W" 0
6186      (and (>= gnus-button-man-level 1) (< gnus-button-man-level 3))
6187      gnus-button-handle-man 1)
6188     ;; more man pages: resolv.conf(5), iso_8859-1(7), xterm(1x)
6189     ("\\b\\([a-z][-_.a-z0-9]+\\)([1-9])\\W" 0
6190      (and (>= gnus-button-man-level 3) (< gnus-button-man-level 5))
6191      gnus-button-handle-man 1)
6192     ;; even more: Apache::PerlRun(3pm), PDL::IO::FastRaw(3pm),
6193     ;; SoWWWAnchor(3iv), XSelectInput(3X11)
6194     ("\\b\\([a-z][-_.:a-z0-9]+\\)([1-9][X1a-z]*)\\W" 0
6195      (>= gnus-button-man-level 5) gnus-button-handle-man 1)
6196     ;; MID or mail: To avoid too many false positives we don't try to catch
6197     ;; all kind of allowed MIDs or mail addresses.  Domain part must contain
6198     ;; at least one dot.  TLD must contain two or three chars or be a know TLD
6199     ;; (info|name|...).  Put this entry near the _end_ of `gnus-button-alist'
6200     ;; so that non-ambiguous entries (see above) match first.
6201     (gnus-button-mid-or-mail-regexp
6202      0 (>= gnus-button-mail-level 5) gnus-button-handle-mid-or-mail 1))
6203   "*Alist of regexps matching buttons in article bodies.
6204
6205 Each entry has the form (REGEXP BUTTON FORM CALLBACK PAR...), where
6206 REGEXP: is the string (case insensitive) matching text around the button (can
6207 also be lisp expression evaluating to a string),
6208 BUTTON: is the number of the regexp grouping actually matching the button,
6209 FORM: is a lisp expression which must eval to true for the button to
6210 be added,
6211 CALLBACK: is the function to call when the user push this button, and each
6212 PAR: is a number of a regexp grouping whose text will be passed to CALLBACK.
6213
6214 CALLBACK can also be a variable, in that case the value of that
6215 variable it the real callback function."
6216   :group 'gnus-article-buttons
6217   :type '(repeat (list (choice regexp variable)
6218                        (integer :tag "Button")
6219                        (sexp :tag "Form")
6220                        (function :tag "Callback")
6221                        (repeat :tag "Par"
6222                                :inline t
6223                                (integer :tag "Regexp group")))))
6224
6225 (defcustom gnus-header-button-alist
6226   '(("^\\(References\\|Message-I[Dd]\\):" "<[^<>]+>"
6227      0 t gnus-button-message-id 0)
6228     ("^\\(From\\|Reply-To\\):" ": *\\(.+\\)$" 1 t gnus-button-reply 1)
6229     ("^\\(Cc\\|To\\):" "[^ \t\n<>,()\"]+@[^ \t\n<>,()\"]+"
6230      0 t gnus-button-mailto 0)
6231     ("^X-[Uu][Rr][Ll]:" gnus-button-url-regexp 0 t browse-url 0)
6232     ("^Subject:" gnus-button-url-regexp 0 t browse-url 0)
6233     ("^[^:]+:" gnus-button-url-regexp 0 t browse-url 0)
6234     ("^[^:]+:" "\\bmailto:\\([-a-z.@_+0-9%=?]+\\)" 0 t gnus-url-mailto 1)
6235     ("^[^:]+:" "\\(<\\(url: \\)?news:\\([^>\n ]*\\)>\\)" 1 t
6236      gnus-button-message-id 3))
6237   "*Alist of headers and regexps to match buttons in article heads.
6238
6239 This alist is very similar to `gnus-button-alist', except that each
6240 alist has an additional HEADER element first in each entry:
6241
6242 \(HEADER REGEXP BUTTON FORM CALLBACK PAR)
6243
6244 HEADER is a regexp to match a header.  For a fuller explanation, see
6245 `gnus-button-alist'."
6246   :group 'gnus-article-buttons
6247   :group 'gnus-article-headers
6248   :type '(repeat (list (regexp :tag "Header")
6249                        regexp
6250                        (integer :tag "Button")
6251                        (sexp :tag "Form")
6252                        (function :tag "Callback")
6253                        (repeat :tag "Par"
6254                                :inline t
6255                                (integer :tag "Regexp group")))))
6256
6257 (defvar gnus-button-regexp nil)
6258 (defvar gnus-button-marker-list nil)
6259 ;; Regexp matching any of the regexps from `gnus-button-alist'.
6260
6261 (defvar gnus-button-last nil)
6262 ;; The value of `gnus-button-alist' when `gnus-button-regexp' was build.
6263
6264 ;;; Commands:
6265
6266 (defun gnus-article-push-button (event)
6267   "Check text under the mouse pointer for a callback function.
6268 If the text under the mouse pointer has a `gnus-callback' property,
6269 call it with the value of the `gnus-data' text property."
6270   (interactive "e")
6271   (set-buffer (window-buffer (posn-window (event-start event))))
6272   (let* ((pos (posn-point (event-start event)))
6273          (data (get-text-property pos 'gnus-data))
6274          (fun (get-text-property pos 'gnus-callback)))
6275     (goto-char pos)
6276     (when fun
6277       (funcall fun data))))
6278
6279 (defun gnus-article-press-button ()
6280   "Check text at point for a callback function.
6281 If the text at point has a `gnus-callback' property,
6282 call it with the value of the `gnus-data' text property."
6283   (interactive)
6284   (let* ((data (get-text-property (point) 'gnus-data))
6285          (fun (get-text-property (point) 'gnus-callback)))
6286     (when fun
6287       (funcall fun data))))
6288
6289 (defun gnus-article-prev-button (n)
6290   "Move point to N buttons backward.
6291 If N is negative, move forward instead."
6292   (interactive "p")
6293   (gnus-article-next-button (- n)))
6294
6295 (defun gnus-article-next-button (n)
6296   "Move point to N buttons forward.
6297 If N is negative, move backward instead."
6298   (interactive "p")
6299   (let ((function (if (< n 0) 'previous-single-property-change
6300                     'next-single-property-change))
6301         (inhibit-point-motion-hooks t)
6302         (backward (< n 0))
6303         (limit (if (< n 0) (point-min) (point-max))))
6304     (setq n (abs n))
6305     (while (and (not (= limit (point)))
6306                 (> n 0))
6307       ;; Skip past the current button.
6308       (when (get-text-property (point) 'gnus-callback)
6309         (goto-char (funcall function (point) 'gnus-callback nil limit)))
6310       ;; Go to the next (or previous) button.
6311       (gnus-goto-char (funcall function (point) 'gnus-callback nil limit))
6312       ;; Put point at the start of the button.
6313       (when (and backward (not (get-text-property (point) 'gnus-callback)))
6314         (goto-char (funcall function (point) 'gnus-callback nil limit)))
6315       ;; Skip past intangible buttons.
6316       (when (get-text-property (point) 'intangible)
6317         (incf n))
6318       (decf n))
6319     (unless (zerop n)
6320       (gnus-message 5 "No more buttons"))
6321     n))
6322
6323 (defun gnus-article-highlight (&optional force)
6324   "Highlight current article.
6325 This function calls `gnus-article-highlight-headers',
6326 `gnus-article-highlight-citation',
6327 `gnus-article-highlight-signature', and `gnus-article-add-buttons' to
6328 do the highlighting.  See the documentation for those functions."
6329   (interactive (list 'force))
6330   (gnus-article-highlight-headers)
6331   (gnus-article-highlight-citation force)
6332   (gnus-article-highlight-signature)
6333   (gnus-article-add-buttons force)
6334   (gnus-article-add-buttons-to-head))
6335
6336 (defun gnus-article-highlight-some (&optional force)
6337   "Highlight current article.
6338 This function calls `gnus-article-highlight-headers',
6339 `gnus-article-highlight-signature', and `gnus-article-add-buttons' to
6340 do the highlighting.  See the documentation for those functions."
6341   (interactive (list 'force))
6342   (gnus-article-highlight-headers)
6343   (gnus-article-highlight-signature)
6344   (gnus-article-add-buttons))
6345
6346 (defun gnus-article-highlight-headers ()
6347   "Highlight article headers as specified by `gnus-header-face-alist'."
6348   (interactive)
6349   (save-excursion
6350     (set-buffer gnus-article-buffer)
6351     (save-restriction
6352       (let ((alist gnus-header-face-alist)
6353             (buffer-read-only nil)
6354             (case-fold-search t)
6355             (inhibit-point-motion-hooks t)
6356             entry regexp header-face field-face from hpoints fpoints)
6357         (article-narrow-to-head)
6358         (while (setq entry (pop alist))
6359           (goto-char (point-min))
6360           (setq regexp (concat "^\\("
6361                                (if (string-equal "" (nth 0 entry))
6362                                    "[^\t ]"
6363                                  (nth 0 entry))
6364                                "\\)")
6365                 header-face (nth 1 entry)
6366                 field-face (nth 2 entry))
6367           (while (and (re-search-forward regexp nil t)
6368                       (not (eobp)))
6369             (beginning-of-line)
6370             (setq from (point))
6371             (unless (search-forward ":" nil t)
6372               (forward-char 1))
6373             (when (and header-face
6374                        (not (memq (point) hpoints)))
6375               (push (point) hpoints)
6376               (gnus-put-text-property from (point) 'face header-face))
6377             (when (and field-face
6378                        (not (memq (setq from (point)) fpoints)))
6379               (push from fpoints)
6380               (if (re-search-forward "^[^ \t]" nil t)
6381                   (forward-char -2)
6382                 (goto-char (point-max)))
6383               (gnus-put-text-property from (point) 'face field-face))))))))
6384
6385 (defun gnus-article-highlight-signature ()
6386   "Highlight the signature in an article.
6387 It does this by highlighting everything after
6388 `gnus-signature-separator' using `gnus-signature-face'."
6389   (interactive)
6390   (when gnus-signature-face
6391     (save-excursion
6392       (set-buffer gnus-article-buffer)
6393       (let ((buffer-read-only nil)
6394             (inhibit-point-motion-hooks t))
6395         (save-restriction
6396           (when (gnus-article-narrow-to-signature)
6397             (gnus-overlay-put (gnus-make-overlay (point-min) (point-max))
6398                               'face gnus-signature-face)))))))
6399
6400 (defun gnus-article-buttonize-signature ()
6401   "Add button to the signature."
6402   (interactive)
6403   (save-excursion
6404     (set-buffer gnus-article-buffer)
6405     (let ((buffer-read-only nil)
6406           (inhibit-point-motion-hooks t))
6407       (when (gnus-article-search-signature)
6408         (gnus-article-add-button (match-beginning 0) (match-end 0)
6409                                  'gnus-signature-toggle
6410                                  (set-marker (make-marker)
6411                                              (1+ (match-end 0))))))))
6412
6413 (defun gnus-button-in-region-p (b e prop)
6414   "Say whether PROP exists in the region."
6415   (text-property-not-all b e prop nil))
6416
6417 (defun gnus-article-add-buttons (&optional force)
6418   "Find external references in the article and make buttons of them.
6419 \"External references\" are things like Message-IDs and URLs, as
6420 specified by `gnus-button-alist'."
6421   (interactive (list 'force))
6422   (save-excursion
6423     (set-buffer gnus-article-buffer)
6424     (let ((buffer-read-only nil)
6425           (inhibit-point-motion-hooks t)
6426           (case-fold-search t)
6427           (alist gnus-button-alist)
6428           beg entry regexp)
6429       ;; Remove all old markers.
6430       (let (marker entry new-list)
6431         (while (setq marker (pop gnus-button-marker-list))
6432           (if (or (< marker (point-min)) (>= marker (point-max)))
6433               (push marker new-list)
6434             (goto-char marker)
6435             (when (setq entry (gnus-button-entry))
6436               (put-text-property (match-beginning (nth 1 entry))
6437                                  (match-end (nth 1 entry))
6438                                  'gnus-callback nil))
6439             (set-marker marker nil)))
6440         (setq gnus-button-marker-list new-list))
6441       ;; We skip the headers.
6442       (article-goto-body)
6443       (setq beg (point))
6444       (while (setq entry (pop alist))
6445         (setq regexp (eval (car entry)))
6446         (goto-char beg)
6447         (while (re-search-forward regexp nil t)
6448           (let* ((start (and entry (match-beginning (nth 1 entry))))
6449                  (end (and entry (match-end (nth 1 entry))))
6450                  (from (match-beginning 0)))
6451             (when (and (or (eq t (nth 2 entry))
6452                            (eval (nth 2 entry)))
6453                        (not (gnus-button-in-region-p
6454                              start end 'gnus-callback)))
6455               ;; That optional form returned non-nil, so we add the
6456               ;; button.
6457               (gnus-article-add-button
6458                start end 'gnus-button-push
6459                (car (push (set-marker (make-marker) from)
6460                           gnus-button-marker-list))))))))))
6461
6462 ;; Add buttons to the head of an article.
6463 (defun gnus-article-add-buttons-to-head ()
6464   "Add buttons to the head of the article."
6465   (interactive)
6466   (save-excursion
6467     (set-buffer gnus-article-buffer)
6468     (save-restriction
6469       (let ((buffer-read-only nil)
6470             (inhibit-point-motion-hooks t)
6471             (case-fold-search t)
6472             (alist gnus-header-button-alist)
6473             entry beg end)
6474         (article-narrow-to-head)
6475         (while alist
6476           ;; Each alist entry.
6477           (setq entry (car alist)
6478                 alist (cdr alist))
6479           (goto-char (point-min))
6480           (while (re-search-forward (car entry) nil t)
6481             ;; Each header matching the entry.
6482             (setq beg (match-beginning 0))
6483             (setq end (or (and (re-search-forward "^[^ \t]" nil t)
6484                                (match-beginning 0))
6485                           (point-max)))
6486             (goto-char beg)
6487             (while (re-search-forward (eval (nth 1 entry)) end t)
6488               ;; Each match within a header.
6489               (let* ((entry (cdr entry))
6490                      (start (match-beginning (nth 1 entry)))
6491                      (end (match-end (nth 1 entry)))
6492                      (form (nth 2 entry)))
6493                 (goto-char (match-end 0))
6494                 (when (eval form)
6495                   (gnus-article-add-button
6496                    start end (nth 3 entry)
6497                    (buffer-substring (match-beginning (nth 4 entry))
6498                                      (match-end (nth 4 entry)))))))
6499             (goto-char end)))))))
6500
6501 ;;; External functions:
6502
6503 (defun gnus-article-add-button (from to fun &optional data)
6504   "Create a button between FROM and TO with callback FUN and data DATA."
6505   (when gnus-article-button-face
6506     (gnus-overlay-put (gnus-make-overlay from to)
6507                       'face gnus-article-button-face))
6508   (gnus-add-text-properties
6509    from to
6510    (nconc (and gnus-article-mouse-face
6511                (list gnus-mouse-face-prop gnus-article-mouse-face))
6512           (list 'gnus-callback fun)
6513           (and data (list 'gnus-data data))))
6514   (widget-convert-button 'link from to :action 'gnus-widget-press-button
6515                          ;; Quote `:button-keymap' for Mule 2.3
6516                          ;; but it won't work.
6517                          ':button-keymap gnus-widget-button-keymap))
6518
6519 ;;; Internal functions:
6520
6521 (defun gnus-article-set-globals ()
6522   (save-excursion
6523     (set-buffer gnus-summary-buffer)
6524     (gnus-set-global-variables)))
6525
6526 (defun gnus-signature-toggle (end)
6527   (save-excursion
6528     (set-buffer gnus-article-buffer)
6529     (let ((buffer-read-only nil)
6530           (inhibit-point-motion-hooks t)
6531           (limit (next-single-property-change end 'mime-view-entity
6532                                               nil (point-max))))
6533       (if (text-property-any end limit 'article-type 'signature)
6534           (progn
6535             (gnus-delete-wash-type 'signature)
6536             (gnus-remove-text-properties-when
6537              'article-type 'signature end limit
6538              (cons 'article-type (cons 'signature
6539                                        gnus-hidden-properties))))
6540         (gnus-add-wash-type 'signature)
6541         (gnus-add-text-properties-when
6542          'article-type nil end limit
6543          (cons 'article-type (cons 'signature
6544                                    gnus-hidden-properties)))))
6545     (let ((gnus-article-mime-handle-alist-1 gnus-article-mime-handle-alist))
6546       (gnus-set-mode-line 'article))))
6547
6548 (defun gnus-button-entry ()
6549   ;; Return the first entry in `gnus-button-alist' matching this place.
6550   (let ((alist gnus-button-alist)
6551         (entry nil))
6552     (while alist
6553       (setq entry (pop alist))
6554       (if (looking-at (eval (car entry)))
6555           (setq alist nil)
6556         (setq entry nil)))
6557     entry))
6558
6559 (defun gnus-button-push (marker)
6560   ;; Push button starting at MARKER.
6561   (save-excursion
6562     (goto-char marker)
6563     (let* ((entry (gnus-button-entry))
6564            (inhibit-point-motion-hooks t)
6565            (fun (nth 3 entry))
6566            (args (mapcar (lambda (group)
6567                            (let ((string (match-string group)))
6568                              (gnus-set-text-properties
6569                               0 (length string) nil string)
6570                              string))
6571                          (nthcdr 4 entry))))
6572       (cond
6573        ((fboundp fun)
6574         (apply fun args))
6575        ((and (boundp fun)
6576              (fboundp (symbol-value fun)))
6577         (apply (symbol-value fun) args))
6578        (t
6579         (gnus-message 1 "You must define `%S' to use this button"
6580                       (cons fun args)))))))
6581
6582 (defun gnus-parse-news-url (url)
6583   (let (scheme server group message-id articles)
6584     (with-temp-buffer
6585       (insert url)
6586       (goto-char (point-min))
6587       (when (looking-at "\\([A-Za-z]+\\):")
6588         (setq scheme (match-string 1))
6589         (goto-char (match-end 0)))
6590       (when (looking-at "//\\([^/]+\\)/")
6591         (setq server (match-string 1))
6592         (goto-char (match-end 0)))
6593
6594       (cond
6595        ((looking-at "\\(.*@.*\\)")
6596         (setq message-id (match-string 1)))
6597        ((looking-at "\\([^/]+\\)/\\([-0-9]+\\)")
6598         (setq group (match-string 1)
6599               articles (split-string (match-string 2) "-")))
6600        ((looking-at "\\([^/]+\\)/?")
6601         (setq group (match-string 1)))
6602        (t
6603         (error "Unknown news URL syntax"))))
6604     (list scheme server group message-id articles)))
6605
6606 (defun gnus-button-handle-news (url)
6607   "Fetch a news URL."
6608   (destructuring-bind (scheme server group message-id articles)
6609       (gnus-parse-news-url url)
6610     (cond
6611      (message-id
6612       (save-excursion
6613         (set-buffer gnus-summary-buffer)
6614         (if server
6615             (let ((gnus-refer-article-method (list (list 'nntp server))))
6616               (gnus-summary-refer-article message-id))
6617           (gnus-summary-refer-article message-id))))
6618      (group
6619       (gnus-button-fetch-group url)))))
6620
6621 (defun gnus-button-handle-man (url)
6622   "Fetch a man page."
6623   (funcall gnus-button-man-handler url))
6624
6625 (defun gnus-button-handle-info (url)
6626   "Fetch an info URL."
6627   (if (string-match
6628        "^\\([^:/]+\\)?/\\(.*\\)"
6629        url)
6630       (gnus-info-find-node
6631        (concat "(" (or (gnus-url-unhex-string (match-string 1 url))
6632                        "Gnus")
6633                ")"
6634                (gnus-url-unhex-string (match-string 2 url))))
6635     (error "Can't parse %s" url)))
6636
6637 (defun gnus-button-message-id (message-id)
6638   "Fetch MESSAGE-ID."
6639   (save-excursion
6640     (set-buffer gnus-summary-buffer)
6641     (gnus-summary-refer-article message-id)))
6642
6643 (defun gnus-button-fetch-group (address)
6644   "Fetch GROUP specified by ADDRESS."
6645   (if (not (string-match "[:/]" address))
6646       ;; This is just a simple group url.
6647       (gnus-group-read-ephemeral-group address gnus-select-method)
6648     (if (not
6649          (string-match
6650           "^\\([^:/]+\\)\\(:\\([^/]+\\)\\)?/\\([^/]+\\)\\(/\\([0-9]+\\)\\)?"
6651           address))
6652         (error "Can't parse %s" address)
6653       (gnus-group-read-ephemeral-group
6654        (match-string 4 address)
6655        `(nntp ,(match-string 1 address)
6656               (nntp-address ,(match-string 1 address))
6657               (nntp-port-number ,(if (match-end 3)
6658                                      (match-string 3 address)
6659                                    "nntp")))
6660        nil nil nil
6661        (and (match-end 6) (list (string-to-int (match-string 6 address))))))))
6662
6663 (defun gnus-url-parse-query-string (query &optional downcase)
6664   (let (retval pairs cur key val)
6665     (setq pairs (split-string query "&"))
6666     (while pairs
6667       (setq cur (car pairs)
6668             pairs (cdr pairs))
6669       (if (not (string-match "=" cur))
6670           nil                           ; Grace
6671         (setq key (gnus-url-unhex-string (substring cur 0 (match-beginning 0)))
6672               val (gnus-url-unhex-string (substring cur (match-end 0) nil) t))
6673         (if downcase
6674             (setq key (downcase key)))
6675         (setq cur (assoc key retval))
6676         (if cur
6677             (setcdr cur (cons val (cdr cur)))
6678           (setq retval (cons (list key val) retval)))))
6679     retval))
6680
6681 (defun gnus-url-mailto (url)
6682   ;; Send mail to someone
6683   (when (string-match "mailto:/*\\(.*\\)" url)
6684     (setq url (substring url (match-beginning 1) nil)))
6685   (let (to args subject func)
6686     (if (string-match (regexp-quote "?") url)
6687         (setq to (gnus-url-unhex-string (substring url 0 (match-beginning 0)))
6688               args (gnus-url-parse-query-string
6689                     (substring url (match-end 0) nil) t))
6690       (setq to (gnus-url-unhex-string url)))
6691     (setq args (cons (list "to" to) args)
6692           subject (cdr-safe (assoc "subject" args)))
6693     (gnus-msg-mail)
6694     (while args
6695       (setq func (intern-soft (concat "message-goto-" (downcase (caar args)))))
6696       (if (fboundp func)
6697           (funcall func)
6698         (message-position-on-field (caar args)))
6699       (insert (mapconcat 'identity (cdar args) ", "))
6700       (setq args (cdr args)))
6701     (if subject
6702         (message-goto-body)
6703       (message-goto-subject))))
6704
6705 (defun gnus-button-embedded-url (address)
6706   "Activate ADDRESS with `browse-url'."
6707   (browse-url (gnus-strip-whitespace address)))
6708
6709 ;;; Next/prev buttons in the article buffer.
6710
6711 (defvar gnus-next-page-line-format "%{%(Next page...%)%}\n")
6712 (defvar gnus-prev-page-line-format "%{%(Previous page...%)%}\n")
6713
6714 (defvar gnus-prev-page-map
6715   (let ((map (make-sparse-keymap)))
6716     (unless (>= emacs-major-version 21)
6717       ;; XEmacs doesn't care.
6718       (set-keymap-parent map gnus-article-mode-map))
6719     (define-key map gnus-mouse-2 'gnus-button-prev-page)
6720     (define-key map "\r" 'gnus-button-prev-page)
6721     map))
6722
6723 (defun gnus-insert-prev-page-button ()
6724   (let ((b (point))
6725         (buffer-read-only nil)
6726         (situation (get-text-property (point-min) 'mime-view-situation)))
6727     (gnus-eval-format
6728      gnus-prev-page-line-format nil
6729      `(,@(gnus-local-map-property gnus-prev-page-map)
6730          gnus-prev t
6731          gnus-callback gnus-article-button-prev-page
6732          article-type annotation
6733          mime-view-situation ,situation))
6734     (widget-convert-button
6735      'link b (point)
6736      :action 'gnus-button-prev-page
6737      :button-keymap gnus-prev-page-map)))
6738
6739 (defvar gnus-next-page-map
6740   (let ((map (make-sparse-keymap)))
6741     (unless (>= emacs-major-version 21)
6742       ;; XEmacs doesn't care.
6743       (set-keymap-parent map gnus-article-mode-map))
6744     (define-key map gnus-mouse-2 'gnus-button-next-page)
6745     (define-key map "\r" 'gnus-button-next-page)
6746     map))
6747
6748 (defun gnus-button-next-page (&optional args more-args)
6749   "Go to the next page."
6750   (interactive)
6751   (let ((win (selected-window)))
6752     (select-window (gnus-get-buffer-window gnus-article-buffer t))
6753     (gnus-article-next-page)
6754     (select-window win)))
6755
6756 (defun gnus-button-prev-page (&optional args more-args)
6757   "Go to the prev page."
6758   (interactive)
6759   (let ((win (selected-window)))
6760     (select-window (gnus-get-buffer-window gnus-article-buffer t))
6761     (gnus-article-prev-page)
6762     (select-window win)))
6763
6764 (defun gnus-insert-next-page-button ()
6765   (let ((b (point))
6766         (buffer-read-only nil)
6767         (situation (get-text-property (point-min) 'mime-view-situation)))
6768     (gnus-eval-format gnus-next-page-line-format nil
6769                       `(,@(gnus-local-map-property gnus-next-page-map)
6770                           gnus-next t
6771                           gnus-callback gnus-article-button-next-page
6772                           article-type annotation
6773                           mime-view-situation ,situation))
6774     (widget-convert-button
6775      'link b (point)
6776      :action 'gnus-button-next-page
6777      :button-keymap gnus-next-page-map)))
6778
6779 (defun gnus-article-button-next-page (arg)
6780   "Go to the next page."
6781   (interactive "P")
6782   (let ((win (selected-window)))
6783     (select-window (gnus-get-buffer-window gnus-article-buffer t))
6784     (gnus-article-next-page)
6785     (select-window win)))
6786
6787 (defun gnus-article-button-prev-page (arg)
6788   "Go to the prev page."
6789   (interactive "P")
6790   (let ((win (selected-window)))
6791     (select-window (gnus-get-buffer-window gnus-article-buffer t))
6792     (gnus-article-prev-page)
6793     (select-window win)))
6794
6795 (defvar gnus-decode-header-methods
6796   '(mail-decode-encoded-word-region)
6797   "List of methods used to decode headers.
6798
6799 This variable is a list of FUNCTION or (REGEXP . FUNCTION).  If item
6800 is FUNCTION, FUNCTION will be apply to all newsgroups.  If item is a
6801 \(REGEXP . FUNCTION), FUNCTION will be only apply to thes newsgroups
6802 whose names match REGEXP.
6803
6804 For example:
6805 \((\"chinese\" . gnus-decode-encoded-word-region-by-guess)
6806  mail-decode-encoded-word-region
6807  (\"chinese\" . rfc1843-decode-region))
6808 ")
6809
6810 (defvar gnus-decode-header-methods-cache nil)
6811
6812 (defun gnus-multi-decode-header (start end)
6813   "Apply the functions from `gnus-encoded-word-methods' that match."
6814   (unless (and gnus-decode-header-methods-cache
6815                (eq gnus-newsgroup-name
6816                    (car gnus-decode-header-methods-cache)))
6817     (setq gnus-decode-header-methods-cache (list gnus-newsgroup-name))
6818     (mapcar (lambda (x)
6819               (if (symbolp x)
6820                   (nconc gnus-decode-header-methods-cache (list x))
6821                 (if (and gnus-newsgroup-name
6822                          (string-match (car x) gnus-newsgroup-name))
6823                     (nconc gnus-decode-header-methods-cache
6824                            (list (cdr x))))))
6825             gnus-decode-header-methods))
6826   (let ((xlist gnus-decode-header-methods-cache))
6827     (pop xlist)
6828     (save-restriction
6829       (narrow-to-region start end)
6830       (while xlist
6831         (funcall (pop xlist) (point-min) (point-max))))))
6832
6833 ;;;
6834 ;;; Treatment top-level handling.
6835 ;;;
6836
6837 (defun gnus-treat-article (condition &optional part-number total-parts type)
6838   (let ((length (- (point-max) (point-min)))
6839         (alist gnus-treatment-function-alist)
6840         (article-goto-body-goes-to-point-min-p t)
6841         (treated-type
6842          (or (not type)
6843              (catch 'found
6844                (let ((list gnus-article-treat-types))
6845                  (while list
6846                    (when (string-match (pop list) type)
6847                      (throw 'found t)))))))
6848         (highlightp (gnus-visual-p 'article-highlight 'highlight))
6849         (entity (static-unless (featurep 'xemacs)
6850                   (when (eq 'head condition)
6851                     (get-text-property (point-min) 'mime-view-entity))))
6852         val elem buttonized)
6853     (gnus-run-hooks 'gnus-part-display-hook)
6854     (unless gnus-inhibit-treatment
6855       (dolist (elem alist)
6856         (setq val
6857               (save-excursion
6858                 (when (gnus-buffer-live-p gnus-summary-buffer)
6859                   (set-buffer gnus-summary-buffer))
6860                 (symbol-value (car elem))))
6861         (when (and (or (consp val)
6862                        treated-type)
6863                    (gnus-treat-predicate val)
6864                    (or (not (get (car elem) 'highlight))
6865                        highlightp))
6866           (when (and (not buttonized)
6867                      (memq (car elem)
6868                            '(gnus-treat-hide-signature
6869                              gnus-treat-highlight-signature)))
6870             (gnus-article-buttonize-signature)
6871             (setq buttonized t))
6872           (save-restriction
6873             (funcall (cadr elem)))))
6874       ;; FSF Emacsen does not inherit the existing text properties
6875       ;; in the new text, so we should do it for `mime-view-entity'.
6876       (static-unless (featurep 'xemacs)
6877         (when entity
6878           (put-text-property (point-min) (point-max)
6879                              'mime-view-entity entity))))))
6880
6881 ;; Dynamic variables.
6882 (eval-when-compile
6883   (defvar part-number)
6884   (defvar total-parts)
6885   (defvar type)
6886   (defvar condition)
6887   (defvar length))
6888
6889 (defun gnus-treat-predicate (val)
6890   (cond
6891    ((null val)
6892     nil)
6893    (condition
6894     (eq condition val))
6895    ((and (listp val)
6896          (stringp (car val)))
6897     (apply 'gnus-or (mapcar `(lambda (s)
6898                                (string-match s ,(or gnus-newsgroup-name "")))
6899                             val)))
6900    ((listp val)
6901     (let ((pred (pop val)))
6902       (cond
6903        ((eq pred 'or)
6904         (apply 'gnus-or (mapcar 'gnus-treat-predicate val)))
6905        ((eq pred 'and)
6906         (apply 'gnus-and (mapcar 'gnus-treat-predicate val)))
6907        ((eq pred 'not)
6908         (not (gnus-treat-predicate (car val))))
6909        ((eq pred 'typep)
6910         (equal (car val) type))
6911        (t
6912         (error "%S is not a valid predicate" pred)))))
6913    ((eq val 'mime)
6914     gnus-show-mime)
6915    ((eq val t)
6916     t)
6917    ((eq val 'head)
6918     nil)
6919    ((eq val 'last)
6920     (eq part-number total-parts))
6921    ((numberp val)
6922     (< length val))
6923    (t
6924     (error "%S is not a valid value" val))))
6925
6926 (defun gnus-article-encrypt-body (protocol &optional n)
6927   "Encrypt the article body."
6928   (interactive
6929    (list
6930     (or gnus-article-encrypt-protocol
6931         (completing-read "Encrypt protocol: "
6932                          gnus-article-encrypt-protocol-alist
6933                          nil t))
6934     current-prefix-arg))
6935   (let ((func (cdr (assoc protocol gnus-article-encrypt-protocol-alist))))
6936     (unless func
6937       (error (format "Can't find the encrypt protocol %s" protocol)))
6938     (if (member gnus-newsgroup-name '("nndraft:delayed"
6939                                       "nndraft:drafts"
6940                                       "nndraft:queue"))
6941         (error "Can't encrypt the article in group %s"
6942                gnus-newsgroup-name))
6943     (gnus-summary-iterate n
6944       (save-excursion
6945         (set-buffer gnus-summary-buffer)
6946         (let ((mail-parse-charset gnus-newsgroup-charset)
6947               (mail-parse-ignored-charsets gnus-newsgroup-ignored-charsets)
6948               (summary-buffer gnus-summary-buffer)
6949               references point)
6950           (gnus-set-global-variables)
6951           (when (gnus-group-read-only-p)
6952             (error "The current newsgroup does not support article encrypt"))
6953           (gnus-summary-show-article t)
6954           (setq references
6955                 (or (mail-header-references gnus-current-headers) ""))
6956           (set-buffer gnus-article-buffer)
6957           (let* ((buffer-read-only nil)
6958                  (headers
6959                   (mapcar (lambda (field)
6960                             (and (save-restriction
6961                                    (message-narrow-to-head)
6962                                    (goto-char (point-min))
6963                                    (search-forward field nil t))
6964                                  (prog2
6965                                      (message-narrow-to-field)
6966                                      (buffer-substring (point-min) (point-max))
6967                                    (delete-region (point-min) (point-max))
6968                                    (widen))))
6969                           '("Content-Type:" "Content-Transfer-Encoding:"
6970                             "Content-Disposition:"))))
6971             (message-narrow-to-head)
6972             (message-remove-header "MIME-Version")
6973             (goto-char (point-max))
6974             (setq point (point))
6975             (insert (apply 'concat headers))
6976             (widen)
6977             (narrow-to-region point (point-max))
6978             (let ((message-options message-options))
6979               (message-options-set 'message-sender user-mail-address)
6980               (message-options-set 'message-recipients user-mail-address)
6981               (message-options-set 'message-sign-encrypt 'not)
6982               (funcall func))
6983             (goto-char (point-min))
6984             (insert "MIME-Version: 1.0\n")
6985             (widen)
6986             (gnus-summary-edit-article-done
6987              references nil summary-buffer t))
6988           (when gnus-keep-backlog
6989             (gnus-backlog-remove-article
6990              (car gnus-article-current) (cdr gnus-article-current)))
6991           (save-excursion
6992             (when (get-buffer gnus-original-article-buffer)
6993               (set-buffer gnus-original-article-buffer)
6994               (setq gnus-original-article nil)))
6995           (when gnus-use-cache
6996             (gnus-cache-update-article
6997              (car gnus-article-current) (cdr gnus-article-current))))))))
6998
6999 (defvar gnus-mime-security-button-line-format "%{%([[%t:%i]%D]%)%}\n"
7000   "The following specs can be used:
7001 %t  The security MIME type
7002 %i  Additional info
7003 %d  Details
7004 %D  Details if button is pressed")
7005
7006 (defvar gnus-mime-security-button-end-line-format "%{%([[End of %t]%D]%)%}\n"
7007   "The following specs can be used:
7008 %t  The security MIME type
7009 %i  Additional info
7010 %d  Details
7011 %D  Details if button is pressed")
7012
7013 (defvar gnus-mime-security-button-line-format-alist
7014   '((?t gnus-tmp-type ?s)
7015     (?i gnus-tmp-info ?s)
7016     (?d gnus-tmp-details ?s)
7017     (?D gnus-tmp-pressed-details ?s)))
7018
7019 (defvar gnus-mime-security-button-map
7020   (let ((map (make-sparse-keymap)))
7021     (unless (>= (string-to-number emacs-version) 21)
7022       (set-keymap-parent map gnus-article-mode-map))
7023     (define-key map gnus-mouse-2 'gnus-article-push-button)
7024     (define-key map "\r" 'gnus-article-press-button)
7025     map))
7026
7027 (defvar gnus-mime-security-details-buffer nil)
7028
7029 (defvar gnus-mime-security-button-pressed nil)
7030
7031 (defvar gnus-mime-security-show-details-inline t
7032   "If non-nil, show details in the article buffer.")
7033
7034 (defun gnus-mime-security-verify-or-decrypt (handle)
7035   (mm-remove-parts (cdr handle))
7036   (let ((region (mm-handle-multipart-ctl-parameter handle 'gnus-region))
7037         point buffer-read-only)
7038     (if region
7039         (goto-char (car region)))
7040     (save-restriction
7041       (narrow-to-region (point) (point))
7042       (with-current-buffer (mm-handle-multipart-original-buffer handle)
7043         (let* ((mm-verify-option 'known)
7044                (mm-decrypt-option 'known)
7045                (nparts (mm-possibly-verify-or-decrypt (cdr handle) handle)))
7046           (unless (eq nparts (cdr handle))
7047             (mm-destroy-parts (cdr handle))
7048             (setcdr handle nparts))))
7049       (setq point (point))
7050       (gnus-mime-display-security handle)
7051       (goto-char (point-max)))
7052     (when region
7053       (delete-region (point) (cdr region))
7054       (set-marker (car region) nil)
7055       (set-marker (cdr region) nil))
7056     (goto-char point)))
7057
7058 (defun gnus-mime-security-show-details (handle)
7059   (let ((details (mm-handle-multipart-ctl-parameter handle 'gnus-details)))
7060     (if details
7061         (if gnus-mime-security-show-details-inline
7062             (let ((gnus-mime-security-button-pressed t)
7063                   (gnus-mime-security-button-line-format
7064                    (get-text-property (point) 'gnus-line-format))
7065                   buffer-read-only)
7066               (forward-char -1)
7067               (while (eq (get-text-property (point) 'gnus-line-format)
7068                          gnus-mime-security-button-line-format)
7069                 (forward-char -1))
7070               (forward-char)
7071               (save-restriction
7072                 (narrow-to-region (point) (point))
7073                 (gnus-insert-mime-security-button handle))
7074               (delete-region (point)
7075                              (or (text-property-not-all
7076                                   (point) (point-max)
7077                                   'gnus-line-format
7078                                   gnus-mime-security-button-line-format)
7079                                  (point-max))))
7080           (if (gnus-buffer-live-p gnus-mime-security-details-buffer)
7081               (with-current-buffer gnus-mime-security-details-buffer
7082                 (erase-buffer)
7083                 t)
7084             (setq gnus-mime-security-details-buffer
7085                   (gnus-get-buffer-create "*MIME Security Details*")))
7086           (with-current-buffer gnus-mime-security-details-buffer
7087             (insert details)
7088             (goto-char (point-min)))
7089           (pop-to-buffer gnus-mime-security-details-buffer))
7090       (gnus-message 5 "No details."))))
7091
7092 (defun gnus-mime-security-press-button (handle)
7093   (if (mm-handle-multipart-ctl-parameter handle 'gnus-info)
7094       (gnus-mime-security-show-details handle)
7095     (gnus-mime-security-verify-or-decrypt handle)))
7096
7097 (defun gnus-insert-mime-security-button (handle &optional displayed)
7098   (let* ((protocol (mm-handle-multipart-ctl-parameter handle 'protocol))
7099          (gnus-tmp-type
7100           (concat
7101            (or (nth 2 (assoc protocol mm-verify-function-alist))
7102                (nth 2 (assoc protocol mm-decrypt-function-alist))
7103                "Unknown")
7104            (if (equal (car handle) "multipart/signed")
7105                " Signed" " Encrypted")
7106            " Part"))
7107          (gnus-tmp-info
7108           (or (mm-handle-multipart-ctl-parameter handle 'gnus-info)
7109               "Undecided"))
7110          (gnus-tmp-details
7111           (mm-handle-multipart-ctl-parameter handle 'gnus-details))
7112          gnus-tmp-pressed-details
7113          b e)
7114     (setq gnus-tmp-details
7115           (if gnus-tmp-details
7116               (concat "\n" gnus-tmp-details) ""))
7117     (setq gnus-tmp-pressed-details
7118           (if gnus-mime-security-button-pressed gnus-tmp-details ""))
7119     (unless (bolp)
7120       (insert "\n"))
7121     (setq b (point))
7122     (gnus-eval-format
7123      gnus-mime-security-button-line-format
7124      gnus-mime-security-button-line-format-alist
7125      `(,@(gnus-local-map-property gnus-mime-security-button-map)
7126          gnus-callback gnus-mime-security-press-button
7127          gnus-line-format ,gnus-mime-security-button-line-format
7128          article-type annotation
7129          gnus-data ,handle))
7130     (setq e (point))
7131     (widget-convert-button
7132      'link b e
7133      :mime-handle handle
7134      :action 'gnus-widget-press-button
7135      :button-keymap gnus-mime-security-button-map
7136      :help-echo
7137      (lambda (widget/window &optional overlay pos)
7138        ;; Needed to properly clear the message due to a bug in
7139        ;; wid-edit (XEmacs only).
7140        (if (boundp 'help-echo-owns-message)
7141            (setq help-echo-owns-message t))
7142        (format
7143         "%S: show detail"
7144         (aref gnus-mouse-2 0))))))
7145
7146 (defun gnus-mime-display-security (handle)
7147   (save-restriction
7148     (narrow-to-region (point) (point))
7149     (unless (gnus-unbuttonized-mime-type-p (car handle))
7150       (gnus-insert-mime-security-button handle))
7151     (gnus-mime-display-mixed (cdr handle))
7152     (unless (bolp)
7153       (insert "\n"))
7154     (unless (gnus-unbuttonized-mime-type-p (car handle))
7155       (let ((gnus-mime-security-button-line-format
7156              gnus-mime-security-button-end-line-format))
7157         (gnus-insert-mime-security-button handle)))
7158     (mm-set-handle-multipart-parameter
7159      handle 'gnus-region
7160      (cons (set-marker (make-marker) (point-min))
7161            (set-marker (make-marker) (point-max))))))
7162
7163
7164 ;;; @ for mime-view
7165 ;;;
7166
7167 (defun gnus-article-header-presentation-method (entity situation)
7168   (mime-insert-header entity)
7169   (article-decode-group-name))
7170
7171 (set-alist 'mime-header-presentation-method-alist
7172            'gnus-original-article-mode
7173            #'gnus-article-header-presentation-method)
7174
7175 (defun gnus-mime-preview-quitting-method ()
7176   (mime-preview-kill-buffer)
7177   (delete-other-windows)
7178   (gnus-article-show-summary)
7179   (gnus-summary-select-article gnus-show-all-headers t))
7180
7181 (set-alist 'mime-preview-quitting-method-alist
7182            'gnus-original-article-mode #'gnus-mime-preview-quitting-method)
7183
7184 (set-alist 'mime-preview-following-method-alist
7185            'gnus-original-article-mode #'gnus-following-method)
7186
7187 (set-alist 'mime-preview-over-to-previous-method-alist
7188            'gnus-original-article-mode
7189            (lambda ()
7190              (if (> (point-min) 1)
7191                  (gnus-article-prev-page)
7192                (gnus-article-read-summary-keys
7193                 nil (gnus-character-to-event ?P)))))
7194
7195 (set-alist 'mime-preview-over-to-next-method-alist
7196            'gnus-original-article-mode'
7197            (lambda ()
7198              (if (< (point-max) (buffer-size))
7199                  (gnus-article-next-page)
7200                (gnus-article-read-summary-keys
7201                 nil (gnus-character-to-event ?N)))))
7202
7203
7204 ;;; @ end
7205 ;;;
7206
7207 (gnus-ems-redefine)
7208
7209 (provide 'gnus-art)
7210
7211 (run-hooks 'gnus-art-load-hook)
7212
7213 ;;; gnus-art.el ends here