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