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