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