HCoop / bpt / emacs.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
(Fexpand_file_name): Fix last change.
[bpt/emacs.git] / lisp / gnus / gnus-art.el
CommitLineData
eec82323 1;;; gnus-art.el --- article mode commands for Gnus
e84b4b86
TTN		 2
3;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
e3fe4da0 4;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
eec82323 5
6748645f 6;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
eec82323
LMI		 7;; Keywords: news
8
9;; This file is part of GNU Emacs.
10
11;; GNU Emacs is free software; you can redistribute it and/or modify
12;; it under the terms of the GNU General Public License as published by
5a9dffec 13;; the Free Software Foundation; either version 3, or (at your option)
eec82323
LMI		 14;; any later version.
15
16;; GNU Emacs is distributed in the hope that it will be useful,
17;; but WITHOUT ANY WARRANTY; without even the implied warranty of
2ff9f5b4 18;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
eec82323
LMI		 19;; GNU General Public License for more details.
20
21;; You should have received a copy of the GNU General Public License
22;; along with GNU Emacs; see the file COPYING. If not, write to the
3a35cf56
LK		 23;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
24;; Boston, MA 02110-1301, USA.
eec82323
LMI		 25
26;;; Commentary:
27
28;;; Code:
29
9640c3bc
GM		 30;; For Emacs < 22.2.
31(eval-and-compile
32 (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
23f87bed 33(eval-when-compile
9efa445f
DN		 34 (require 'cl))
35(defvar tool-bar-map)
36(defvar w3m-minor-mode-map)
5ab7173c 37
eec82323 38(require 'gnus)
01c52d31
MB		 39;; Avoid the "Recursive load suspected" error in Emacs 21.1.
40(eval-and-compile
41 (let ((recursive-load-depth-limit 100))
42 (require 'gnus-sum)))
eec82323
LMI		 43(require 'gnus-spec)
44(require 'gnus-int)
23f87bed 45(require 'gnus-win)
16409b0b
GM		 46(require 'mm-bodies)
47(require 'mail-parse)
48(require 'mm-decode)
49(require 'mm-view)
50(require 'wid-edit)
51(require 'mm-uu)
23f87bed
MB		 52(require 'message)
53
54(autoload 'gnus-msg-mail "gnus-msg" nil t)
55(autoload 'gnus-button-mailto "gnus-msg")
56(autoload 'gnus-button-reply "gnus-msg" nil t)
498063ec 57(autoload 'parse-time-string "parse-time" nil nil)
01c52d31
MB		 58(autoload 'ansi-color-apply-on-region "ansi-color")
59(autoload 'mm-url-insert-file-contents-external "mm-url")
531bedc3 60(autoload 'mm-extern-cache-contents "mm-extern")
eec82323
LMI		 61
62(defgroup gnus-article nil
63 "Article display."
23f87bed 64 :link '(custom-manual "(gnus)Article Buffer")
eec82323
LMI		 65 :group 'gnus)
66
16409b0b
GM		 67(defgroup gnus-article-treat nil
68 "Treating article parts."
69 :link '(custom-manual "(gnus)Article Hiding")
70 :group 'gnus-article)
71
eec82323
LMI		 72(defgroup gnus-article-hiding nil
73 "Hiding article parts."
74 :link '(custom-manual "(gnus)Article Hiding")
75 :group 'gnus-article)
76
77(defgroup gnus-article-highlight nil
78 "Article highlighting."
79 :link '(custom-manual "(gnus)Article Highlighting")
80 :group 'gnus-article
81 :group 'gnus-visual)
82
83(defgroup gnus-article-signature nil
84 "Article signatures."
85 :link '(custom-manual "(gnus)Article Signature")
86 :group 'gnus-article)
87
88(defgroup gnus-article-headers nil
89 "Article headers."
90 :link '(custom-manual "(gnus)Hiding Headers")
91 :group 'gnus-article)
92
93(defgroup gnus-article-washing nil
94 "Special commands on articles."
95 :link '(custom-manual "(gnus)Article Washing")
96 :group 'gnus-article)
97
98(defgroup gnus-article-emphasis nil
99 "Fontisizing articles."
100 :link '(custom-manual "(gnus)Article Fontisizing")
101 :group 'gnus-article)
102
103(defgroup gnus-article-saving nil
104 "Saving articles."
105 :link '(custom-manual "(gnus)Saving Articles")
106 :group 'gnus-article)
107
108(defgroup gnus-article-mime nil
109 "Worshiping the MIME wonder."
110 :link '(custom-manual "(gnus)Using MIME")
111 :group 'gnus-article)
112
113(defgroup gnus-article-buttons nil
114 "Pushable buttons in the article buffer."
115 :link '(custom-manual "(gnus)Article Buttons")
116 :group 'gnus-article)
117
118(defgroup gnus-article-various nil
119 "Other article options."
120 :link '(custom-manual "(gnus)Misc Article")
121 :group 'gnus-article)
122
123(defcustom gnus-ignored-headers
23f87bed
MB		 124 (mapcar
125 (lambda (header)
126 (concat "^" header ":"))
127 '("Path" "Expires" "Date-Received" "References" "Xref" "Lines"
128 "Relay-Version" "Message-ID" "Approved" "Sender" "Received"
129 "X-UIDL" "MIME-Version" "Return-Path" "In-Reply-To"
130 "Content-Type" "Content-Transfer-Encoding" "X-WebTV-Signature"
131 "X-MimeOLE" "X-MSMail-Priority" "X-Priority" "X-Loop"
132 "X-Authentication-Warning" "X-MIME-Autoconverted" "X-Face"
133 "X-Attribution" "X-Originating-IP" "Delivered-To"
134 "NNTP-[-A-Za-z]+" "Distribution" "X-no-archive" "X-Trace"
135 "X-Complaints-To" "X-NNTP-Posting-Host" "X-Orig.*"
136 "Abuse-Reports-To" "Cache-Post-Path" "X-Article-Creation-Date"
137 "X-Poster" "X-Mail2News-Path" "X-Server-Date" "X-Cache"
138 "Originator" "X-Problems-To" "X-Auth-User" "X-Post-Time"
139 "X-Admin" "X-UID" "Resent-[-A-Za-z]+" "X-Mailing-List"
140 "Precedence" "Original-[-A-Za-z]+" "X-filename" "X-Orcpt"
141 "Old-Received" "X-Pgp" "X-Auth" "X-From-Line"
142 "X-Gnus-Article-Number" "X-Majordomo" "X-Url" "X-Sender"
143 "MBOX-Line" "Priority" "X400-[-A-Za-z]+"
144 "Status" "X-Gnus-Mail-Source" "Cancel-Lock"
145 "X-FTN" "X-EXP32-SerialNo" "Encoding" "Importance"
146 "Autoforwarded" "Original-Encoded-Information-Types" "X-Ya-Pop3"
147 "X-Face-Version" "X-Vms-To" "X-ML-NAME" "X-ML-COUNT"
148 "Mailing-List" "X-finfo" "X-md5sum" "X-md5sum-Origin"
149 "X-Sun-Charset" "X-Accept-Language" "X-Envelope-Sender"
150 "List-[A-Za-z]+" "X-Listprocessor-Version"
151 "X-Received" "X-Distribute" "X-Sequence" "X-Juno-Line-Breaks"
152 "X-Notes-Item" "X-MS-TNEF-Correlator" "x-uunet-gateway"
153 "X-Received" "Content-length" "X-precedence"
154 "X-Authenticated-User" "X-Comment" "X-Report" "X-Abuse-Info"
155 "X-HTTP-Proxy" "X-Mydeja-Info" "X-Copyright" "X-No-Markup"
156 "X-Abuse-Info" "X-From_" "X-Accept-Language" "Errors-To"
157 "X-BeenThere" "X-Mailman-Version" "List-Help" "List-Post"
158 "List-Subscribe" "List-Id" "List-Unsubscribe" "List-Archive"
159 "X-Content-length" "X-Posting-Agent" "Original-Received"
160 "X-Request-PGP" "X-Fingerprint" "X-WRIEnvto" "X-WRIEnvfrom"
161 "X-Virus-Scanned" "X-Delivery-Agent" "Posted-Date" "X-Gateway"
162 "X-Local-Origin" "X-Local-Destination" "X-UserInfo1"
163 "X-Received-Date" "X-Hashcash" "Face" "X-DMCA-Notifications"
01c52d31
MB		 164 "X-Abuse-and-DMCA-Info" "X-Postfilter" "X-Gpg-.*" "X-Disclaimer"
165 "Envelope-To" "X-Spam-Score" "System-Type" "X-Injected-Via-Gmane"
166 "X-Gmane-NNTP-Posting-Host" "Jabber-ID" "Archived-At"
167 "Envelope-Sender" "Envelope-Recipients"))
6748645f 168 "*All headers that start with this regexp will be hidden.
eec82323
LMI		 169This variable can also be a list of regexps of headers to be ignored.
170If `gnus-visible-headers' is non-nil, this variable will be ignored."
171 :type '(choice :custom-show nil
172 regexp
173 (repeat regexp))
174 :group 'gnus-article-hiding)
175
176(defcustom gnus-visible-headers
23f87bed 177 "^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 178 "*All headers that do not match this regexp will be hidden.
eec82323
LMI		 179This variable can also be a list of regexp of headers to remain visible.
180If this variable is non-nil, `gnus-ignored-headers' will be ignored."
181 :type '(repeat :value-to-internal (lambda (widget value)
182 (custom-split-regexp-maybe value))
183 :match (lambda (widget value)
184 (or (stringp value)
185 (widget-editable-list-match widget value)))
186 regexp)
187 :group 'gnus-article-hiding)
188
189(defcustom gnus-sorted-header-list
190 '("^From:" "^Subject:" "^Summary:" "^Keywords:" "^Newsgroups:"
191 "^Followup-To:" "^To:" "^Cc:" "^Date:" "^Organization:")
6748645f 192 "*This variable is a list of regular expressions.
eec82323
LMI		 193If it is non-nil, headers that match the regular expressions will
194be placed first in the article buffer in the sequence specified by
195this list."
196 :type '(repeat regexp)
197 :group 'gnus-article-hiding)
198
199(defcustom gnus-boring-article-headers '(empty followup-to reply-to)
200 "Headers that are only to be displayed if they have interesting data.
23f87bed
MB		 201Possible values in this list are:
202
203 'empty Headers with no content.
204 'newsgroups Newsgroup identical to Gnus group.
205 'to-address To identical to To-address.
206 'to-list To identical to To-list.
207 'cc-list CC identical to To-list.
208 'followup-to Followup-to identical to Newsgroups.
209 'reply-to Reply-to identical to From.
210 'date Date less than four days old.
211 'long-to To and/or Cc longer than 1024 characters.
212 'many-to Multiple To and/or Cc."
eec82323 213 :type '(set (const :tag "Headers with no content." empty)
23f87bed
MB		 214 (const :tag "Newsgroups identical to Gnus group." newsgroups)
215 (const :tag "To identical to To-address." to-address)
216 (const :tag "To identical to To-list." to-list)
217 (const :tag "CC identical to To-list." cc-list)
218 (const :tag "Followup-to identical to Newsgroups." followup-to)
219 (const :tag "Reply-to identical to From." reply-to)
6748645f 220 (const :tag "Date less than four days old." date)
23f87bed 221 (const :tag "To and/or Cc longer than 1024 characters." long-to)
16409b0b 222 (const :tag "Multiple To and/or Cc headers." many-to))
eec82323
LMI		 223 :group 'gnus-article-hiding)
224
23f87bed
MB		 225(defcustom gnus-article-skip-boring nil
226 "Skip over text that is not worth reading.
227By default, if you set this t, then Gnus will display citations and
228signatures, but will never scroll down to show you a page consisting
229only of boring text. Boring text is controlled by
230`gnus-article-boring-faces'."
bf247b6e 231 :version "22.1"
23f87bed
MB		 232 :type 'boolean
233 :group 'gnus-article-hiding)
234
eec82323
LMI		 235(defcustom gnus-signature-separator '("^-- $" "^-- *$")
236 "Regexp matching signature separator.
237This can also be a list of regexps. In that case, it will be checked
238from head to tail looking for a separator. Searches will be done from
239the end of the buffer."
3031d8b0
MB		 240 :type '(choice :format "%{%t%}: %[Value Menu%]\n%v"
241 (regexp)
242 (repeat :tag "List of regexp" regexp))
eec82323
LMI		 243 :group 'gnus-article-signature)
244
245(defcustom gnus-signature-limit nil
16409b0b 246 "Provide a limit to what is considered a signature.
eec82323
LMI		 247If it is a number, no signature may not be longer (in characters) than
248that number. If it is a floating point number, no signature may be
249longer (in lines) than that number. If it is a function, the function
250will be called without any parameters, and if it returns nil, there is
251no signature in the buffer. If it is a string, it will be used as a
01c52d31
MB		 252regexp. If it matches, the text in question is not a signature.
253
254This can also be a list of the above values."
4a2358e9
MB		 255 :type '(choice (const nil)
256 (integer :value 200)
6748645f 257 (number :value 4.0)
b28080e3 258 function
6748645f 259 (regexp :value ".*"))
eec82323
LMI		 260 :group 'gnus-article-signature)
261
262(defcustom gnus-hidden-properties '(invisible t intangible t)
263 "Property list to use for hiding text."
264 :type 'sexp
265 :group 'gnus-article-hiding)
266
23f87bed
MB		 267;; Fixme: This isn't the right thing for mixed graphical and non-graphical
268;; frames in a session.
eec82323 269(defcustom gnus-article-x-face-command
23f87bed
MB		 270 (if (featurep 'xemacs)
271 (if (or (gnus-image-type-available-p 'xface)
272 (gnus-image-type-available-p 'pbm))
273 'gnus-display-x-face-in-from
274 "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | ee -")
275 (if (gnus-image-type-available-p 'pbm)
276 'gnus-display-x-face-in-from
e0bad764
DL		 277 "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | \
278display -"))
6748645f 279 "*String or function to be executed to display an X-Face header.
eec82323 280If it is a string, the command will be executed in a sub-shell
2ff9f5b4 281asynchronously. The compressed face will be piped to this command."
23f87bed
MB		 282 :type `(choice string
283 (function-item gnus-display-x-face-in-from)
16409b0b 284 function)
b5a206e7 285 :version "21.1"
23f87bed 286 :group 'gnus-picon
eec82323
LMI		 287 :group 'gnus-article-washing)
288
289(defcustom gnus-article-x-face-too-ugly nil
290 "Regexp matching posters whose face shouldn't be shown automatically."
4bb6a3a6 291 :type '(choice regexp (const nil))
eec82323
LMI		 292 :group 'gnus-article-washing)
293
e0bad764
DL		 294(defcustom gnus-article-banner-alist nil
295 "Banner alist for stripping.
a1506d29 296For example,
23f87bed 297 ((egroups . \"^[ \\t\\n]*-------------------+\\\\( \\\\(e\\\\|Yahoo! \\\\)Groups Sponsor -+\\\\)?....\\n\\\\(.+\\n\\\\)+\"))"
fc2c2db8 298 :version "21.1"
e0bad764
DL		 299 :type '(repeat (cons symbol regexp))
300 :group 'gnus-article-washing)
301
23f87bed
MB		 302(gnus-define-group-parameter
303 banner
304 :variable-document
305 "Alist of regexps (to match group names) and banner."
306 :variable-group gnus-article-washing
307 :parameter-type
308 '(choice :tag "Banner"
309 :value nil
310 (const :tag "Remove signature" signature)
311 (symbol :tag "Item in `gnus-article-banner-alist'" none)
312 regexp
313 (const :tag "None" nil))
314 :parameter-document
315 "If non-nil, specify how to remove `banners' from articles.
316
317Symbol `signature' means to remove signatures delimited by
318`gnus-signature-separator'. Any other symbol is used to look up a
319regular expression to match the banner in `gnus-article-banner-alist'.
320A string is used as a regular expression to match the banner
321directly.")
322
323(defcustom gnus-article-address-banner-alist nil
324 "Alist of mail addresses and banners.
325Each element has the form (ADDRESS . BANNER), where ADDRESS is a regexp
326to match a mail address in the From: header, BANNER is one of a symbol
327`signature', an item in `gnus-article-banner-alist', a regexp and nil.
328If ADDRESS matches author's mail address, it will remove things like
329advertisements. For example:
330
331\((\"@yoo-hoo\\\\.co\\\\.jp\\\\'\" . \"\\n_+\\nDo You Yoo-hoo!\\\\?\\n.*\\n.*\\n\"))
332"
333 :type '(repeat
334 (cons
335 (regexp :tag "Address")
336 (choice :tag "Banner" :value nil
337 (const :tag "Remove signature" signature)
338 (symbol :tag "Item in `gnus-article-banner-alist'" none)
339 regexp
340 (const :tag "None" nil))))
bf247b6e 341 :version "22.1"
23f87bed
MB		 342 :group 'gnus-article-washing)
343
ae465fa7
MB		 344(defmacro gnus-emphasis-custom-with-format (&rest body)
345 `(let ((format "\
346\\(\\s-\\|^\\|\\=\\|[-\"]\\|\\s(\\)\\(%s\\(\\w+\\(\\s-+\\w+\\)*[.,]?\\)%s\\)\
347\\(\\([-,.;:!?\"]\\|\\s)\\)+\\s-\\|[?!.]\\s-\\|\\s)\\|\\s-\\)"))
348 ,@body))
349
350(defun gnus-emphasis-custom-value-to-external (value)
351 (gnus-emphasis-custom-with-format
352 (if (consp (car value))
353 (list (format format (car (car value)) (cdr (car value)))
354 2
355 (if (nth 1 value) 2 3)
356 (nth 2 value))
357 value)))
358
359(defun gnus-emphasis-custom-value-to-internal (value)
360 (gnus-emphasis-custom-with-format
361 (let ((regexp (concat "\\`"
362 (format (regexp-quote format)
363 "\\([^()]+\\)" "\\([^()]+\\)")
364 "\\'"))
365 pattern)
366 (if (string-match regexp (setq pattern (car value)))
367 (list (cons (match-string 1 pattern) (match-string 2 pattern))
368 (= (nth 2 value) 2)
369 (nth 3 value))
370 value))))
371
eec82323 372(defcustom gnus-emphasis-alist
ae465fa7
MB		 373 (let ((types
374 '(("\\*" "\\*" bold nil 2)
23f87bed 375 ("_" "_" underline)
eec82323 376 ("/" "/" italic)
eec82323
LMI		 377 ("_/" "/_" underline-italic)
378 ("_\\*" "\\*_" underline-bold)
379 ("\\*/" "/\\*" bold-italic)
380 ("_\\*/" "/\\*_" underline-bold-italic))))
ae465fa7
MB		 381 (nconc
382 (gnus-emphasis-custom-with-format
383 (mapcar (lambda (spec)
384 (list (format format (car spec) (cadr spec))
385 (or (nth 3 spec) 2)
386 (or (nth 4 spec) 3)
387 (intern (format "gnus-emphasis-%s" (nth 2 spec)))))
388 types))
95f75c75
SM		 389 '(;; I've never seen anyone use this strikethru convention whereas I've
390 ;; several times seen it triggered by normal text. --Stef
391 ;; Miles suggests that this form is sometimes used but for italics,
392 ;; so maybe we should map it to `italic'.
393 ;; ("\\(\\s-\\|^\\)\\(-\\(\\(\\w\\|-[^-]\\)+\\)-\\)\\(\\s-\\|[?!.,;]\\)"
394 ;; 2 3 gnus-emphasis-strikethru)
ae465fa7
MB		 395 ("\\(\\s-\\|^\\)\\(_\\(\\(\\w\\|_[^_]\\)+\\)_\\)\\(\\s-\\|[?!.,;]\\)"
396 2 3 gnus-emphasis-underline))))
6748645f 397 "*Alist that says how to fontify certain phrases.
eec82323
LMI		 398Each item looks like this:
399
400 (\"_\\\\(\\\\w+\\\\)_\" 0 1 'underline)
401
402The first element is a regular expression to be matched. The second
403is a number that says what regular expression grouping used to find
404the entire emphasized word. The third is a number that says what
405regexp grouping should be displayed and highlighted. The fourth
406is the face used for highlighting."
ae465fa7
MB		 407 :type
408 '(repeat
409 (menu-choice
410 :format "%[Customizing Style%]\n%v"
411 :indent 2
412 (group :tag "Default"
413 :value ("" 0 0 default)
414 :value-create
415 (lambda (widget)
416 (let ((value (widget-get
417 (cadr (widget-get (widget-get widget :parent)
418 :args))
419 :value)))
420 (if (not (eq (nth 2 value) 'default))
421 (widget-put
422 widget
423 :value
424 (gnus-emphasis-custom-value-to-external value))))
425 (widget-group-value-create widget))
ad136a7c
MB		 426 regexp
427 (integer :format "Match group: %v")
01c52d31 428 (integer :format "Emphasize group: %v")
ae465fa7
MB		 429 face)
430 (group :tag "Simple"
431 :value (("_" . "_") nil default)
432 (cons :format "%v"
ad136a7c
MB		 433 (regexp :format "Start regexp: %v")
434 (regexp :format "End regexp: %v"))
ae465fa7
MB		 435 (boolean :format "Show start and end patterns: %[%v%]\n"
436 :on " On " :off " Off ")
437 face)))
438 :get (lambda (symbol)
439 (mapcar 'gnus-emphasis-custom-value-to-internal
440 (default-value symbol)))
441 :set (lambda (symbol value)
442 (set-default symbol (mapcar 'gnus-emphasis-custom-value-to-external
443 value)))
eec82323
LMI		 444 :group 'gnus-article-emphasis)
445
16409b0b
GM		 446(defcustom gnus-emphasize-whitespace-regexp "^[ \t]+\\|[ \t]*\n"
447 "A regexp to describe whitespace which should not be emphasized.
448Typical values are \"^[ \\t]+\\\\|[ \\t]*\\n\" and \"[ \\t]+\\\\|[ \\t]*\\n\".
449The former avoids underlining of leading and trailing whitespace,
450and the latter avoids underlining any whitespace at all."
fc2c2db8 451 :version "21.1"
16409b0b
GM		 452 :group 'gnus-article-emphasis
453 :type 'regexp)
454
23f87bed 455(defface gnus-emphasis-bold '((t (:bold t)))
eec82323
LMI		 456 "Face used for displaying strong emphasized text (*word*)."
457 :group 'gnus-article-emphasis)
458
23f87bed 459(defface gnus-emphasis-italic '((t (:italic t)))
eec82323
LMI		 460 "Face used for displaying italic emphasized text (/word/)."
461 :group 'gnus-article-emphasis)
462
463(defface gnus-emphasis-underline '((t (:underline t)))
464 "Face used for displaying underlined emphasized text (_word_)."
465 :group 'gnus-article-emphasis)
466
23f87bed 467(defface gnus-emphasis-underline-bold '((t (:bold t :underline t)))
eec82323
LMI		 468 "Face used for displaying underlined bold emphasized text (_*word*_)."
469 :group 'gnus-article-emphasis)
470
23f87bed 471(defface gnus-emphasis-underline-italic '((t (:italic t :underline t)))
8de38c21 472 "Face used for displaying underlined italic emphasized text (_/word/_)."
eec82323
LMI		 473 :group 'gnus-article-emphasis)
474
23f87bed 475(defface gnus-emphasis-bold-italic '((t (:bold t :italic t)))
eec82323
LMI		 476 "Face used for displaying bold italic emphasized text (/*word*/)."
477 :group 'gnus-article-emphasis)
478
479(defface gnus-emphasis-underline-bold-italic
23f87bed 480 '((t (:bold t :italic t :underline t)))
eec82323 481 "Face used for displaying underlined bold italic emphasized text.
8f688cb0 482Example: (_/*word*/_)."
eec82323
LMI		 483 :group 'gnus-article-emphasis)
484
23f87bed
MB		 485(defface gnus-emphasis-strikethru (if (featurep 'xemacs)
486 '((t (:strikethru t)))
487 '((t (:strike-through t))))
488 "Face used for displaying strike-through text (-word-)."
489 :group 'gnus-article-emphasis)
490
16409b0b
GM		 491(defface gnus-emphasis-highlight-words
492 '((t (:background "black" :foreground "yellow")))
493 "Face used for displaying highlighted words."
494 :group 'gnus-article-emphasis)
495
01c52d31 496(defcustom gnus-article-time-format "%a, %d %b %Y %T %Z"
eec82323 497 "Format for display of Date headers in article bodies.
6748645f
LMI		 498See `format-time-string' for the possible values.
499
500The variable can also be function, which should return a complete Date
501header. The function is called with one argument, the time, which can
502be fed to `format-time-string'."
01c52d31 503 :type '(choice string function)
eec82323
LMI		 504 :link '(custom-manual "(gnus)Article Date")
505 :group 'gnus-article-washing)
506
eec82323 507(defcustom gnus-save-all-headers t
26c9afc3
MB		 508 "*If non-nil, don't remove any headers before saving.
509This will be overridden by the `:headers' property that the symbol of
510the saver function, which is specified by `gnus-default-article-saver',
511might have."
eec82323
LMI		 512 :group 'gnus-article-saving
513 :type 'boolean)
514
515(defcustom gnus-prompt-before-saving 'always
516 "*This variable says how much prompting is to be done when saving articles.
517If it is nil, no prompting will be done, and the articles will be
518saved to the default files. If this variable is `always', each and
519every article that is saved will be preceded by a prompt, even when
520saving large batches of articles. If this variable is neither nil not
521`always', there the user will be prompted once for a file name for
522each invocation of the saving commands."
523 :group 'gnus-article-saving
524 :type '(choice (item always)
525 (item :tag "never" nil)
6748645f 526 (sexp :tag "once" :format "%t\n" :value t)))
eec82323
LMI		 527
528(defcustom gnus-saved-headers gnus-visible-headers
529 "Headers to keep if `gnus-save-all-headers' is nil.
530If `gnus-save-all-headers' is non-nil, this variable will be ignored.
531If that variable is nil, however, all headers that match this regexp
26c9afc3
MB		 532will be kept while the rest will be deleted before saving. This and
533`gnus-save-all-headers' will be overridden by the `:headers' property
534that the symbol of the saver function, which is specified by
535`gnus-default-article-saver', might have."
eec82323 536 :group 'gnus-article-saving
4bb6a3a6 537 :type 'regexp)
eec82323
LMI		 538
539(defcustom gnus-default-article-saver 'gnus-summary-save-in-rmail
540 "A function to save articles in your favourite format.
26c9afc3
MB		 541The function will be called by way of the `gnus-summary-save-article'
542command, and friends such as `gnus-summary-save-article-rmail'.
eec82323
LMI		 543
544Gnus provides the following functions:
545
546* gnus-summary-save-in-rmail (Rmail format)
547* gnus-summary-save-in-mail (Unix mail format)
548* gnus-summary-save-in-folder (MH folder)
549* gnus-summary-save-in-file (article format)
23f87bed 550* gnus-summary-save-body-in-file (article body)
eec82323 551* gnus-summary-save-in-vm (use VM's folder format)
26c9afc3
MB		 552* gnus-summary-write-to-file (article format -- overwrite)
553* gnus-summary-write-body-to-file (article body -- overwrite)
554
555The symbol of each function may have the following properties:
556
557* :decode
558The value non-nil means save decoded articles. This is meaningful
559only with `gnus-summary-save-in-file', `gnus-summary-save-body-in-file',
560`gnus-summary-write-to-file', and `gnus-summary-write-body-to-file'.
561
562* :function
563The value specifies an alternative function which appends, not
564overwrites, articles to a file. This implies that when saving many
565articles at a time, `gnus-prompt-before-saving' is bound to t and all
566articles are saved in a single file. This is meaningful only with
567`gnus-summary-write-to-file' and `gnus-summary-write-body-to-file'.
568
569* :headers
570The value specifies the symbol of a variable of which the value
571specifies headers to be saved. If it is omitted,
572`gnus-save-all-headers' and `gnus-saved-headers' control what
573headers should be saved."
eec82323
LMI		 574 :group 'gnus-article-saving
575 :type '(radio (function-item gnus-summary-save-in-rmail)
576 (function-item gnus-summary-save-in-mail)
577 (function-item gnus-summary-save-in-folder)
578 (function-item gnus-summary-save-in-file)
23f87bed 579 (function-item gnus-summary-save-body-in-file)
eec82323 580 (function-item gnus-summary-save-in-vm)
58090a8d 581 (function-item gnus-summary-write-to-file)
26c9afc3 582 (function-item gnus-summary-write-body-to-file)
58090a8d 583 (function)))
eec82323 584
26c9afc3
MB		 585(defcustom gnus-article-save-coding-system
586 (or (and (mm-coding-system-p 'utf-8) 'utf-8)
587 (and (mm-coding-system-p 'iso-2022-7bit) 'iso-2022-7bit)
588 (and (mm-coding-system-p 'emacs-mule) 'emacs-mule)
589 (and (mm-coding-system-p 'escape-quoted) 'escape-quoted))
590 "Coding system used to save decoded articles to a file.
591
592The recommended coding systems are `utf-8', `iso-2022-7bit' and so on,
593which can safely encode any characters in text. This is used by the
594commands including:
595
596* gnus-summary-save-article-file
597* gnus-summary-save-article-body-file
598* gnus-summary-write-article-file
599* gnus-summary-write-article-body-file
600
601and the functions to which you may set `gnus-default-article-saver':
602
603* gnus-summary-save-in-file
604* gnus-summary-save-body-in-file
605* gnus-summary-write-to-file
606* gnus-summary-write-body-to-file
607
608Those commands and functions save just text displayed in the article
609buffer to a file if the value of this variable is non-nil. Note that
610buttonized MIME parts will be lost in a saved file in that case.
611Otherwise, raw articles will be saved."
612 :group 'gnus-article-saving
613 :type `(choice
614 :format "%{%t%}:\n %[Value Menu%] %v"
615 (const :tag "Save raw articles" nil)
616 ,@(delq nil
617 (mapcar
618 (lambda (arg) (if (mm-coding-system-p (nth 3 arg)) arg))
619 '((const :tag "UTF-8" utf-8)
620 (const :tag "iso-2022-7bit" iso-2022-7bit)
621 (const :tag "Emacs internal" emacs-mule)
622 (const :tag "escape-quoted" escape-quoted))))
623 (symbol :tag "Coding system")))
624
eec82323
LMI		 625(defcustom gnus-rmail-save-name 'gnus-plain-save-name
626 "A function generating a file name to save articles in Rmail format.
627The function is called with NEWSGROUP, HEADERS, and optional LAST-FILE."
628 :group 'gnus-article-saving
629 :type 'function)
630
631(defcustom gnus-mail-save-name 'gnus-plain-save-name
632 "A function generating a file name to save articles in Unix mail format.
633The function is called with NEWSGROUP, HEADERS, and optional LAST-FILE."
634 :group 'gnus-article-saving
635 :type 'function)
636
637(defcustom gnus-folder-save-name 'gnus-folder-save-name
638 "A function generating a file name to save articles in MH folder.
639The function is called with NEWSGROUP, HEADERS, and optional LAST-FOLDER."
640 :group 'gnus-article-saving
641 :type 'function)
642
643(defcustom gnus-file-save-name 'gnus-numeric-save-name
644 "A function generating a file name to save articles in article format.
645The function is called with NEWSGROUP, HEADERS, and optional
646LAST-FILE."
647 :group 'gnus-article-saving
648 :type 'function)
649
650(defcustom gnus-split-methods
651 '((gnus-article-archive-name)
652 (gnus-article-nndoc-name))
6748645f 653 "*Variable used to suggest where articles are to be saved.
eec82323
LMI		 654For instance, if you would like to save articles related to Gnus in
655the file \"gnus-stuff\", and articles related to VM in \"vm-stuff\",
656you could set this variable to something like:
657
658 '((\"^Subject:.*gnus\\|^Newsgroups:.*gnus\" \"gnus-stuff\")
659 (\"^Subject:.*vm\\|^Xref:.*vm\" \"vm-stuff\"))
660
01c52d31
MB		 661This variable is an alist where the key is the match and the
662value is a list of possible files to save in if the match is
663non-nil.
eec82323
LMI		 664
665If the match is a string, it is used as a regexp match on the
666article. If the match is a symbol, that symbol will be funcalled
667from the buffer of the article to be saved with the newsgroup as the
01c52d31 668parameter. If it is a list, it will be evaled in the same buffer.
eec82323 669
01c52d31
MB		 670If this form or function returns a string, this string will be used as a
671possible file name; and if it returns a non-nil list, that list will be
672used as possible file names."
eec82323 673 :group 'gnus-article-saving
6748645f
LMI		 674 :type '(repeat (choice (list :value (fun) function)
675 (cons :value ("" "") regexp (repeat string))
676 (sexp :value nil))))
eec82323 677
eec82323
LMI		 678(defcustom gnus-page-delimiter "^\^L"
679 "*Regexp describing what to use as article page delimiters.
680The default value is \"^\^L\", which is a form linefeed at the
681beginning of a line."
682 :type 'regexp
683 :group 'gnus-article-various)
684
16409b0b 685(defcustom gnus-article-mode-line-format "Gnus: %g [%w] %S%m"
eec82323 686 "*The format specification for the article mode line.
16409b0b
GM		 687See `gnus-summary-mode-line-format' for a closer description.
688
689The following additional specs are available:
690
691%w The article washing status.
692%m The number of MIME parts in the article."
eec82323
LMI		 693 :type 'string
694 :group 'gnus-article-various)
695
696(defcustom gnus-article-mode-hook nil
697 "*A hook for Gnus article mode."
698 :type 'hook
699 :group 'gnus-article-various)
700
23f87bed
MB		 701(when (featurep 'xemacs)
702 ;; Extracted from gnus-xmas-define in order to preserve user settings
703 (when (fboundp 'turn-off-scroll-in-place)
704 (add-hook 'gnus-article-mode-hook 'turn-off-scroll-in-place))
705 ;; Extracted from gnus-xmas-redefine in order to preserve user settings
706 (add-hook 'gnus-article-mode-hook 'gnus-xmas-article-menu-add))
707
eec82323
LMI		 708(defcustom gnus-article-menu-hook nil
709 "*Hook run after the creation of the article mode menu."
710 :type 'hook
711 :group 'gnus-article-various)
712
713(defcustom gnus-article-prepare-hook nil
16409b0b 714 "*A hook called after an article has been prepared in the article buffer."
eec82323
LMI		 715 :type 'hook
716 :group 'gnus-article-various)
717
01c52d31
MB		 718(defcustom gnus-copy-article-ignored-headers nil
719 "List of headers to be removed when copying an article.
720Each element is a regular expression."
330f707b 721 :version "23.1" ;; No Gnus
01c52d31
MB		 722 :type '(repeat regexp)
723 :group 'gnus-article-various)
724
23f87bed
MB		 725(make-obsolete-variable 'gnus-article-hide-pgp-hook
726 "This variable is obsolete in Gnus 5.10.")
a8151ef7 727
01c52d31
MB		 728(defface gnus-button
729 '((t (:weight bold)))
730 "Face used for highlighting a button in the article buffer."
731 :group 'gnus-article-buttons)
732
733(defcustom gnus-article-button-face 'gnus-button
eec82323
LMI		 734 "Face used for highlighting buttons in the article buffer.
735
736An article button is a piece of text that you can activate by pressing
737`RET' or `mouse-2' above it."
738 :type 'face
739 :group 'gnus-article-buttons)
740
741(defcustom gnus-article-mouse-face 'highlight
742 "Face used for mouse highlighting in the article buffer.
743
744Article buttons will be displayed in this face when the cursor is
745above them."
746 :type 'face
747 :group 'gnus-article-buttons)
748
0f49874b 749(defcustom gnus-signature-face 'gnus-signature
a8151ef7 750 "Face used for highlighting a signature in the article buffer.
0f49874b 751Obsolete; use the face `gnus-signature' for customizations instead."
eec82323
LMI		 752 :type 'face
753 :group 'gnus-article-highlight
754 :group 'gnus-article-signature)
755
0f49874b 756(defface gnus-signature
f59a3415 757 '((t
23f87bed 758 (:italic t)))
a8151ef7
LMI		 759 "Face used for highlighting a signature in the article buffer."
760 :group 'gnus-article-highlight
761 :group 'gnus-article-signature)
0f49874b
MB		 762;; backward-compatibility alias
763(put 'gnus-signature-face 'face-alias 'gnus-signature)
a8151ef7 764
0f49874b 765(defface gnus-header-from
eec82323
LMI		 766 '((((class color)
767 (background dark))
01c52d31 768 (:foreground "PaleGreen1"))
eec82323
LMI		 769 (((class color)
770 (background light))
6748645f 771 (:foreground "red3"))
eec82323 772 (t
23f87bed 773 (:italic t)))
eec82323
LMI		 774 "Face used for displaying from headers."
775 :group 'gnus-article-headers
776 :group 'gnus-article-highlight)
0f49874b
MB		 777;; backward-compatibility alias
778(put 'gnus-header-from-face 'face-alias 'gnus-header-from)
eec82323 779
0f49874b 780(defface gnus-header-subject
eec82323
LMI		 781 '((((class color)
782 (background dark))
01c52d31 783 (:foreground "SeaGreen1"))
eec82323
LMI		 784 (((class color)
785 (background light))
6748645f 786 (:foreground "red4"))
eec82323 787 (t
23f87bed 788 (:bold t :italic t)))
eec82323
LMI		 789 "Face used for displaying subject headers."
790 :group 'gnus-article-headers
791 :group 'gnus-article-highlight)
0f49874b
MB		 792;; backward-compatibility alias
793(put 'gnus-header-subject-face 'face-alias 'gnus-header-subject)
eec82323 794
0f49874b 795(defface gnus-header-newsgroups
eec82323
LMI		 796 '((((class color)
797 (background dark))
23f87bed 798 (:foreground "yellow" :italic t))
eec82323
LMI		 799 (((class color)
800 (background light))
23f87bed 801 (:foreground "MidnightBlue" :italic t))
eec82323 802 (t
23f87bed
MB		 803 (:italic t)))
804 "Face used for displaying newsgroups headers.
805In the default setup this face is only used for crossposted
806articles."
eec82323
LMI		 807 :group 'gnus-article-headers
808 :group 'gnus-article-highlight)
0f49874b
MB		 809;; backward-compatibility alias
810(put 'gnus-header-newsgroups-face 'face-alias 'gnus-header-newsgroups)
eec82323 811
0f49874b 812(defface gnus-header-name
eec82323
LMI		 813 '((((class color)
814 (background dark))
01c52d31 815 (:foreground "SpringGreen2"))
eec82323
LMI		 816 (((class color)
817 (background light))
818 (:foreground "maroon"))
819 (t
23f87bed 820 (:bold t)))
eec82323
LMI		 821 "Face used for displaying header names."
822 :group 'gnus-article-headers
823 :group 'gnus-article-highlight)
0f49874b
MB		 824;; backward-compatibility alias
825(put 'gnus-header-name-face 'face-alias 'gnus-header-name)
eec82323 826
0f49874b 827(defface gnus-header-content
eec82323
LMI		 828 '((((class color)
829 (background dark))
01c52d31 830 (:foreground "SpringGreen1" :italic t))
eec82323
LMI		 831 (((class color)
832 (background light))
23f87bed 833 (:foreground "indianred4" :italic t))
eec82323 834 (t
23f87bed 835 (:italic t))) "Face used for displaying header content."
eec82323
LMI		 836 :group 'gnus-article-headers
837 :group 'gnus-article-highlight)
0f49874b
MB		 838;; backward-compatibility alias
839(put 'gnus-header-content-face 'face-alias 'gnus-header-content)
eec82323
LMI		 840
841(defcustom gnus-header-face-alist
0f49874b
MB		 842 '(("From" nil gnus-header-from)
843 ("Subject" nil gnus-header-subject)
844 ("Newsgroups:.*," nil gnus-header-newsgroups)
845 ("" gnus-header-name gnus-header-content))
23f87bed 846 "*Controls highlighting of article headers.
eec82323
LMI		 847
848An alist of the form (HEADER NAME CONTENT).
849
23f87bed
MB		 850HEADER is a regular expression which should match the name of a
851header and NAME and CONTENT are either face names or nil.
eec82323
LMI		 852
853The name of each header field will be displayed using the face
23f87bed
MB		 854specified by the first element in the list where HEADER matches
855the header name and NAME is non-nil. Similarly, the content will
856be displayed by the first non-nil matching CONTENT face."
eec82323
LMI		 857 :group 'gnus-article-headers
858 :group 'gnus-article-highlight
859 :type '(repeat (list (regexp :tag "Header")
860 (choice :tag "Name"
861 (item :tag "skip" nil)
862 (face :value default))
863 (choice :tag "Content"
864 (item :tag "skip" nil)
865 (face :value default)))))
866
01c52d31
MB		 867(defcustom gnus-face-properties-alist (if (featurep 'xemacs)
868 '((xface . (:face gnus-x-face)))
869 '((pbm . (:face gnus-x-face))
870 (png . nil)))
871 "Alist of image types and properties applied to Face and X-Face images.
872Here are examples:
873
874;; Specify the altitude of Face images in the From header.
875\(setq gnus-face-properties-alist
876 '((pbm . (:face gnus-x-face :ascent 80))
877 (png . (:ascent 80))))
878
879;; Show Face images as pressed buttons.
880\(setq gnus-face-properties-alist
881 '((pbm . (:face gnus-x-face :relief -2))
882 (png . (:relief -2))))
883
884See the manual for the valid properties for various image types.
885Currently, `pbm' is used for X-Face images and `png' is used for Face
886images in Emacs. Only the `:face' property is effective on the `xface'
887image type in XEmacs if it is built with the libcompface library."
330f707b 888 :version "23.1" ;; No Gnus
01c52d31
MB		 889 :group 'gnus-article-headers
890 :type '(repeat (cons :format "%v" (symbol :tag "Image type") plist)))
891
16409b0b 892(defcustom gnus-article-decode-hook
23f87bed
MB		 893 '(article-decode-charset article-decode-encoded-words
894 article-decode-group-name article-decode-idna-rhs)
16409b0b
GM		 895 "*Hook run to decode charsets in articles."
896 :group 'gnus-article-headers
897 :type 'hook)
898
899(defcustom gnus-display-mime-function 'gnus-display-mime
900 "Function to display MIME articles."
901 :group 'gnus-article-mime
902 :type 'function)
903
904(defvar gnus-decode-header-function 'mail-decode-encoded-word-region
905 "Function used to decode headers.")
906
343d6628
MB		 907(defvar gnus-decode-address-function 'mail-decode-encoded-address-region
908 "Function used to decode addresses.")
909
16409b0b 910(defvar gnus-article-dumbquotes-map
23f87bed
MB		 911 '(("\200" "EUR")
912 ("\202" ",")
16409b0b
GM		 913 ("\203" "f")
914 ("\204" ",,")
915 ("\205" "...")
916 ("\213" "<")
917 ("\214" "OE")
918 ("\221" "`")
919 ("\222" "'")
920 ("\223" "``")
921 ("\224" "\"")
922 ("\225" "*")
e0bad764
DL		 923 ("\226" "-")
924 ("\227" "--")
23f87bed 925 ("\230" "~")
16409b0b
GM		 926 ("\231" "(TM)")
927 ("\233" ">")
928 ("\234" "oe")
929 ("\264" "'"))
930 "Table for MS-to-Latin1 translation.")
931
932(defcustom gnus-ignored-mime-types nil
933 "List of MIME types that should be ignored by Gnus."
fc2c2db8 934 :version "21.1"
16409b0b
GM		 935 :group 'gnus-article-mime
936 :type '(repeat regexp))
937
938(defcustom gnus-unbuttonized-mime-types '(".*/.*")
23f87bed
MB		 939 "List of MIME types that should not be given buttons when rendered inline.
940See also `gnus-buttonized-mime-types' which may override this variable.
941This variable is only used when `gnus-inhibit-mime-unbuttonizing' is nil."
942 :version "21.1"
943 :group 'gnus-article-mime
944 :type '(repeat regexp))
945
946(defcustom gnus-buttonized-mime-types nil
947 "List of MIME types that should be given buttons when rendered inline.
948If set, this variable overrides `gnus-unbuttonized-mime-types'.
949To see e.g. security buttons you could set this to
3031d8b0
MB		 950`(\"multipart/signed\")'. You could also add \"multipart/alternative\" to
951this list to display radio buttons that allow you to choose one of two
952media types those mails include. See also `mm-discouraged-alternatives'.
23f87bed 953This variable is only used when `gnus-inhibit-mime-unbuttonizing' is nil."
bf247b6e 954 :version "22.1"
16409b0b
GM		 955 :group 'gnus-article-mime
956 :type '(repeat regexp))
957
23f87bed
MB		 958(defcustom gnus-inhibit-mime-unbuttonizing nil
959 "If non-nil, all MIME parts get buttons.
960When nil (the default value), then some MIME parts do not get buttons,
961as described by the variables `gnus-buttonized-mime-types' and
962`gnus-unbuttonized-mime-types'."
bf247b6e 963 :version "22.1"
d0859c9a 964 :group 'gnus-article-mime
23f87bed
MB		 965 :type 'boolean)
966
967(defcustom gnus-body-boundary-delimiter "_"
968 "String used to delimit header and body.
969This variable is used by `gnus-article-treat-body-boundary' which can
970be controlled by `gnus-treat-body-boundary'."
bf247b6e 971 :version "22.1"
23f87bed
MB		 972 :group 'gnus-article-various
973 :type '(choice (item :tag "None" :value nil)
974 string))
975
97f78c9b
MB		 976(defcustom gnus-picon-databases '("/usr/lib/picon" "/usr/local/faces"
977 "/usr/share/picons")
23f87bed
MB		 978 "Defines the location of the faces database.
979For information on obtaining this database of pretty pictures, please
980see http://www.cs.indiana.edu/picons/ftp/index.html"
bf247b6e 981 :version "22.1"
23f87bed
MB		 982 :type '(repeat directory)
983 :link '(url-link :tag "download"
984 "http://www.cs.indiana.edu/picons/ftp/index.html")
985 :link '(custom-manual "(gnus)Picons")
986 :group 'gnus-picon)
987
988(defun gnus-picons-installed-p ()
989 "Say whether picons are installed on your machine."
990 (let ((installed nil))
991 (dolist (database gnus-picon-databases)
992 (when (file-exists-p database)
993 (setq installed t)))
994 installed))
995
16409b0b
GM		 996(defcustom gnus-article-mime-part-function nil
997 "Function called with a MIME handle as the argument.
998This is meant for people who want to do something automatic based
999on parts -- for instance, adding Vcard info to a database."
1000 :group 'gnus-article-mime
4a2358e9
MB		 1001 :type '(choice (const nil)
1002 function))
16409b0b
GM		 1003
1004(defcustom gnus-mime-multipart-functions nil
fc2c2db8
DL		 1005 "An alist of MIME types to functions to display them."
1006 :version "21.1"
1007 :group 'gnus-article-mime
01c52d31 1008 :type '(repeat (cons :format "%v" (string :tag "MIME type") function)))
16409b0b
GM		 1009
1010(defcustom gnus-article-date-lapsed-new-header nil
1011 "Whether the X-Sent and Date headers can coexist.
1012When using `gnus-treat-date-lapsed', the \"X-Sent:\" header will
1013either replace the old \"Date:\" header (if this variable is nil), or
1014be added below it (otherwise)."
fc2c2db8 1015 :version "21.1"
16409b0b
GM		 1016 :group 'gnus-article-headers
1017 :type 'boolean)
1018
1019(defcustom gnus-article-mime-match-handle-function 'undisplayed-alternative
1020 "Function called with a MIME handle as the argument.
1021This is meant for people who want to view first matched part.
a1506d29
JB		 1022For `undisplayed-alternative' (default), the first undisplayed
1023part or alternative part is used. For `undisplayed', the first
1024undisplayed part is used. For a function, the first part which
f20b2f5c 1025the function return t is used. For nil, the first part is
16409b0b 1026used."
fc2c2db8 1027 :version "21.1"
16409b0b 1028 :group 'gnus-article-mime
a1506d29 1029 :type '(choice
16409b0b
GM		 1030 (item :tag "first" :value nil)
1031 (item :tag "undisplayed" :value undisplayed)
a1506d29 1032 (item :tag "undisplayed or alternative"
16409b0b
GM		 1033 :value undisplayed-alternative)
1034 (function)))
1035
e0bad764
DL		 1036(defcustom gnus-mime-action-alist
1037 '(("save to file" . gnus-mime-save-part)
23f87bed 1038 ("save and strip" . gnus-mime-save-part-and-strip)
01c52d31 1039 ("replace with file" . gnus-mime-replace-part)
23f87bed 1040 ("delete part" . gnus-mime-delete-part)
e0bad764
DL		 1041 ("display as text" . gnus-mime-inline-part)
1042 ("view the part" . gnus-mime-view-part)
1043 ("pipe to command" . gnus-mime-pipe-part)
1044 ("toggle display" . gnus-article-press-button)
23f87bed 1045 ("toggle display" . gnus-article-view-part-as-charset)
e0bad764 1046 ("view as type" . gnus-mime-view-part-as-type)
23f87bed
MB		 1047 ("view internally" . gnus-mime-view-part-internally)
1048 ("view externally" . gnus-mime-view-part-externally))
e0bad764
DL		 1049 "An alist of actions that run on the MIME attachment."
1050 :group 'gnus-article-mime
1051 :type '(repeat (cons (string :tag "name")
1052 (function))))
1053
01c52d31
MB		 1054(defcustom gnus-auto-select-part 1
1055 "Advance to next MIME part when deleting or stripping parts.
1056
1057When 0, point will be placed on the same part as before. When
1058positive (negative), move point forward (backwards) this many
1059parts. When nil, redisplay article."
330f707b 1060 :version "23.1" ;; No Gnus
01c52d31
MB		 1061 :group 'gnus-article-mime
1062 :type '(choice (const nil :tag "Redisplay article.")
1063 (const 1 :tag "Next part.")
1064 (const 0 :tag "Current part.")
1065 integer))
1066
16409b0b
GM		 1067;;;
1068;;; The treatment variables
1069;;;
1070
1071(defvar gnus-part-display-hook nil
1072 "Hook called on parts that are to receive treatment.")
1073
1074(defvar gnus-article-treat-custom
1075 '(choice (const :tag "Off" nil)
1076 (const :tag "On" t)
1077 (const :tag "Header" head)
01c52d31 1078 (const :tag "First" first)
16409b0b
GM		 1079 (const :tag "Last" last)
1080 (integer :tag "Less")
1081 (repeat :tag "Groups" regexp)
1082 (sexp :tag "Predicate")))
1083
1084(defvar gnus-article-treat-head-custom
1085 '(choice (const :tag "Off" nil)
1086 (const :tag "Header" head)))
1087
01c52d31
MB		 1088(defvar gnus-article-treat-types '("text/plain" "text/x-verbatim"
1089 "text/x-patch")
16409b0b
GM		 1090 "Parts to treat.")
1091
1092(defvar gnus-inhibit-treatment nil
1093 "Whether to inhibit treatment.")
1094
23f87bed 1095(defcustom gnus-treat-highlight-signature '(or t (typep "text/x-vcard"))
16409b0b 1096 "Highlight the signature.
01c52d31
MB		 1097Valid values are nil, t, `head', `first', `last', an integer or a
1098predicate. See Info node `(gnus)Customizing Articles'."
16409b0b 1099 :group 'gnus-article-treat
23f87bed 1100 :link '(custom-manual "(gnus)Customizing Articles")
16409b0b
GM		 1101 :type gnus-article-treat-custom)
1102(put 'gnus-treat-highlight-signature 'highlight t)
1103
1104(defcustom gnus-treat-buttonize 100000
1105 "Add buttons.
01c52d31
MB		 1106Valid values are nil, t, `head', `first', `last', an integer or a
1107predicate. See Info node `(gnus)Customizing Articles'."
16409b0b 1108 :group 'gnus-article-treat
23f87bed 1109 :link '(custom-manual "(gnus)Customizing Articles")
16409b0b
GM		 1110 :type gnus-article-treat-custom)
1111(put 'gnus-treat-buttonize 'highlight t)
1112
1113(defcustom gnus-treat-buttonize-head 'head
1114 "Add buttons to the head.
01c52d31
MB		 1115Valid values are nil, t, `head', `first', `last', an integer or a
1116predicate. See Info node `(gnus)Customizing Articles'."
16409b0b 1117 :group 'gnus-article-treat
23f87bed 1118 :link '(custom-manual "(gnus)Customizing Articles")
16409b0b
GM		 1119 :type gnus-article-treat-head-custom)
1120(put 'gnus-treat-buttonize-head 'highlight t)
1121
437ce4be 1122(defcustom gnus-treat-emphasize 50000
16409b0b 1123 "Emphasize text.
01c52d31
MB		 1124Valid values are nil, t, `head', `first', `last', an integer or a
1125predicate. See Info node `(gnus)Customizing Articles'."
16409b0b 1126 :group 'gnus-article-treat
23f87bed 1127 :link '(custom-manual "(gnus)Customizing Articles")
16409b0b
GM		 1128 :type gnus-article-treat-custom)
1129(put 'gnus-treat-emphasize 'highlight t)
1130
1131(defcustom gnus-treat-strip-cr nil
1132 "Remove carriage returns.
01c52d31
MB		 1133Valid values are nil, t, `head', `first', `last', an integer or a
1134predicate. See Info node `(gnus)Customizing Articles'."
bf247b6e 1135 :version "22.1"
16409b0b 1136 :group 'gnus-article-treat
23f87bed
MB		 1137 :link '(custom-manual "(gnus)Customizing Articles")
1138 :type gnus-article-treat-custom)
1139
1140(defcustom gnus-treat-unsplit-urls nil
1141 "Remove newlines from within URLs.
01c52d31
MB		 1142Valid values are nil, t, `head', `first', `last', an integer or a
1143predicate. See Info node `(gnus)Customizing Articles'."
bf247b6e 1144 :version "22.1"
23f87bed
MB		 1145 :group 'gnus-article-treat
1146 :link '(custom-manual "(gnus)Customizing Articles")
1147 :type gnus-article-treat-custom)
1148
1149(defcustom gnus-treat-leading-whitespace nil
1150 "Remove leading whitespace in headers.
01c52d31
MB		 1151Valid values are nil, t, `head', `first', `last', an integer or a
1152predicate. See Info node `(gnus)Customizing Articles'."
bf247b6e 1153 :version "22.1"
23f87bed
MB		 1154 :group 'gnus-article-treat
1155 :link '(custom-manual "(gnus)Customizing Articles")
16409b0b
GM		 1156 :type gnus-article-treat-custom)
1157
1158(defcustom gnus-treat-hide-headers 'head
1159 "Hide headers.
01c52d31
MB		 1160Valid values are nil, t, `head', `first', `last', an integer or a
1161predicate. See Info node `(gnus)Customizing Articles'."
16409b0b 1162 :group 'gnus-article-treat
23f87bed 1163 :link '(custom-manual "(gnus)Customizing Articles")
16409b0b
GM		 1164 :type gnus-article-treat-head-custom)
1165
1166(defcustom gnus-treat-hide-boring-headers nil
1167 "Hide boring headers.
01c52d31
MB		 1168Valid values are nil, t, `head', `first', `last', an integer or a
1169predicate. See Info node `(gnus)Customizing Articles'."
16409b0b 1170 :group 'gnus-article-treat
23f87bed 1171 :link '(custom-manual "(gnus)Customizing Articles")
16409b0b
GM		 1172 :type gnus-article-treat-head-custom)
1173
1174(defcustom gnus-treat-hide-signature nil
1175 "Hide the signature.
01c52d31
MB		 1176Valid values are nil, t, `head', `first', `last', an integer or a
1177predicate. See Info node `(gnus)Customizing Articles'."
16409b0b 1178 :group 'gnus-article-treat
23f87bed 1179 :link '(custom-manual "(gnus)Customizing Articles")
16409b0b
GM		 1180 :type gnus-article-treat-custom)
1181
1182(defcustom gnus-treat-fill-article nil
1183 "Fill the article.
01c52d31
MB		 1184Valid values are nil, t, `head', `first', `last', an integer or a
1185predicate. See Info node `(gnus)Customizing Articles'."
16409b0b 1186 :group 'gnus-article-treat
23f87bed 1187 :link '(custom-manual "(gnus)Customizing Articles")
16409b0b
GM		 1188 :type gnus-article-treat-custom)
1189
1190(defcustom gnus-treat-hide-citation nil
1191 "Hide cited text.
01c52d31
MB		 1192Valid values are nil, t, `head', `first', `last', an integer or a
1193predicate. See Info node `(gnus)Customizing Articles'."
16409b0b 1194 :group 'gnus-article-treat
23f87bed 1195 :link '(custom-manual "(gnus)Customizing Articles")
16409b0b
GM		 1196 :type gnus-article-treat-custom)
1197
e0bad764
DL		 1198(defcustom gnus-treat-hide-citation-maybe nil
1199 "Hide cited text.
01c52d31
MB		 1200Valid values are nil, t, `head', `first', `last', an integer or a
1201predicate. See Info node `(gnus)Customizing Articles'."
e0bad764 1202 :group 'gnus-article-treat
23f87bed 1203 :link '(custom-manual "(gnus)Customizing Articles")
e0bad764
DL		 1204 :type gnus-article-treat-custom)
1205
16409b0b
GM		 1206(defcustom gnus-treat-strip-list-identifiers 'head
1207 "Strip list identifiers from `gnus-list-identifiers`.
01c52d31
MB		 1208Valid values are nil, t, `head', `first', `last', an integer or a
1209predicate. See Info node `(gnus)Customizing Articles'."
fc2c2db8 1210 :version "21.1"
16409b0b 1211 :group 'gnus-article-treat
23f87bed 1212 :link '(custom-manual "(gnus)Customizing Articles")
16409b0b
GM		 1213 :type gnus-article-treat-custom)
1214
23f87bed
MB		 1215(make-obsolete-variable 'gnus-treat-strip-pgp
1216 "This option is obsolete in Gnus 5.10.")
16409b0b
GM		 1217
1218(defcustom gnus-treat-strip-pem nil
1219 "Strip PEM signatures.
01c52d31
MB		 1220Valid values are nil, t, `head', `first', `last', an integer or a
1221predicate. See Info node `(gnus)Customizing Articles'."
16409b0b 1222 :group 'gnus-article-treat
23f87bed 1223 :link '(custom-manual "(gnus)Customizing Articles")
16409b0b
GM		 1224 :type gnus-article-treat-custom)
1225
1226(defcustom gnus-treat-strip-banner t
1227 "Strip banners from articles.
1228The banner to be stripped is specified in the `banner' group parameter.
01c52d31
MB		 1229Valid values are nil, t, `head', `first', `last', an integer or a
1230predicate. See Info node `(gnus)Customizing Articles'."
16409b0b 1231 :group 'gnus-article-treat
23f87bed 1232 :link '(custom-manual "(gnus)Customizing Articles")
16409b0b
GM		 1233 :type gnus-article-treat-custom)
1234
1235(defcustom gnus-treat-highlight-headers 'head
1236 "Highlight the headers.
01c52d31
MB		 1237Valid values are nil, t, `head', `first', `last', an integer or a
1238predicate. See Info node `(gnus)Customizing Articles'."
16409b0b 1239 :group 'gnus-article-treat
23f87bed 1240 :link '(custom-manual "(gnus)Customizing Articles")
16409b0b
GM		 1241 :type gnus-article-treat-head-custom)
1242(put 'gnus-treat-highlight-headers 'highlight t)
1243
1244(defcustom gnus-treat-highlight-citation t
1245 "Highlight cited text.
01c52d31
MB		 1246Valid values are nil, t, `head', `first', `last', an integer or a
1247predicate. See Info node `(gnus)Customizing Articles'."
16409b0b 1248 :group 'gnus-article-treat
23f87bed 1249 :link '(custom-manual "(gnus)Customizing Articles")
16409b0b
GM		 1250 :type gnus-article-treat-custom)
1251(put 'gnus-treat-highlight-citation 'highlight t)
1252
1253(defcustom gnus-treat-date-ut nil
1254 "Display the Date in UT (GMT).
01c52d31
MB		 1255Valid values are nil, t, `head', `first', `last', an integer or a
1256predicate. See Info node `(gnus)Customizing Articles'."
16409b0b 1257 :group 'gnus-article-treat
23f87bed 1258 :link '(custom-manual "(gnus)Customizing Articles")
16409b0b
GM		 1259 :type gnus-article-treat-head-custom)
1260
1261(defcustom gnus-treat-date-local nil
1262 "Display the Date in the local timezone.
01c52d31
MB		 1263Valid values are nil, t, `head', `first', `last', an integer or a
1264predicate. See Info node `(gnus)Customizing Articles'."
23f87bed
MB		 1265 :group 'gnus-article-treat
1266 :link '(custom-manual "(gnus)Customizing Articles")
1267 :type gnus-article-treat-head-custom)
1268
1269(defcustom gnus-treat-date-english nil
1270 "Display the Date in a format that can be read aloud in English.
01c52d31
MB		 1271Valid values are nil, t, `head', `first', `last', an integer or a
1272predicate. See Info node `(gnus)Customizing Articles'."
bf247b6e 1273 :version "22.1"
16409b0b 1274 :group 'gnus-article-treat
23f87bed 1275 :link '(custom-manual "(gnus)Customizing Articles")
16409b0b
GM		 1276 :type gnus-article-treat-head-custom)
1277
1278(defcustom gnus-treat-date-lapsed nil
1279 "Display the Date header in a way that says how much time has elapsed.
01c52d31
MB		 1280Valid values are nil, t, `head', `first', `last', an integer or a
1281predicate. See Info node `(gnus)Customizing Articles'."
16409b0b 1282 :group 'gnus-article-treat
23f87bed 1283 :link '(custom-manual "(gnus)Customizing Articles")
16409b0b
GM		 1284 :type gnus-article-treat-head-custom)
1285
1286(defcustom gnus-treat-date-original nil
1287 "Display the date in the original timezone.
01c52d31
MB		 1288Valid values are nil, t, `head', `first', `last', an integer or a
1289predicate. See Info node `(gnus)Customizing Articles'."
16409b0b 1290 :group 'gnus-article-treat
23f87bed 1291 :link '(custom-manual "(gnus)Customizing Articles")
16409b0b
GM		 1292 :type gnus-article-treat-head-custom)
1293
1294(defcustom gnus-treat-date-iso8601 nil
1295 "Display the date in the ISO8601 format.
01c52d31
MB		 1296Valid values are nil, t, `head', `first', `last', an integer or a
1297predicate. See Info node `(gnus)Customizing Articles'."
fc2c2db8 1298 :version "21.1"
16409b0b 1299 :group 'gnus-article-treat
23f87bed 1300 :link '(custom-manual "(gnus)Customizing Articles")
16409b0b
GM		 1301 :type gnus-article-treat-head-custom)
1302
1303(defcustom gnus-treat-date-user-defined nil
1304 "Display the date in a user-defined format.
1305The format is defined by the `gnus-article-time-format' variable.
01c52d31
MB		 1306Valid values are nil, t, `head', `first', `last', an integer or a
1307predicate. See Info node `(gnus)Customizing Articles'."
16409b0b 1308 :group 'gnus-article-treat
23f87bed 1309 :link '(custom-manual "(gnus)Customizing Articles")
16409b0b
GM		 1310 :type gnus-article-treat-head-custom)
1311
1312(defcustom gnus-treat-strip-headers-in-body t
1313 "Strip the X-No-Archive header line from the beginning of the body.
01c52d31
MB		 1314Valid values are nil, t, `head', `first', `last', an integer or a
1315predicate. See Info node `(gnus)Customizing Articles'."
fc2c2db8 1316 :version "21.1"
16409b0b 1317 :group 'gnus-article-treat
23f87bed 1318 :link '(custom-manual "(gnus)Customizing Articles")
16409b0b
GM		 1319 :type gnus-article-treat-custom)
1320
1321(defcustom gnus-treat-strip-trailing-blank-lines nil
1322 "Strip trailing blank lines.
01c52d31
MB		 1323Valid values are nil, t, `head', `first', `last', an integer or a
1324predicate. See Info node `(gnus)Customizing Articles'.
292f71fe
MB		 1325
1326When set to t, it also strips trailing blanks in all MIME parts.
1327Consider to use `last' instead."
16409b0b 1328 :group 'gnus-article-treat
23f87bed 1329 :link '(custom-manual "(gnus)Customizing Articles")
16409b0b
GM		 1330 :type gnus-article-treat-custom)
1331
1332(defcustom gnus-treat-strip-leading-blank-lines nil
1333 "Strip leading blank lines.
01c52d31
MB		 1334Valid values are nil, t, `head', `first', `last', an integer or a
1335predicate. See Info node `(gnus)Customizing Articles'.
292f71fe
MB		 1336
1337When set to t, it also strips trailing blanks in all MIME parts."
16409b0b 1338 :group 'gnus-article-treat
23f87bed 1339 :link '(custom-manual "(gnus)Customizing Articles")
16409b0b
GM		 1340 :type gnus-article-treat-custom)
1341
1342(defcustom gnus-treat-strip-multiple-blank-lines nil
1343 "Strip multiple blank lines.
01c52d31
MB		 1344Valid values are nil, t, `head', `first', `last', an integer or a
1345predicate. See Info node `(gnus)Customizing Articles'."
16409b0b 1346 :group 'gnus-article-treat
23f87bed
MB		 1347 :link '(custom-manual "(gnus)Customizing Articles")
1348 :type gnus-article-treat-custom)
1349
1350(defcustom gnus-treat-unfold-headers 'head
1351 "Unfold folded header lines.
01c52d31
MB		 1352Valid values are nil, t, `head', `first', `last', an integer or a
1353predicate. See Info node `(gnus)Customizing Articles'."
bf247b6e 1354 :version "22.1"
23f87bed
MB		 1355 :group 'gnus-article-treat
1356 :link '(custom-manual "(gnus)Customizing Articles")
1357 :type gnus-article-treat-custom)
1358
01c52d31
MB		 1359(defcustom gnus-article-unfold-long-headers nil
1360 "If non-nil, allow unfolding headers even if the header is long.
1361If it is a regexp, only long headers matching this regexp are unfolded.
1362If it is t, all long headers are unfolded.
1363
1364This variable has no effect if `gnus-treat-unfold-headers' is nil."
330f707b 1365 :version "23.1" ;; No Gnus
01c52d31
MB		 1366 :group 'gnus-article-treat
1367 :type '(choice (const nil)
1368 (const :tag "all" t)
1369 (regexp)))
1370
23f87bed
MB		 1371(defcustom gnus-treat-fold-headers nil
1372 "Fold headers.
01c52d31
MB		 1373Valid values are nil, t, `head', `first', `last', an integer or a
1374predicate. See Info node `(gnus)Customizing Articles'."
bf247b6e 1375 :version "22.1"
23f87bed
MB		 1376 :group 'gnus-article-treat
1377 :link '(custom-manual "(gnus)Customizing Articles")
1378 :type gnus-article-treat-custom)
1379
1380(defcustom gnus-treat-fold-newsgroups 'head
1381 "Fold the Newsgroups and Followup-To headers.
01c52d31
MB		 1382Valid values are nil, t, `head', `first', `last', an integer or a
1383predicate. See Info node `(gnus)Customizing Articles'."
bf247b6e 1384 :version "22.1"
23f87bed
MB		 1385 :group 'gnus-article-treat
1386 :link '(custom-manual "(gnus)Customizing Articles")
16409b0b
GM		 1387 :type gnus-article-treat-custom)
1388
1389(defcustom gnus-treat-overstrike t
1390 "Treat overstrike highlighting.
01c52d31
MB		 1391Valid values are nil, t, `head', `first', `last', an integer or a
1392predicate. See Info node `(gnus)Customizing Articles'."
16409b0b 1393 :group 'gnus-article-treat
23f87bed 1394 :link '(custom-manual "(gnus)Customizing Articles")
16409b0b
GM		 1395 :type gnus-article-treat-custom)
1396(put 'gnus-treat-overstrike 'highlight t)
1397
01c52d31
MB		 1398(defcustom gnus-treat-ansi-sequences (if (locate-library "ansi-color") t)
1399 "Treat ANSI SGR control sequences.
1400Valid values are nil, t, `head', `first', `last', an integer or a
1401predicate. See Info node `(gnus)Customizing Articles'."
1402 :group 'gnus-article-treat
1403 :link '(custom-manual "(gnus)Customizing Articles")
1404 :type gnus-article-treat-custom)
1405
23f87bed
MB		 1406(make-obsolete-variable 'gnus-treat-display-xface
1407 'gnus-treat-display-x-face)
1408
1409(defcustom gnus-treat-display-x-face
1410 (and (not noninteractive)
11e95b02
MB		 1411 (gnus-image-type-available-p 'xbm)
1412 (if (featurep 'xemacs)
1413 (featurep 'xface)
1414 (and (string-match "^0x" (shell-command-to-string "uncompface"))
1415 (executable-find "icontopbm")))
8b93df01 1416 'head)
16409b0b 1417 "Display X-Face headers.
87ba2830 1418Valid values are nil and `head'.
23f87bed
MB		 1419See Info node `(gnus)Customizing Articles' and Info node
1420`(gnus)X-Face' for details."
1421 :group 'gnus-article-treat
1422 :version "21.1"
1423 :link '(custom-manual "(gnus)Customizing Articles")
1424 :link '(custom-manual "(gnus)X-Face")
1425 :type gnus-article-treat-head-custom
1426 :set (lambda (symbol value)
1427 (set-default
1428 symbol
1429 (cond ((or (boundp symbol) (get symbol 'saved-value))
1430 value)
1431 ((boundp 'gnus-treat-display-xface)
1432 (message "\
1433** gnus-treat-display-xface is an obsolete variable;\
1434 use gnus-treat-display-x-face instead")
1435 (default-value 'gnus-treat-display-xface))
1436 ((get 'gnus-treat-display-xface 'saved-value)
1437 (message "\
1438** gnus-treat-display-xface is an obsolete variable;\
1439 use gnus-treat-display-x-face instead")
1440 (eval (car (get 'gnus-treat-display-xface 'saved-value))))
1441 (t
1442 value)))))
1443(put 'gnus-treat-display-x-face 'highlight t)
1444
1445(defcustom gnus-treat-display-face
1446 (and (not noninteractive)
11e95b02 1447 (gnus-image-type-available-p 'png)
23f87bed
MB		 1448 'head)
1449 "Display Face headers.
01c52d31
MB		 1450Valid values are nil, t, `head', `first', `last', an integer or a
1451predicate. See Info node `(gnus)Customizing Articles' and Info
1452node `(gnus)X-Face' for details."
16409b0b 1453 :group 'gnus-article-treat
bf247b6e 1454 :version "22.1"
23f87bed
MB		 1455 :link '(custom-manual "(gnus)Customizing Articles")
1456 :link '(custom-manual "(gnus)X-Face")
16409b0b 1457 :type gnus-article-treat-head-custom)
23f87bed 1458(put 'gnus-treat-display-face 'highlight t)
16409b0b 1459
11e95b02 1460(defcustom gnus-treat-display-smileys (gnus-image-type-available-p 'xpm)
16409b0b 1461 "Display smileys.
01c52d31
MB		 1462Valid values are nil, t, `head', `first', `last', an integer or a
1463predicate. See Info node `(gnus)Customizing Articles' and Info
1464node `(gnus)Smileys' for details."
16409b0b 1465 :group 'gnus-article-treat
b5a206e7 1466 :version "21.1"
23f87bed
MB		 1467 :link '(custom-manual "(gnus)Customizing Articles")
1468 :link '(custom-manual "(gnus)Smileys")
16409b0b
GM		 1469 :type gnus-article-treat-custom)
1470(put 'gnus-treat-display-smileys 'highlight t)
1471
23f87bed
MB		 1472(defcustom gnus-treat-from-picon
1473 (if (and (gnus-image-type-available-p 'xpm)
1474 (gnus-picons-installed-p))
1475 'head nil)
1476 "Display picons in the From header.
01c52d31
MB		 1477Valid values are nil, t, `head', `first', `last', an integer or a
1478predicate. See Info node `(gnus)Customizing Articles' and Info
1479node `(gnus)Picons' for details."
bf247b6e 1480 :version "22.1"
16409b0b 1481 :group 'gnus-article-treat
23f87bed
MB		 1482 :group 'gnus-picon
1483 :link '(custom-manual "(gnus)Customizing Articles")
1484 :link '(custom-manual "(gnus)Picons")
1485 :type gnus-article-treat-head-custom)
1486(put 'gnus-treat-from-picon 'highlight t)
1487
1488(defcustom gnus-treat-mail-picon
1489 (if (and (gnus-image-type-available-p 'xpm)
1490 (gnus-picons-installed-p))
1491 'head nil)
1492 "Display picons in To and Cc headers.
01c52d31
MB		 1493Valid values are nil, t, `head', `first', `last', an integer or a
1494predicate. See Info node `(gnus)Customizing Articles' and Info
1495node `(gnus)Picons' for details."
bf247b6e 1496 :version "22.1"
23f87bed
MB		 1497 :group 'gnus-article-treat
1498 :group 'gnus-picon
1499 :link '(custom-manual "(gnus)Customizing Articles")
1500 :link '(custom-manual "(gnus)Picons")
1501 :type gnus-article-treat-head-custom)
1502(put 'gnus-treat-mail-picon 'highlight t)
1503
1504(defcustom gnus-treat-newsgroups-picon
1505 (if (and (gnus-image-type-available-p 'xpm)
1506 (gnus-picons-installed-p))
1507 'head nil)
1508 "Display picons in the Newsgroups and Followup-To headers.
01c52d31
MB		 1509Valid values are nil, t, `head', `first', `last', an integer or a
1510predicate. See Info node `(gnus)Customizing Articles' and Info
1511node `(gnus)Picons' for details."
bf247b6e 1512 :version "22.1"
23f87bed
MB		 1513 :group 'gnus-article-treat
1514 :group 'gnus-picon
1515 :link '(custom-manual "(gnus)Customizing Articles")
1516 :link '(custom-manual "(gnus)Picons")
1517 :type gnus-article-treat-head-custom)
1518(put 'gnus-treat-newsgroups-picon 'highlight t)
1519
1520(defcustom gnus-treat-body-boundary
437ce4be
MB		 1521 (if (or gnus-treat-newsgroups-picon
1522 gnus-treat-mail-picon
1523 gnus-treat-from-picon)
1524 ;; If there's much decoration, the user might prefer a boundery.
1525 'head
1526 nil)
23f87bed
MB		 1527 "Draw a boundary at the end of the headers.
1528Valid values are nil and `head'.
1529See Info node `(gnus)Customizing Articles' for details."
bf247b6e 1530 :version "22.1"
23f87bed
MB		 1531 :group 'gnus-article-treat
1532 :link '(custom-manual "(gnus)Customizing Articles")
16409b0b 1533 :type gnus-article-treat-head-custom)
16409b0b
GM		 1534
1535(defcustom gnus-treat-capitalize-sentences nil
1536 "Capitalize sentence-starting words.
01c52d31
MB		 1537Valid values are nil, t, `head', `first', `last', an integer or a
1538predicate. See Info node `(gnus)Customizing Articles'."
fc2c2db8 1539 :version "21.1"
16409b0b 1540 :group 'gnus-article-treat
23f87bed
MB		 1541 :link '(custom-manual "(gnus)Customizing Articles")
1542 :type gnus-article-treat-custom)
1543
1544(defcustom gnus-treat-wash-html nil
1545 "Format as HTML.
01c52d31
MB		 1546Valid values are nil, t, `head', `first', `last', an integer or a
1547predicate. See Info node `(gnus)Customizing Articles'."
bf247b6e 1548 :version "22.1"
23f87bed
MB		 1549 :group 'gnus-article-treat
1550 :link '(custom-manual "(gnus)Customizing Articles")
16409b0b
GM		 1551 :type gnus-article-treat-custom)
1552
1553(defcustom gnus-treat-fill-long-lines nil
1554 "Fill long lines.
01c52d31
MB		 1555Valid values are nil, t, `head', `first', `last', an integer or a
1556predicate. See Info node `(gnus)Customizing Articles'."
16409b0b 1557 :group 'gnus-article-treat
23f87bed 1558 :link '(custom-manual "(gnus)Customizing Articles")
16409b0b
GM		 1559 :type gnus-article-treat-custom)
1560
1561(defcustom gnus-treat-play-sounds nil
1562 "Play sounds.
01c52d31
MB		 1563Valid values are nil, t, `head', `first', `last', an integer or a
1564predicate. See Info node `(gnus)Customizing Articles'."
fc2c2db8 1565 :version "21.1"
16409b0b 1566 :group 'gnus-article-treat
23f87bed 1567 :link '(custom-manual "(gnus)Customizing Articles")
16409b0b
GM		 1568 :type gnus-article-treat-custom)
1569
1570(defcustom gnus-treat-translate nil
1571 "Translate articles from one language to another.
01c52d31
MB		 1572Valid values are nil, t, `head', `first', `last', an integer or a
1573predicate. See Info node `(gnus)Customizing Articles'."
fc2c2db8 1574 :version "21.1"
16409b0b 1575 :group 'gnus-article-treat
23f87bed 1576 :link '(custom-manual "(gnus)Customizing Articles")
16409b0b
GM		 1577 :type gnus-article-treat-custom)
1578
23f87bed
MB		 1579(defcustom gnus-treat-x-pgp-sig nil
1580 "Verify X-PGP-Sig.
1581To automatically treat X-PGP-Sig, set it to head.
01c52d31
MB		 1582Valid values are nil, t, `head', `first', `last', an integer or a
1583predicate. See Info node `(gnus)Customizing Articles'."
bf247b6e 1584 :version "22.1"
23f87bed
MB		 1585 :group 'gnus-article-treat
1586 :group 'mime-security
1587 :link '(custom-manual "(gnus)Customizing Articles")
1588 :type gnus-article-treat-custom)
1589
1590(defvar gnus-article-encrypt-protocol-alist
1591 '(("PGP" . mml2015-self-encrypt)))
1592
1593;; Set to nil if more than one protocol added to
1594;; gnus-article-encrypt-protocol-alist.
1595(defcustom gnus-article-encrypt-protocol "PGP"
1596 "The protocol used for encrypt articles.
1597It is a string, such as \"PGP\". If nil, ask user."
bf247b6e 1598 :version "22.1"
23f87bed
MB		 1599 :type 'string
1600 :group 'mime-security)
1601
1602(defvar gnus-article-wash-function nil
1603 "Function used for converting HTML into text.")
1604
1605(defcustom gnus-use-idna (and (condition-case nil (require 'idna) (file-error))
1606 (mm-coding-system-p 'utf-8)
1607 (executable-find idna-program))
1608 "Whether IDNA decoding of headers is used when viewing messages.
1609This requires GNU Libidn, and by default only enabled if it is found."
bf247b6e 1610 :version "22.1"
23f87bed
MB		 1611 :group 'gnus-article-headers
1612 :type 'boolean)
1613
1614(defcustom gnus-article-over-scroll nil
1615 "If non-nil, allow scrolling the article buffer even when there no more text."
bf247b6e 1616 :version "22.1"
23f87bed
MB		 1617 :group 'gnus-article
1618 :type 'boolean)
1619
eec82323
LMI		 1620;;; Internal variables
1621
23f87bed
MB		 1622(defvar gnus-english-month-names
1623 '("January" "February" "March" "April" "May" "June" "July" "August"
1624 "September" "October" "November" "December"))
1625
16409b0b
GM		 1626(defvar article-goto-body-goes-to-point-min-p nil)
1627(defvar gnus-article-wash-types nil)
1628(defvar gnus-article-emphasis-alist nil)
23f87bed 1629(defvar gnus-article-image-alist nil)
16409b0b
GM		 1630
1631(defvar gnus-article-mime-handle-alist-1 nil)
1632(defvar gnus-treatment-function-alist
23f87bed
MB		 1633 '((gnus-treat-x-pgp-sig gnus-article-verify-x-pgp-sig)
1634 (gnus-treat-strip-banner gnus-article-strip-banner)
16409b0b
GM		 1635 (gnus-treat-strip-headers-in-body gnus-article-strip-headers-in-body)
1636 (gnus-treat-highlight-signature gnus-article-highlight-signature)
1637 (gnus-treat-buttonize gnus-article-add-buttons)
1638 (gnus-treat-fill-article gnus-article-fill-cited-article)
1639 (gnus-treat-fill-long-lines gnus-article-fill-long-lines)
1640 (gnus-treat-strip-cr gnus-article-remove-cr)
23f87bed
MB		 1641 (gnus-treat-unsplit-urls gnus-article-unsplit-urls)
1642 (gnus-treat-date-ut gnus-article-date-ut)
1643 (gnus-treat-date-local gnus-article-date-local)
1644 (gnus-treat-date-english gnus-article-date-english)
23f87bed
MB		 1645 (gnus-treat-date-original gnus-article-date-original)
1646 (gnus-treat-date-user-defined gnus-article-date-user)
1647 (gnus-treat-date-iso8601 gnus-article-date-iso8601)
f3f01d5d 1648 (gnus-treat-date-lapsed gnus-article-date-lapsed)
23f87bed
MB		 1649 (gnus-treat-display-x-face gnus-article-display-x-face)
1650 (gnus-treat-display-face gnus-article-display-face)
16409b0b
GM		 1651 (gnus-treat-hide-headers gnus-article-maybe-hide-headers)
1652 (gnus-treat-hide-boring-headers gnus-article-hide-boring-headers)
1653 (gnus-treat-hide-signature gnus-article-hide-signature)
16409b0b 1654 (gnus-treat-strip-list-identifiers gnus-article-hide-list-identifiers)
23f87bed 1655 (gnus-treat-leading-whitespace gnus-article-remove-leading-whitespace)
16409b0b 1656 (gnus-treat-strip-pem gnus-article-hide-pem)
23f87bed
MB		 1657 (gnus-treat-from-picon gnus-treat-from-picon)
1658 (gnus-treat-mail-picon gnus-treat-mail-picon)
1659 (gnus-treat-newsgroups-picon gnus-treat-newsgroups-picon)
16409b0b 1660 (gnus-treat-highlight-headers gnus-article-highlight-headers)
16409b0b 1661 (gnus-treat-highlight-signature gnus-article-highlight-signature)
16409b0b
GM		 1662 (gnus-treat-strip-trailing-blank-lines
1663 gnus-article-remove-trailing-blank-lines)
1664 (gnus-treat-strip-leading-blank-lines
1665 gnus-article-strip-leading-blank-lines)
1666 (gnus-treat-strip-multiple-blank-lines
1667 gnus-article-strip-multiple-blank-lines)
1668 (gnus-treat-overstrike gnus-article-treat-overstrike)
01c52d31 1669 (gnus-treat-ansi-sequences gnus-article-treat-ansi-sequences)
23f87bed 1670 (gnus-treat-unfold-headers gnus-article-treat-unfold-headers)
23f87bed 1671 (gnus-treat-fold-newsgroups gnus-article-treat-fold-newsgroups)
01c52d31 1672 (gnus-treat-fold-headers gnus-article-treat-fold-headers)
16409b0b 1673 (gnus-treat-buttonize-head gnus-article-add-buttons-to-head)
23f87bed 1674 (gnus-treat-display-smileys gnus-treat-smiley)
16409b0b 1675 (gnus-treat-capitalize-sentences gnus-article-capitalize-sentences)
23f87bed
MB		 1676 (gnus-treat-wash-html gnus-article-wash-html)
1677 (gnus-treat-emphasize gnus-article-emphasize)
1678 (gnus-treat-hide-citation gnus-article-hide-citation)
1679 (gnus-treat-hide-citation-maybe gnus-article-hide-citation-maybe)
1680 (gnus-treat-highlight-citation gnus-article-highlight-citation)
1681 (gnus-treat-body-boundary gnus-article-treat-body-boundary)
16409b0b
GM		 1682 (gnus-treat-play-sounds gnus-earcon-display)))
1683
1684(defvar gnus-article-mime-handle-alist nil)
6748645f
LMI		 1685(defvar article-lapsed-timer nil)
1686(defvar gnus-article-current-summary nil)
1687
eec82323
LMI		 1688(defvar gnus-article-mode-syntax-table
1689 (let ((table (copy-syntax-table text-mode-syntax-table)))
23f87bed
MB		 1690 ;; This causes the citation match run O(2^n).
1691 ;; (modify-syntax-entry ?- "w" table)
1692 (modify-syntax-entry ?> ")<" table)
1693 (modify-syntax-entry ?< "(>" table)
1694 ;; make M-. in article buffers work for `foo' strings
1695 (modify-syntax-entry ?' " " table)
1696 (modify-syntax-entry ?` " " table)
eec82323
LMI		 1697 table)
1698 "Syntax table used in article mode buffers.
1699Initialized from `text-mode-syntax-table.")
1700
1701(defvar gnus-save-article-buffer nil)
1702
eec82323
LMI		 1703(defvar gnus-number-of-articles-to-be-saved nil)
1704
1705(defvar gnus-inhibit-hiding nil)
1706
c1d7d285
MB		 1707(defvar gnus-article-edit-mode nil)
1708
23f87bed
MB		 1709;;; Macros for dealing with the article buffer.
1710
1711(defmacro gnus-with-article-headers (&rest forms)
80de1778 1712 `(with-current-buffer gnus-article-buffer
23f87bed
MB		 1713 (save-restriction
1714 (let ((inhibit-read-only t)
1715 (inhibit-point-motion-hooks t)
1716 (case-fold-search t))
1717 (article-narrow-to-head)
1718 ,@forms))))
1719
1720(put 'gnus-with-article-headers 'lisp-indent-function 0)
1721(put 'gnus-with-article-headers 'edebug-form-spec '(body))
1722
1723(defmacro gnus-with-article-buffer (&rest forms)
80de1778 1724 `(with-current-buffer gnus-article-buffer
23f87bed
MB		 1725 (let ((inhibit-read-only t))
1726 ,@forms)))
1727
1728(put 'gnus-with-article-buffer 'lisp-indent-function 0)
1729(put 'gnus-with-article-buffer 'edebug-form-spec '(body))
1730
1731(defun gnus-article-goto-header (header)
1732 "Go to HEADER, which is a regular expression."
1733 (re-search-forward (concat "^\\(" header "\\):") nil t))
1734
eec82323
LMI		 1735(defsubst gnus-article-hide-text (b e props)
1736 "Set text PROPS on the B to E region, extending `intangible' 1 past B."
520aa572 1737 (gnus-add-text-properties-when 'article-type nil b e props)
eec82323
LMI		 1738 (when (memq 'intangible props)
1739 (put-text-property
1740 (max (1- b) (point-min))
1741 b 'intangible (cddr (memq 'intangible props)))))
520aa572 1742
eec82323
LMI		 1743(defsubst gnus-article-unhide-text (b e)
1744 "Remove hidden text properties from region between B and E."
1745 (remove-text-properties b e gnus-hidden-properties)
1746 (when (memq 'intangible gnus-hidden-properties)
1747 (put-text-property (max (1- b) (point-min))
1748 b 'intangible nil)))
1749
1750(defun gnus-article-hide-text-type (b e type)
1751 "Hide text of TYPE between B and E."
23f87bed 1752 (gnus-add-wash-type type)
eec82323
LMI		 1753 (gnus-article-hide-text
1754 b e (cons 'article-type (cons type gnus-hidden-properties))))
1755
1756(defun gnus-article-unhide-text-type (b e type)
6748645f 1757 "Unhide text of TYPE between B and E."
23f87bed 1758 (gnus-delete-wash-type type)
eec82323
LMI		 1759 (remove-text-properties
1760 b e (cons 'article-type (cons type gnus-hidden-properties)))
1761 (when (memq 'intangible gnus-hidden-properties)
1762 (put-text-property (max (1- b) (point-min))
1763 b 'intangible nil)))
1764
1765(defun gnus-article-hide-text-of-type (type)
1766 "Hide text of TYPE in the current buffer."
1767 (save-excursion
1768 (let ((b (point-min))
1769 (e (point-max)))
1770 (while (setq b (text-property-any b e 'article-type type))
1771 (add-text-properties b (incf b) gnus-hidden-properties)))))
1772
1773(defun gnus-article-delete-text-of-type (type)
1774 "Delete text of TYPE in the current buffer."
1775 (save-excursion
a8151ef7 1776 (let ((b (point-min)))
7dafe00b
MB		 1777 (if (eq type 'multipart)
1778 ;; Remove MIME buttons associated with multipart/alternative parts.
1779 (progn
1780 (goto-char b)
1781 (while (if (get-text-property (point) 'gnus-part)
1782 (setq b (point))
1783 (when (setq b (next-single-property-change (point)
1784 'gnus-part))
1785 (goto-char b)
1786 t))
1787 (end-of-line)
1788 (skip-chars-forward "\n")
1789 (when (eq (get-text-property b 'article-type) 'multipart)
1790 (delete-region b (point)))))
1791 (while (setq b (text-property-any b (point-max) 'article-type type))
1792 (delete-region
1793 b (or (text-property-not-all b (point-max) 'article-type type)
1794 (point-max))))))))
eec82323
LMI		 1795
1796(defun gnus-article-delete-invisible-text ()
1797 "Delete all invisible text in the current buffer."
1798 (save-excursion
a8151ef7
LMI		 1799 (let ((b (point-min)))
1800 (while (setq b (text-property-any b (point-max) 'invisible t))
1801 (delete-region
1802 b (or (text-property-not-all b (point-max) 'invisible t)
1803 (point-max)))))))
eec82323
LMI		 1804
1805(defun gnus-article-text-type-exists-p (type)
1806 "Say whether any text of type TYPE exists in the buffer."
1807 (text-property-any (point-min) (point-max) 'article-type type))
1808
1809(defsubst gnus-article-header-rank ()
1810 "Give the rank of the string HEADER as given by `gnus-sorted-header-list'."
1811 (let ((list gnus-sorted-header-list)
23f87bed 1812 (i 1))
eec82323 1813 (while list
23f87bed
MB		 1814 (if (looking-at (car list))
1815 (setq list nil)
1816 (setq list (cdr list))
1817 (incf i)))
1818 i))
eec82323
LMI		 1819
1820(defun article-hide-headers (&optional arg delete)
16409b0b
GM		 1821 "Hide unwanted headers and possibly sort them as well."
1822 (interactive)
1823 ;; This function might be inhibited.
1824 (unless gnus-inhibit-hiding
37cc095b 1825 (let ((inhibit-read-only t)
23f87bed
MB		 1826 (case-fold-search t)
1827 (max (1+ (length gnus-sorted-header-list)))
1828 (inhibit-point-motion-hooks t)
1829 (cur (current-buffer))
1830 ignored visible beg)
1831 (save-excursion
1832 ;; `gnus-ignored-headers' and `gnus-visible-headers' may be
1833 ;; group parameters, so we should go to the summary buffer.
1834 (when (prog1
1835 (condition-case nil
1836 (progn (set-buffer gnus-summary-buffer) t)
1837 (error nil))
1838 (setq ignored (when (not gnus-visible-headers)
1839 (cond ((stringp gnus-ignored-headers)
1840 gnus-ignored-headers)
1841 ((listp gnus-ignored-headers)
1842 (mapconcat 'identity
1843 gnus-ignored-headers
1844 "\\|"))))
1845 visible (cond ((stringp gnus-visible-headers)
1846 gnus-visible-headers)
1847 ((and gnus-visible-headers
1848 (listp gnus-visible-headers))
1849 (mapconcat 'identity
1850 gnus-visible-headers
1851 "\\|")))))
1852 (set-buffer cur))
1853 (save-restriction
16409b0b
GM		 1854 ;; First we narrow to just the headers.
1855 (article-narrow-to-head)
1856 ;; Hide any "From " lines at the beginning of (mail) articles.
1857 (while (looking-at "From ")
1858 (forward-line 1))
1859 (unless (bobp)
1860 (delete-region (point-min) (point)))
1861 ;; Then treat the rest of the header lines.
1862 ;; Then we use the two regular expressions
1863 ;; `gnus-ignored-headers' and `gnus-visible-headers' to
1864 ;; select which header lines is to remain visible in the
1865 ;; article buffer.
23f87bed 1866 (while (re-search-forward "^[^ \t:]*:" nil t)
16409b0b
GM		 1867 (beginning-of-line)
1868 ;; Mark the rank of the header.
1869 (put-text-property
1870 (point) (1+ (point)) 'message-rank
1871 (if (or (and visible (looking-at visible))
1872 (and ignored
1873 (not (looking-at ignored))))
1874 (gnus-article-header-rank)
1875 (+ 2 max)))
1876 (forward-line 1))
1877 (message-sort-headers-1)
1878 (when (setq beg (text-property-any
1879 (point-min) (point-max) 'message-rank (+ 2 max)))
1880 ;; We delete the unwanted headers.
23f87bed 1881 (gnus-add-wash-type 'headers)
16409b0b
GM		 1882 (add-text-properties (point-min) (+ 5 (point-min))
1883 '(article-type headers dummy-invisible t))
1884 (delete-region beg (point-max))))))))
eec82323
LMI		 1885
1886(defun article-hide-boring-headers (&optional arg)
1887 "Toggle hiding of headers that aren't very interesting.
1888If given a negative prefix, always show; if given a positive prefix,
1889always hide."
1890 (interactive (gnus-article-hidden-arg))
1891 (when (and (not (gnus-article-check-hidden-text 'boring-headers arg))
1892 (not gnus-show-all-headers))
1893 (save-excursion
1894 (save-restriction
4e7d0221 1895 (let ((inhibit-read-only t)
01c52d31 1896 (inhibit-point-motion-hooks t))
16409b0b 1897 (article-narrow-to-head)
01c52d31 1898 (dolist (elem gnus-boring-article-headers)
eec82323
LMI		 1899 (goto-char (point-min))
1900 (cond
1901 ;; Hide empty headers.
1902 ((eq elem 'empty)
16409b0b 1903 (while (re-search-forward "^[^: \t]+:[ \t]*\n[^ \t]" nil t)
eec82323
LMI		 1904 (forward-line -1)
1905 (gnus-article-hide-text-type
01c52d31 1906 (point-at-bol)
eec82323
LMI		 1907 (progn
1908 (end-of-line)
1909 (if (re-search-forward "^[^ \t]" nil t)
1910 (match-beginning 0)
1911 (point-max)))
1912 'boring-headers)))
1913 ;; Hide boring Newsgroups header.
1914 ((eq elem 'newsgroups)
23f87bed
MB		 1915 (when (gnus-string-equal
1916 (gnus-fetch-field "newsgroups")
1917 (gnus-group-real-name
1918 (if (boundp 'gnus-newsgroup-name)
1919 gnus-newsgroup-name
1920 "")))
eec82323 1921 (gnus-article-hide-header "newsgroups")))
23f87bed
MB		 1922 ((eq elem 'to-address)
1923 (let ((to (message-fetch-field "to"))
1924 (to-address
1925 (gnus-parameter-to-address
1926 (if (boundp 'gnus-newsgroup-name)
1927 gnus-newsgroup-name ""))))
1928 (when (and to to-address
1929 (ignore-errors
1930 (gnus-string-equal
1931 ;; only one address in To
1932 (nth 1 (mail-extract-address-components to))
1933 to-address)))
1934 (gnus-article-hide-header "to"))))
1935 ((eq elem 'to-list)
1936 (let ((to (message-fetch-field "to"))
1937 (to-list
1938 (gnus-parameter-to-list
1939 (if (boundp 'gnus-newsgroup-name)
1940 gnus-newsgroup-name ""))))
1941 (when (and to to-list
1942 (ignore-errors
1943 (gnus-string-equal
1944 ;; only one address in To
1945 (nth 1 (mail-extract-address-components to))
1946 to-list)))
1947 (gnus-article-hide-header "to"))))
1948 ((eq elem 'cc-list)
1949 (let ((cc (message-fetch-field "cc"))
1950 (to-list
1951 (gnus-parameter-to-list
1952 (if (boundp 'gnus-newsgroup-name)
1953 gnus-newsgroup-name ""))))
1954 (when (and cc to-list
1955 (ignore-errors
1956 (gnus-string-equal
1957 ;; only one address in CC
1958 (nth 1 (mail-extract-address-components cc))
1959 to-list)))
1960 (gnus-article-hide-header "cc"))))
eec82323 1961 ((eq elem 'followup-to)
23f87bed
MB		 1962 (when (gnus-string-equal
1963 (message-fetch-field "followup-to")
1964 (message-fetch-field "newsgroups"))
eec82323
LMI		 1965 (gnus-article-hide-header "followup-to")))
1966 ((eq elem 'reply-to)
23f87bed
MB		 1967 (if (gnus-group-find-parameter
1968 gnus-newsgroup-name 'broken-reply-to)
1969 (gnus-article-hide-header "reply-to")
1970 (let ((from (message-fetch-field "from"))
1971 (reply-to (message-fetch-field "reply-to")))
1972 (when
1973 (and
eec82323
LMI		 1974 from reply-to
1975 (ignore-errors
1976 (equal
23f87bed
MB		 1977 (sort (mapcar
1978 (lambda (x) (downcase (cadr x)))
1979 (mail-extract-address-components from t))
1980 'string<)
1981 (sort (mapcar
1982 (lambda (x) (downcase (cadr x)))
1983 (mail-extract-address-components reply-to t))
1984 'string<))))
1985 (gnus-article-hide-header "reply-to")))))
eec82323 1986 ((eq elem 'date)
b193caa3
MB		 1987 (let ((date (with-current-buffer gnus-original-article-buffer
1988 ;; If date in `gnus-article-buffer' is localized
1989 ;; (`gnus-treat-date-user-defined'),
1990 ;; `days-between' might fail.
1991 (message-fetch-field "date"))))
eec82323 1992 (when (and date
16409b0b 1993 (< (days-between (current-time-string) date)
eec82323 1994 4))
6748645f
LMI		 1995 (gnus-article-hide-header "date"))))
1996 ((eq elem 'long-to)
16409b0b
GM		 1997 (let ((to (message-fetch-field "to"))
1998 (cc (message-fetch-field "cc")))
6748645f 1999 (when (> (length to) 1024)
16409b0b
GM		 2000 (gnus-article-hide-header "to"))
2001 (when (> (length cc) 1024)
2002 (gnus-article-hide-header "cc"))))
6748645f 2003 ((eq elem 'many-to)
16409b0b
GM		 2004 (let ((to-count 0)
2005 (cc-count 0))
6748645f
LMI		 2006 (goto-char (point-min))
2007 (while (re-search-forward "^to:" nil t)
2008 (setq to-count (1+ to-count)))
2009 (when (> to-count 1)
2010 (while (> to-count 0)
2011 (goto-char (point-min))
2012 (save-restriction
2013 (re-search-forward "^to:" nil nil to-count)
2014 (forward-line -1)
2015 (narrow-to-region (point) (point-max))
2016 (gnus-article-hide-header "to"))
16409b0b
GM		 2017 (setq to-count (1- to-count))))
2018 (goto-char (point-min))
2019 (while (re-search-forward "^cc:" nil t)
2020 (setq cc-count (1+ cc-count)))
2021 (when (> cc-count 1)
2022 (while (> cc-count 0)
2023 (goto-char (point-min))
2024 (save-restriction
2025 (re-search-forward "^cc:" nil nil cc-count)
2026 (forward-line -1)
2027 (narrow-to-region (point) (point-max))
2028 (gnus-article-hide-header "cc"))
2029 (setq cc-count (1- cc-count)))))))))))))
eec82323
LMI		 2030
2031(defun gnus-article-hide-header (header)
2032 (save-excursion
2033 (goto-char (point-min))
2034 (when (re-search-forward (concat "^" header ":") nil t)
2035 (gnus-article-hide-text-type
01c52d31 2036 (point-at-bol)
eec82323
LMI		 2037 (progn
2038 (end-of-line)
2039 (if (re-search-forward "^[^ \t]" nil t)
2040 (match-beginning 0)
2041 (point-max)))
2042 'boring-headers))))
2043
16409b0b
GM		 2044(defvar gnus-article-normalized-header-length 40
2045 "Length of normalized headers.")
2046
2047(defun article-normalize-headers ()
2048 "Make all header lines 40 characters long."
2049 (interactive)
4e7d0221 2050 (let ((inhibit-read-only t)
16409b0b
GM		 2051 column)
2052 (save-excursion
2053 (save-restriction
2054 (article-narrow-to-head)
2055 (while (not (eobp))
2056 (cond
01c52d31 2057 ((< (setq column (- (point-at-eol) (point)))
16409b0b
GM		 2058 gnus-article-normalized-header-length)
2059 (end-of-line)
2060 (insert (make-string
2061 (- gnus-article-normalized-header-length column)
2062 ? )))
2063 ((> column gnus-article-normalized-header-length)
2064 (gnus-put-text-property
2065 (progn
2066 (forward-char gnus-article-normalized-header-length)
2067 (point))
01c52d31 2068 (point-at-eol)
16409b0b
GM		 2069 'invisible t))
2070 (t
2071 ;; Do nothing.
2072 ))
2073 (forward-line 1))))))
2074
6748645f 2075(defun article-treat-dumbquotes ()
23f87bed 2076 "Translate M****s*** sm*rtq**t*s and other symbols into proper text.
16409b0b 2077Note that this function guesses whether a character is a sm*rtq**t* or
74dd1b0d
SZ		 2078not, so it should only be used interactively.
2079
23f87bed
MB		 2080Sm*rtq**t*s are M****s***'s unilateral extension to the
2081iso-8859-1 character map in an attempt to provide more quoting
2082characters. If you see something like \\222 or \\264 where
2083you're expecting some kind of apostrophe or quotation mark, then
2084try this wash."
6748645f 2085 (interactive)
16409b0b 2086 (article-translate-strings gnus-article-dumbquotes-map))
6748645f
LMI		 2087
2088(defun article-translate-characters (from to)
2089 "Translate all characters in the body of the article according to FROM and TO.
2090FROM is a string of characters to translate from; to is a string of
2091characters to translate to."
2092 (save-excursion
16409b0b 2093 (when (article-goto-body)
4e7d0221 2094 (let ((inhibit-read-only t)
6748645f
LMI		 2095 (x (make-string 225 ?x))
2096 (i -1))
2097 (while (< (incf i) (length x))
2098 (aset x i i))
2099 (setq i 0)
2100 (while (< i (length from))
2101 (aset x (aref from i) (aref to i))
2102 (incf i))
2103 (translate-region (point) (point-max) x)))))
2104
16409b0b
GM		 2105(defun article-translate-strings (map)
2106 "Translate all string in the body of the article according to MAP.
2107MAP is an alist where the elements are on the form (\"from\" \"to\")."
2108 (save-excursion
2109 (when (article-goto-body)
01c52d31
MB		 2110 (let ((inhibit-read-only t))
2111 (dolist (elem map)
16409b0b
GM		 2112 (save-excursion
2113 (while (search-forward (car elem) nil t)
2114 (replace-match (cadr elem)))))))))
2115
eec82323
LMI		 2116(defun article-treat-overstrike ()
2117 "Translate overstrikes into bold text."
2118 (interactive)
2119 (save-excursion
16409b0b 2120 (when (article-goto-body)
4e7d0221 2121 (let ((inhibit-read-only t))
eec82323 2122 (while (search-forward "\b" nil t)
16409b0b 2123 (let ((next (char-after))
eec82323
LMI		 2124 (previous (char-after (- (point) 2))))
2125 ;; We do the boldification/underlining by hiding the
2126 ;; overstrikes and putting the proper text property
2127 ;; on the letters.
2128 (cond
2129 ((eq next previous)
2130 (gnus-article-hide-text-type (- (point) 2) (point) 'overstrike)
2131 (put-text-property (point) (1+ (point)) 'face 'bold))
2132 ((eq next ?_)
2133 (gnus-article-hide-text-type
2134 (1- (point)) (1+ (point)) 'overstrike)
2135 (put-text-property
2136 (- (point) 2) (1- (point)) 'face 'underline))
2137 ((eq previous ?_)
2138 (gnus-article-hide-text-type (- (point) 2) (point) 'overstrike)
2139 (put-text-property
2140 (point) (1+ (point)) 'face 'underline)))))))))
2141
01c52d31
MB		 2142(defun article-treat-ansi-sequences ()
2143 "Translate ANSI SGR control sequences into overlays or extents."
2144 (interactive)
2145 (save-excursion
2146 (when (article-goto-body)
2147 (let ((inhibit-read-only t))
2148 (ansi-color-apply-on-region (point) (point-max))))))
2149
23f87bed
MB		 2150(defun gnus-article-treat-unfold-headers ()
2151 "Unfold folded message headers.
2152Only the headers that fit into the current window width will be
2153unfolded."
2154 (interactive)
2155 (gnus-with-article-headers
2156 (let (length)
2157 (while (not (eobp))
2158 (save-restriction
2159 (mail-header-narrow-to-field)
01c52d31
MB		 2160 (let* ((header (buffer-string))
2161 (unfoldable
2162 (or (equal gnus-article-unfold-long-headers t)
2163 (and (stringp gnus-article-unfold-long-headers)
2164 (string-match gnus-article-unfold-long-headers header)))))
23f87bed
MB		 2165 (with-temp-buffer
2166 (insert header)
2167 (goto-char (point-min))
2168 (while (re-search-forward "\n[\t ]" nil t)
2169 (replace-match " " t t)))
01c52d31
MB		 2170 (setq length (- (point-max) (point-min) 1))
2171 (when (or unfoldable
2172 (< length (window-width)))
2173 (while (re-search-forward "\n[\t ]" nil t)
2174 (replace-match " " t t))))
23f87bed
MB		 2175 (goto-char (point-max)))))))
2176
2177(defun gnus-article-treat-fold-headers ()
2178 "Fold message headers."
2179 (interactive)
2180 (gnus-with-article-headers
2181 (while (not (eobp))
2182 (save-restriction
2183 (mail-header-narrow-to-field)
2184 (mail-header-fold-field)
2185 (goto-char (point-max))))))
2186
2187(defun gnus-treat-smiley ()
2188 "Toggle display of textual emoticons (\"smileys\") as small graphical icons."
2189 (interactive)
2190 (gnus-with-article-buffer
2191 (if (memq 'smiley gnus-article-wash-types)
2192 (gnus-delete-images 'smiley)
2193 (article-goto-body)
2194 (let ((images (smiley-region (point) (point-max))))
2195 (when images
2196 (gnus-add-wash-type 'smiley)
2197 (dolist (image images)
2198 (gnus-add-image 'smiley image)))))))
2199
2200(defun gnus-article-remove-images ()
2201 "Remove all images from the article buffer."
2202 (interactive)
2203 (gnus-with-article-buffer
2204 (dolist (elem gnus-article-image-alist)
2205 (gnus-delete-images (car elem)))))
2206
2207(defun gnus-article-treat-fold-newsgroups ()
2208 "Unfold folded message headers.
2209Only the headers that fit into the current window width will be
2210unfolded."
2211 (interactive)
2212 (gnus-with-article-headers
2213 (while (gnus-article-goto-header "newsgroups\\|followup-to")
2214 (save-restriction
2215 (mail-header-narrow-to-field)
2216 (while (re-search-forward ", *" nil t)
2217 (replace-match ", " t t))
2218 (mail-header-fold-field)
2219 (goto-char (point-max))))))
2220
b7b80032 2221(defcustom gnus-article-truncate-lines (default-value 'truncate-lines)
01c52d31
MB		 2222 "Value of `truncate-lines' in Gnus Article buffer.
2223Valid values are nil, t, `head', `first', `last', an integer or a
2224predicate. See Info node `(gnus)Customizing Articles'."
330f707b 2225 :version "23.1" ;; No Gnus
01c52d31
MB		 2226 :group 'gnus-article
2227 ;; :link '(custom-manual "(gnus)Customizing Articles")
2228 :type 'boolean)
2229
2230(defun gnus-article-toggle-truncate-lines (&optional arg)
2231 "Toggle whether to fold or truncate long lines in article the buffer.
2232If ARG is non-nil and not a number, toggle
2233`gnus-article-truncate-lines' too. If ARG is a number, truncate
2234long lines iff arg is positive."
2235 (interactive "P")
2236 (cond
2237 ((and (numberp arg) (> arg 0))
2238 (setq gnus-article-truncate-lines t))
2239 ((numberp arg)
2240 (setq gnus-article-truncate-lines nil))
2241 (arg
2242 (setq gnus-article-truncate-lines
2243 (not gnus-article-truncate-lines))))
2244 (gnus-with-article-buffer
2245 (cond
2246 ((and (numberp arg) (> arg 0))
2247 (setq truncate-lines nil))
2248 ((numberp arg)
2249 (setq truncate-lines t)))
2250 ;; In versions of Emacs 22 (CVS) before 2006-05-26,
2251 ;; `toggle-truncate-lines' needs an argument.
2252 (toggle-truncate-lines)))
2253
23f87bed
MB		 2254(defun gnus-article-treat-body-boundary ()
2255 "Place a boundary line at the end of the headers."
2256 (interactive)
2257 (when (and gnus-body-boundary-delimiter
2258 (> (length gnus-body-boundary-delimiter) 0))
2259 (gnus-with-article-headers
2260 (goto-char (point-max))
2261 (let ((start (point)))
2262 (insert "X-Boundary: ")
2263 (gnus-add-text-properties start (point) '(invisible t intangible t))
2264 (insert (let (str)
2265 (while (>= (1- (window-width)) (length str))
2266 (setq str (concat str gnus-body-boundary-delimiter)))
2267 (substring str 0 (1- (window-width))))
2268 "\n")
2269 (gnus-put-text-property start (point) 'gnus-decoration 'header)))))
2270
16409b0b
GM		 2271(defun article-fill-long-lines ()
2272 "Fill lines that are wider than the window width."
eec82323
LMI		 2273 (interactive)
2274 (save-excursion
4e7d0221 2275 (let ((inhibit-read-only t)
16409b0b
GM		 2276 (width (window-width (get-buffer-window (current-buffer)))))
2277 (save-restriction
2278 (article-goto-body)
80b47379 2279 (let ((adaptive-fill-mode nil)) ;Why? -sm
16409b0b
GM		 2280 (while (not (eobp))
2281 (end-of-line)
2282 (when (>= (current-column) (min fill-column width))
23f87bed 2283 (narrow-to-region (min (1+ (point)) (point-max))
01c52d31 2284 (point-at-bol))
23f87bed
MB		 2285 (let ((goback (point-marker)))
2286 (fill-paragraph nil)
2287 (goto-char (marker-position goback)))
16409b0b
GM		 2288 (widen))
2289 (forward-line 1)))))))
2290
2291(defun article-capitalize-sentences ()
2292 "Capitalize the first word in each sentence."
2293 (interactive)
2294 (save-excursion
4e7d0221 2295 (let ((inhibit-read-only t)
16409b0b
GM		 2296 (paragraph-start "^[\n\^L]"))
2297 (article-goto-body)
2298 (while (not (eobp))
2299 (capitalize-word 1)
2300 (forward-sentence)))))
eec82323
LMI		 2301
2302(defun article-remove-cr ()
16409b0b 2303 "Remove trailing CRs and then translate remaining CRs into LFs."
eec82323
LMI		 2304 (interactive)
2305 (save-excursion
4e7d0221 2306 (let ((inhibit-read-only t))
eec82323 2307 (goto-char (point-min))
16409b0b
GM		 2308 (while (re-search-forward "\r+$" nil t)
2309 (replace-match "" t t))
2310 (goto-char (point-min))
eec82323 2311 (while (search-forward "\r" nil t)
16409b0b 2312 (replace-match "\n" t t)))))
eec82323
LMI		 2313
2314(defun article-remove-trailing-blank-lines ()
2315 "Remove all trailing blank lines from the article."
2316 (interactive)
2317 (save-excursion
4e7d0221 2318 (let ((inhibit-read-only t))
eec82323
LMI		 2319 (goto-char (point-max))
2320 (delete-region
2321 (point)
2322 (progn
2323 (while (and (not (bobp))
16409b0b
GM		 2324 (looking-at "^[ \t]*$")
2325 (not (gnus-annotation-in-region-p
01c52d31 2326 (point) (point-at-eol))))
eec82323
LMI		 2327 (forward-line -1))
2328 (forward-line 1)
2329 (point))))))
2330
9efa445f 2331(defvar gnus-face-properties-alist)
01c52d31 2332
b890d447 2333(defun article-display-face (&optional force)
23f87bed 2334 "Display any Face headers in the header."
b890d447 2335 (interactive (list 'force))
23f87bed
MB		 2336 (let ((wash-face-p buffer-read-only))
2337 (gnus-with-article-headers
2338 ;; When displaying parts, this function can be called several times on
2339 ;; the same article, without any intended toggle semantic (as typing `W
2340 ;; D d' would have). So face deletion must occur only when we come from
2341 ;; an interactive command, that is when the *Article* buffer is
2342 ;; read-only.
2343 (if (and wash-face-p (memq 'face gnus-article-wash-types))
2344 (gnus-delete-images 'face)
b890d447
MB		 2345 (let ((from (message-fetch-field "from"))
2346 face faces)
7d0c69be 2347 (save-current-buffer
23f87bed 2348 (when (and wash-face-p
7d0c69be
MB		 2349 (gnus-buffer-live-p gnus-original-article-buffer)
2350 (not (re-search-forward "^Face:[\t ]*" nil t)))
23f87bed
MB		 2351 (set-buffer gnus-original-article-buffer))
2352 (save-restriction
2353 (mail-narrow-to-head)
b890d447
MB		 2354 (when (or force
2355 ;; Check whether this face is censored.
2356 (not (and gnus-article-x-face-too-ugly
2357 (or from
2358 (setq from (message-fetch-field "from")))
2359 (string-match gnus-article-x-face-too-ugly
2360 from))))
2361 (while (gnus-article-goto-header "Face")
2362 (push (mail-header-field-value) faces)))))
d6697c02 2363 (when faces
7d0c69be 2364 (goto-char (point-min))
b890d447
MB		 2365 (let (png image)
2366 (unless (setq from (gnus-article-goto-header "from"))
7d0c69be
MB		 2367 (insert "From:")
2368 (setq from (point))
b890d447 2369 (insert " [no `from' set]\n"))
7d0c69be
MB		 2370 (while faces
2371 (when (setq png (gnus-convert-face-to-png (pop faces)))
01c52d31
MB		 2372 (setq image
2373 (apply 'gnus-create-image png 'png t
2374 (cdr (assq 'png gnus-face-properties-alist))))
d6697c02
MB		 2375 (goto-char from)
2376 (gnus-add-wash-type 'face)
2377 (gnus-add-image 'face image)
2378 (gnus-put-image image nil 'face))))))))))
23f87bed 2379
eec82323
LMI		 2380(defun article-display-x-face (&optional force)
2381 "Look for an X-Face header and display it if present."
2382 (interactive (list 'force))
23f87bed
MB		 2383 (let ((wash-face-p buffer-read-only)) ;; When type `W f'
2384 (gnus-with-article-headers
2385 ;; Delete the old process, if any.
2386 (when (process-status "article-x-face")
2387 (delete-process "article-x-face"))
2388 ;; See the comment in `article-display-face'.
2389 (if (and wash-face-p (memq 'xface gnus-article-wash-types))
2390 ;; We have already displayed X-Faces, so we remove them
2391 ;; instead.
2392 (gnus-delete-images 'xface)
2393 ;; Display X-Faces.
b890d447
MB		 2394 (let ((from (message-fetch-field "from"))
2395 x-faces face)
7d0c69be 2396 (save-current-buffer
23f87bed 2397 (when (and wash-face-p
7d0c69be
MB		 2398 (gnus-buffer-live-p gnus-original-article-buffer)
2399 (not (re-search-forward "^X-Face:[\t ]*" nil t)))
23f87bed
MB		 2400 ;; If type `W f', use gnus-original-article-buffer,
2401 ;; otherwise use the current buffer because displaying
2402 ;; RFC822 parts calls this function too.
2403 (set-buffer gnus-original-article-buffer))
2404 (save-restriction
2405 (mail-narrow-to-head)
b890d447
MB		 2406 (and gnus-article-x-face-command
2407 (or force
2408 ;; Check whether this face is censored.
2409 (not (and gnus-article-x-face-too-ugly
2410 (or from
2411 (setq from (message-fetch-field "from")))
2412 (string-match gnus-article-x-face-too-ugly
2413 from))))
2414 (while (gnus-article-goto-header "X-Face")
2415 (push (mail-header-field-value) x-faces)))))
2416 (when x-faces
2417 ;; We display the face.
2418 (cond ((functionp gnus-article-x-face-command)
2419 ;; The command is a lisp function, so we call it.
2420 (mapc gnus-article-x-face-command x-faces))
2421 ((stringp gnus-article-x-face-command)
2422 ;; The command is a string, so we interpret the command
2423 ;; as a, well, command, and fork it off.
2424 (let ((process-connection-type nil))
2425 (gnus-set-process-query-on-exit-flag
2426 (start-process
2427 "article-x-face" nil shell-file-name
2428 shell-command-switch gnus-article-x-face-command)
2429 nil)
2430 ;; Sending multiple EOFs to xv doesn't work,
2431 ;; so we only do a single external face.
2432 (with-temp-buffer
2433 (insert (car x-faces))
2434 (process-send-region "article-x-face"
2435 (point-min) (point-max)))
2436 (process-send-eof "article-x-face")))
2437 (t
2438 (error "`%s' set to `%s' is not a function"
2439 gnus-article-x-face-command
2440 'gnus-article-x-face-command)))))))))
a8151ef7 2441
16409b0b
GM		 2442(defun article-decode-mime-words ()
2443 "Decode all MIME-encoded words in the article."
2444 (interactive)
01c52d31 2445 (gnus-with-article-buffer
16409b0b 2446 (let ((inhibit-point-motion-hooks t)
16409b0b 2447 (mail-parse-charset gnus-newsgroup-charset)
a1506d29 2448 (mail-parse-ignored-charsets
01c52d31
MB		 2449 (with-current-buffer gnus-summary-buffer
2450 gnus-newsgroup-ignored-charsets)))
16409b0b
GM		 2451 (mail-decode-encoded-word-region (point-min) (point-max)))))
2452
2453(defun article-decode-charset (&optional prompt)
2454 "Decode charset-encoded text in the article.
2455If PROMPT (the prefix), prompt for a coding system to use."
2456 (interactive "P")
2457 (let ((inhibit-point-motion-hooks t) (case-fold-search t)
23f87bed 2458 (inhibit-read-only t)
16409b0b 2459 (mail-parse-charset gnus-newsgroup-charset)
a1506d29 2460 (mail-parse-ignored-charsets
16409b0b
GM		 2461 (save-excursion (condition-case nil
2462 (set-buffer gnus-summary-buffer)
2463 (error))
2464 gnus-newsgroup-ignored-charsets))
2465 ct cte ctl charset format)
c96ec15a
MB		 2466 (save-excursion
2467 (save-restriction
2468 (article-narrow-to-head)
2469 (setq ct (message-fetch-field "Content-Type" t)
2470 cte (message-fetch-field "Content-Transfer-Encoding" t)
2471 ctl (and ct (mail-header-parse-content-type ct))
2472 charset (cond
2473 (prompt
2474 (mm-read-coding-system "Charset to decode: "))
2475 (ctl
2476 (mail-content-type-get ctl 'charset)))
2477 format (and ctl (mail-content-type-get ctl 'format)))
2478 (when cte
2479 (setq cte (mail-header-strip cte)))
2480 (if (and ctl (not (string-match "/" (car ctl))))
2481 (setq ctl nil))
2482 (goto-char (point-max)))
2483 (forward-line 1)
2484 (save-restriction
2485 (narrow-to-region (point) (point-max))
2486 (when (and (eq mail-parse-charset 'gnus-decoded)
2487 (eq (mm-body-7-or-8) '8bit))
2488 ;; The text code could have been decoded.
2489 (setq charset mail-parse-charset))
2490 (when (and (or (not ctl)
2491 (equal (car ctl) "text/plain"))
2492 (not format)) ;; article with format will decode later.
2493 (mm-decode-body
2494 charset (and cte (intern (downcase
2495 (gnus-strip-whitespace cte))))
2496 (car ctl)))))))
16409b0b
GM		 2497
2498(defun article-decode-encoded-words ()
2499 "Remove encoded-word encoding from headers."
2500 (let ((inhibit-point-motion-hooks t)
2501 (mail-parse-charset gnus-newsgroup-charset)
a1506d29 2502 (mail-parse-ignored-charsets
16409b0b
GM		 2503 (save-excursion (condition-case nil
2504 (set-buffer gnus-summary-buffer)
2505 (error))
2506 gnus-newsgroup-ignored-charsets))
343d6628 2507 (inhibit-read-only t)
8fbdffe5
MB		 2508 end start)
2509 (goto-char (point-min))
2510 (when (search-forward "\n\n" nil 'move)
2511 (forward-line -1))
2512 (setq end (point))
2513 (while (not (bobp))
2514 (while (progn
2515 (forward-line -1)
2516 (and (not (bobp))
2517 (memq (char-after) '(?\t ? )))))
2518 (setq start (point))
2519 (if (looking-at "\
343d6628
MB		 2520\\(?:Resent-\\)?\\(?:From\\|Cc\\|To\\|Bcc\\|\\(?:In-\\)?Reply-To\\|Sender\
2521\\|Mail-Followup-To\\|Mail-Copies-To\\|Approved\\):")
8fbdffe5
MB		 2522 (funcall gnus-decode-address-function start end)
2523 (funcall gnus-decode-header-function start end))
2524 (goto-char (setq end start)))))
eec82323 2525
23f87bed 2526(defun article-decode-group-name ()
01c52d31 2527 "Decode group names in Newsgroups, Followup-To and Xref headers."
23f87bed
MB		 2528 (let ((inhibit-point-motion-hooks t)
2529 (inhibit-read-only t)
01c52d31
MB		 2530 (method (gnus-find-method-for-group gnus-newsgroup-name))
2531 regexp)
23f87bed
MB		 2532 (when (and (or gnus-group-name-charset-method-alist
2533 gnus-group-name-charset-group-alist)
2534 (gnus-buffer-live-p gnus-original-article-buffer))
2535 (save-restriction
2536 (article-narrow-to-head)
01c52d31
MB		 2537 (dolist (header '("Newsgroups" "Followup-To" "Xref"))
2538 (with-current-buffer gnus-original-article-buffer
2539 (goto-char (point-min)))
2540 (setq regexp (concat "^" header
2541 ":\\([^\n]*\\(?:\n[\t ]+[^\n]+\\)*\\)\n"))
2542 (while (re-search-forward regexp nil t)
2543 (replace-match (save-match-data
2544 (gnus-decode-newsgroups
2545 ;; XXX how to use data in article buffer?
2546 (with-current-buffer gnus-original-article-buffer
2547 (re-search-forward regexp nil t)
2548 (match-string 1))
2549 gnus-newsgroup-name method))
2550 t t nil 1))
2551 (goto-char (point-min)))))))
23f87bed
MB		 2552
2553(autoload 'idna-to-unicode "idna")
2554
2555(defun article-decode-idna-rhs ()
53cfefc8
MB		 2556 "Decode IDNA strings in RHS in various headers in current buffer.
2557The following headers are decoded: From:, To:, Cc:, Reply-To:,
2558Mail-Reply-To: and Mail-Followup-To:."
23f87bed
MB		 2559 (when gnus-use-idna
2560 (save-restriction
2561 (let ((inhibit-point-motion-hooks t)
2562 (inhibit-read-only t))
2563 (article-narrow-to-head)
2564 (goto-char (point-min))
53cfefc8 2565 (while (re-search-forward "@[^ \t\n\r,>]*\\(xn--[-A-Za-z0-9.]*\\)[ \t\n\r,>]" nil t)
23f87bed
MB		 2566 (let (ace unicode)
2567 (when (save-match-data
2568 (and (setq ace (match-string 1))
2569 (save-excursion
2570 (and (re-search-backward "^[^ \t]" nil t)
53cfefc8 2571 (looking-at "From\\|To\\|Cc\\|Reply-To\\|Mail-Reply-To\\|Mail-Followup-To")))
23f87bed
MB		 2572 (setq unicode (idna-to-unicode ace))))
2573 (unless (string= ace unicode)
2574 (replace-match unicode nil nil nil 1)))))))))
2575
2576(defun article-de-quoted-unreadable (&optional force read-charset)
16409b0b 2577 "Translate a quoted-printable-encoded article.
eec82323 2578If FORCE, decode the article whether it is marked as quoted-printable
23f87bed
MB		 2579or not.
2580If READ-CHARSET, ask for a coding system."
2581 (interactive (list 'force current-prefix-arg))
eec82323 2582 (save-excursion
4e7d0221 2583 (let ((inhibit-read-only t) type charset)
8b93df01
DL		 2584 (if (gnus-buffer-live-p gnus-original-article-buffer)
2585 (with-current-buffer gnus-original-article-buffer
2586 (setq type
2587 (gnus-fetch-field "content-transfer-encoding"))
2588 (let* ((ct (gnus-fetch-field "content-type"))
c96ec15a 2589 (ctl (and ct (mail-header-parse-content-type ct))))
8b93df01
DL		 2590 (setq charset (and ctl
2591 (mail-content-type-get ctl 'charset)))
2592 (if (stringp charset)
2593 (setq charset (intern (downcase charset)))))))
23f87bed
MB		 2594 (if read-charset
2595 (setq charset (mm-read-coding-system "Charset: " charset)))
a1506d29 2596 (unless charset
8b93df01 2597 (setq charset gnus-newsgroup-charset))
eec82323 2598 (when (or force
eb806ef3
DL		 2599 (and type (let ((case-fold-search t))
2600 (string-match "quoted-printable" type))))
16409b0b 2601 (article-goto-body)
eb806ef3
DL		 2602 (quoted-printable-decode-region
2603 (point) (point-max) (mm-charset-to-coding-system charset))))))
16409b0b 2604
23f87bed 2605(defun article-de-base64-unreadable (&optional force read-charset)
16409b0b 2606 "Translate a base64 article.
23f87bed
MB		 2607If FORCE, decode the article whether it is marked as base64 not.
2608If READ-CHARSET, ask for a coding system."
2609 (interactive (list 'force current-prefix-arg))
16409b0b 2610 (save-excursion
4e7d0221 2611 (let ((inhibit-read-only t) type charset)
8b93df01
DL		 2612 (if (gnus-buffer-live-p gnus-original-article-buffer)
2613 (with-current-buffer gnus-original-article-buffer
2614 (setq type
2615 (gnus-fetch-field "content-transfer-encoding"))
2616 (let* ((ct (gnus-fetch-field "content-type"))
c96ec15a 2617 (ctl (and ct (mail-header-parse-content-type ct))))
8b93df01
DL		 2618 (setq charset (and ctl
2619 (mail-content-type-get ctl 'charset)))
2620 (if (stringp charset)
2621 (setq charset (intern (downcase charset)))))))
23f87bed
MB		 2622 (if read-charset
2623 (setq charset (mm-read-coding-system "Charset: " charset)))
a1506d29 2624 (unless charset
8b93df01 2625 (setq charset gnus-newsgroup-charset))
16409b0b 2626 (when (or force
eb806ef3
DL		 2627 (and type (let ((case-fold-search t))
2628 (string-match "base64" type))))
16409b0b
GM		 2629 (article-goto-body)
2630 (save-restriction
2631 (narrow-to-region (point) (point-max))
2632 (base64-decode-region (point-min) (point-max))
eb806ef3
DL		 2633 (mm-decode-coding-region
2634 (point-min) (point-max) (mm-charset-to-coding-system charset)))))))
16409b0b
GM		 2635
2636(eval-when-compile
2637 (require 'rfc1843))
2638
2639(defun article-decode-HZ ()
2640 "Translate a HZ-encoded article."
2641 (interactive)
2642 (require 'rfc1843)
2643 (save-excursion
4e7d0221 2644 (let ((inhibit-read-only t))
16409b0b
GM		 2645 (rfc1843-decode-region (point-min) (point-max)))))
2646
23f87bed
MB		 2647(defun article-unsplit-urls ()
2648 "Remove the newlines that some other mailers insert into URLs."
16409b0b 2649 (interactive)
23f87bed
MB		 2650 (save-excursion
2651 (let ((inhibit-read-only t))
2652 (goto-char (point-min))
2653 (while (re-search-forward
97f78c9b 2654 "\\(\\(https?\\|ftp\\)://\\S-+\\) *\n\\(\\S-+\\)" nil t)
23f87bed
MB		 2655 (replace-match "\\1\\3" t)))
2656 (when (interactive-p)
2657 (gnus-treat-article nil))))
2658
2659
2660(defun article-wash-html (&optional read-charset)
2661 "Format an HTML article.
73043f7d
MB		 2662If READ-CHARSET, ask for a coding system. If it is a number, the
2663charset defined in `gnus-summary-show-article-charset-alist' is used."
23f87bed 2664 (interactive "P")
16409b0b 2665 (save-excursion
4e7d0221 2666 (let ((inhibit-read-only t)
8b93df01 2667 charset)
73043f7d
MB		 2668 (if read-charset
2669 (if (or (and (numberp read-charset)
2670 (setq charset
2671 (cdr
2672 (assq read-charset
2673 gnus-summary-show-article-charset-alist))))
2674 (setq charset (mm-read-coding-system "Charset: ")))
2675 (let ((gnus-summary-show-article-charset-alist
2676 (list (cons 1 charset))))
2677 (with-current-buffer gnus-summary-buffer
2678 (gnus-summary-show-article 1)))
2679 (error "No charset is given"))
2680 (when (gnus-buffer-live-p gnus-original-article-buffer)
2681 (with-current-buffer gnus-original-article-buffer
2682 (let* ((ct (gnus-fetch-field "content-type"))
c96ec15a 2683 (ctl (and ct (mail-header-parse-content-type ct))))
73043f7d
MB		 2684 (setq charset (and ctl
2685 (mail-content-type-get ctl 'charset)))
2686 (when (stringp charset)
2687 (setq charset (intern (downcase charset)))))))
2688 (unless charset
2689 (setq charset gnus-newsgroup-charset)))
16409b0b
GM		 2690 (article-goto-body)
2691 (save-window-excursion
2692 (save-restriction
2693 (narrow-to-region (point) (point-max))
23f87bed
MB		 2694 (let* ((func (or gnus-article-wash-function mm-text-html-renderer))
2695 (entry (assq func mm-text-html-washer-alist)))
2696 (when entry
2697 (setq func (cdr entry)))
2698 (cond
2699 ((functionp func)
2700 (funcall func))
2701 (t
2702 (apply (car func) (cdr func))))))))))
2703
9640c3bc
GM		 2704;; External.
2705(declare-function w3-region "ext:w3-display" (st nd))
2706
23f87bed
MB		 2707(defun gnus-article-wash-html-with-w3 ()
2708 "Wash the current buffer with w3."
2709 (mm-setup-w3)
2710 (let ((w3-strict-width (window-width))
2711 (url-standalone-mode t)
2712 (url-gateway-unplugged t)
2713 (w3-honor-stylesheets nil))
2714 (condition-case ()
2715 (w3-region (point-min) (point-max))
2716 (error))))
2717
9640c3bc
GM		 2718;; External.
2719(declare-function w3m-region "ext:w3m" (start end &optional url charset))
2720
23f87bed
MB		 2721(defun gnus-article-wash-html-with-w3m ()
2722 "Wash the current buffer with emacs-w3m."
2723 (mm-setup-w3m)
7dafe00b
MB		 2724 (let ((w3m-safe-url-regexp mm-w3m-safe-url-regexp)
2725 w3m-force-redisplay)
2726 (w3m-region (point-min) (point-max)))
2727 (when (and mm-inline-text-html-with-w3m-keymap
2728 (boundp 'w3m-minor-mode-map)
2729 w3m-minor-mode-map)
2730 (add-text-properties
2731 (point-min) (point-max)
2732 (list 'keymap w3m-minor-mode-map
2733 ;; Put the mark meaning this part was rendered by emacs-w3m.
2734 'mm-inline-text-html-with-w3m t))))
16409b0b 2735
9efa445f 2736(defvar charset) ;; Bound by `article-wash-html'.
73043f7d
MB		 2737
2738(defun gnus-article-wash-html-with-w3m-standalone ()
2739 "Wash the current buffer with w3m."
7347faa8
MB		 2740 (if (mm-w3m-standalone-supports-m17n-p)
2741 (progn
2742 (unless (mm-coding-system-p charset) ;; Bound by `article-wash-html'.
2743 ;; The default.
2744 (setq charset 'iso-8859-1))
2745 (let ((coding-system-for-write charset)
2746 (coding-system-for-read charset))
2747 (call-process-region
2748 (point-min) (point-max)
2749 "w3m" t t nil "-dump" "-T" "text/html"
2750 "-I" (symbol-name charset) "-O" (symbol-name charset))))
2751 (mm-inline-wash-with-stdin nil "w3m" "-dump" "-T" "text/html")))
73043f7d 2752
01c52d31
MB		 2753(defvar gnus-article-browse-html-temp-list nil
2754 "List of temporary files created by `gnus-article-browse-html-parts'.
2755Internal variable.")
2756
2757(defcustom gnus-article-browse-delete-temp 'ask
2758 "What to do with temporary files from `gnus-article-browse-html-parts'.
2759If nil, don't delete temporary files. If it is t, delete them on
2760exit from the summary buffer. If it is the symbol `file', query
2761on each file, if it is `ask' ask once when exiting from the
2762summary buffer."
2763 :group 'gnus-article
330f707b 2764 :version "23.1" ;; No Gnus
01c52d31
MB		 2765 :type '(choice (const :tag "Don't delete" nil)
2766 (const :tag "Don't ask" t)
2767 (const :tag "Ask" ask)
2768 (const :tag "Ask for each file" file)))
2769
2770;; Cf. mm-postponed-undisplay-list / mm-destroy-postponed-undisplay-list.
2771
2772(defun gnus-article-browse-delete-temp-files (&optional how)
2773 "Delete temp-files created by `gnus-article-browse-html-parts'."
2774 (when (and gnus-article-browse-html-temp-list
2775 (or how
2776 (setq how gnus-article-browse-delete-temp)))
2777 (when (and (eq how 'ask)
bbbe940b
MB		 2778 (gnus-y-or-n-p (format
2779 "Delete all %s temporary HTML file(s)? "
2780 (length gnus-article-browse-html-temp-list)))
01c52d31
MB		 2781 (setq how t)))
2782 (dolist (file gnus-article-browse-html-temp-list)
2783 (when (and (file-exists-p file)
2784 (or (eq how t)
2785 ;; `how' is neither `nil', `ask' nor `t' (i.e. `file'):
2786 (gnus-y-or-n-p
2787 (format "Delete temporary HTML file `%s'? " file))))
2788 (delete-file file)))
2789 ;; Also remove file from the list when not deleted or if file doesn't
2790 ;; exist anymore.
2791 (setq gnus-article-browse-html-temp-list nil))
2792 gnus-article-browse-html-temp-list)
2793
87035689 2794(defun gnus-article-browse-html-parts (list &optional header)
01c52d31 2795 "View all \"text/html\" parts from LIST.
87035689
MB		 2796Recurse into multiparts. The optional HEADER that should be a decoded
2797message header will be added to the bodies of the \"text/html\" parts."
01c52d31 2798 ;; Internal function used by `gnus-article-browse-html-article'.
bbbe940b 2799 (let (type file charset tmp-file showed)
01c52d31
MB		 2800 ;; Find and show the html-parts.
2801 (dolist (handle list)
2802 ;; If HTML, show it:
bbbe940b
MB		 2803 (cond ((not (listp handle)))
2804 ((or (equal (car (setq type (mm-handle-type handle))) "text/html")
2805 (and (equal (car type) "message/external-body")
87035689
MB		 2806 (or header
2807 (setq file (or (mail-content-type-get type 'name)
2808 (mail-content-type-get
2809 (mm-handle-disposition handle)
2810 'filename))))
bbbe940b
MB		 2811 (or (mm-handle-cache handle)
2812 (condition-case code
2813 (progn (mm-extern-cache-contents handle) t)
2814 (error
2815 (gnus-message 3 "%s" (error-message-string code))
2816 (when (>= gnus-verbose 3) (sit-for 2))
2817 nil)))
2818 (progn
2819 (setq handle (mm-handle-cache handle)
2820 type (mm-handle-type handle))
2821 (equal (car type) "text/html"))))
2822 (when (or (setq charset (mail-content-type-get type 'charset))
87035689 2823 header
bbbe940b
MB		 2824 (not file))
2825 (setq tmp-file (mm-make-temp-file
2826 ;; Do we need to care for 8.3 filenames?
2827 "mm-" nil ".html")))
87035689
MB		 2828 ;; Add a meta html tag to specify charset and a header.
2829 (cond
2830 (header
2831 (let (title eheader body hcharset coding)
2832 (with-temp-buffer
2833 (mm-enable-multibyte)
2834 (setq case-fold-search t)
2835 (insert header "\n")
2836 (setq title (message-fetch-field "subject"))
2837 (goto-char (point-min))
2838 (while (re-search-forward "\\(<\\)\\|\\(>\\)\\|&" nil t)
2839 (replace-match (cond ((match-beginning 1) "&lt;")
2840 ((match-beginning 2) "&gt;")
2841 (t "&amp;"))))
2842 (goto-char (point-min))
2843 (insert "<pre>\n")
2844 (goto-char (point-max))
2845 (insert "</pre>\n<hr>\n")
2846 ;; We have to examine charset one by one since
2847 ;; charset specified in parts might be different.
2848 (if (eq charset 'gnus-decoded)
2849 (setq charset 'utf-8
2850 eheader (mm-encode-coding-string (buffer-string)
2851 charset)
2852 title (when title
2853 (mm-encode-coding-string title charset))
2854 body (mm-encode-coding-string (mm-get-part handle)
2855 charset))
2856 (setq hcharset (mm-find-mime-charset-region (point-min)
2857 (point-max)))
2858 (cond ((= (length hcharset) 1)
2859 (setq hcharset (car hcharset)
2860 coding (mm-charset-to-coding-system
2861 hcharset)))
2862 ((> (length hcharset) 1)
2863 (setq hcharset 'utf-8
2864 coding hcharset)))
2865 (if coding
2866 (if charset
2867 (progn
2868 (setq body
2869 (mm-charset-to-coding-system charset))
2870 (if (eq coding body)
2871 (setq eheader (mm-encode-coding-string
2872 (buffer-string) coding)
2873 title (when title
2874 (mm-encode-coding-string
2875 title coding))
2876 body (mm-get-part handle))
2877 (setq charset 'utf-8
2878 eheader (mm-encode-coding-string
2879 (buffer-string) charset)
2880 title (when title
2881 (mm-encode-coding-string
2882 title charset))
2883 body (mm-encode-coding-string
2884 (mm-decode-coding-string
2885 (mm-get-part handle) body)
2886 charset))))
2887 (setq charset hcharset
2888 eheader (mm-encode-coding-string
2889 (buffer-string) coding)
2890 title (when title
2891 (mm-encode-coding-string
2892 title coding))
2893 body (mm-get-part handle)))
2894 (setq eheader (mm-string-as-unibyte (buffer-string))
2895 body (mm-get-part handle))))
2896 (erase-buffer)
2897 (mm-disable-multibyte)
2898 (insert body)
2899 (when charset
2900 (mm-add-meta-html-tag handle charset))
2901 (when title
2902 (goto-char (point-min))
2903 (unless (search-forward "<title>" nil t)
2904 (re-search-forward "<head>\\s-*" nil t)
2905 (insert "<title>" title "</title>\n")))
2906 (goto-char (point-min))
2907 (or (re-search-forward
2908 "<body\\(?:\\s-+[^>]+\\|\\s-*\\)>\\s-*" nil t)
2909 (re-search-forward
2910 "</head\\(?:\\s-+[^>]+\\|\\s-*\\)>\\s-*" nil t))
2911 (insert eheader)
2912 (mm-write-region (point-min) (point-max)
2913 tmp-file nil nil nil 'binary t))))
2914 (charset
2915 (mm-with-unibyte-buffer
2916 (insert (if (eq charset 'gnus-decoded)
2917 (mm-encode-coding-string
2918 (mm-get-part handle)
2919 (setq charset 'utf-8))
2920 (mm-get-part handle)))
2921 (if (or (mm-add-meta-html-tag handle charset)
2922 (not file))
2923 (mm-write-region (point-min) (point-max)
2924 tmp-file nil nil nil 'binary t)
2925 (setq tmp-file nil))))
2926 (tmp-file
2927 (mm-save-part-to-file handle tmp-file)))
bbbe940b
MB		 2928 (when tmp-file
2929 (add-to-list 'gnus-article-browse-html-temp-list tmp-file))
2930 (add-hook 'gnus-summary-prepare-exit-hook
2931 'gnus-article-browse-delete-temp-files)
2932 (add-hook 'gnus-exit-gnus-hook
2933 (lambda ()
2934 (gnus-article-browse-delete-temp-files t)))
2935 ;; FIXME: Warn if there's an <img> tag?
2936 (browse-url-of-file (or tmp-file (expand-file-name file)))
2937 (setq showed t))
2938 ;; If multipart, recurse
87035689
MB		 2939 ((equal (mm-handle-media-supertype handle) "multipart")
2940 (when (gnus-article-browse-html-parts handle header)
2941 (setq showed t)))
2942 ((equal (mm-handle-media-type handle) "message/rfc822")
2943 (mm-with-multibyte-buffer
2944 (mm-insert-part handle)
2945 (setq handle (mm-dissect-buffer t t))
2946 (when (and (bufferp (car handle))
2947 (stringp (car (mm-handle-type handle))))
2948 (setq handle (list handle)))
2949 (when header
2950 (article-decode-encoded-words)
2951 (let ((gnus-visible-headers
2952 (or (get 'gnus-visible-headers 'standard-value)
2953 gnus-visible-headers)))
2954 (article-hide-headers))
2955 (goto-char (point-min))
2956 (search-forward "\n\n" nil 'move)
2957 (skip-chars-backward "\t\n ")
2958 (setq header (buffer-substring (point-min) (point)))))
2959 (when (prog1
2960 (gnus-article-browse-html-parts handle header)
2961 (mm-destroy-parts handle))
2962 (setq showed t)))))
01c52d31
MB		 2963 showed))
2964
2965;; FIXME: Documentation in texi/gnus.texi missing.
87035689 2966(defun gnus-article-browse-html-article (&optional arg)
01c52d31 2967 "View \"text/html\" parts of the current article with a WWW browser.
87035689
MB		 2968The message header is added to the beginning of every html part unless
2969the prefix argument ARG is given.
01c52d31
MB		 2970
2971Warning: Spammers use links to images in HTML articles to verify
2972whether you have read the message. As
2973`gnus-article-browse-html-article' passes the unmodified HTML
2974content to the browser without eliminating these \"web bugs\" you
b890d447
MB		 2975should only use it for mails from trusted senders.
2976
2977If you alwasy want to display HTML part in the browser, set
2978`mm-text-html-renderer' to nil."
01c52d31 2979 ;; Cf. `mm-w3m-safe-url-regexp'
87035689
MB		 2980 (interactive "P")
2981 (if arg
2982 (gnus-summary-show-article)
2983 (let ((gnus-visible-headers (or (get 'gnus-visible-headers 'standard-value)
2984 gnus-visible-headers)))
2985 (gnus-summary-show-article)))
2986 (with-current-buffer gnus-article-buffer
2987 (let ((header (unless arg
2988 (save-restriction
2989 (widen)
2990 (buffer-substring-no-properties
2991 (goto-char (point-min))
2992 (if (search-forward "\n\n" nil t)
2993 (match-beginning 0)
2994 (goto-char (point-max))
2995 (skip-chars-backward "\t\n ")
2996 (point))))))
2997 parts)
2998 (set-buffer gnus-original-article-buffer)
2999 (setq parts (mm-dissect-buffer t t))
01c52d31
MB		 3000 ;; If singlepart, enforce a list.
3001 (when (and (bufferp (car parts))
3002 (stringp (car (mm-handle-type parts))))
3003 (setq parts (list parts)))
3004 ;; Process the list
87035689 3005 (unless (gnus-article-browse-html-parts parts header)
01c52d31 3006 (gnus-error 3 "Mail doesn't contain a \"text/html\" part!"))
87035689
MB		 3007 (mm-destroy-parts parts)
3008 (unless arg
3009 (gnus-summary-show-article)))))
01c52d31 3010
16409b0b
GM		 3011(defun article-hide-list-identifiers ()
3012 "Remove list identifies from the Subject header.
3013The `gnus-list-identifiers' variable specifies what to do."
3014 (interactive)
23f87bed
MB		 3015 (let ((inhibit-point-motion-hooks t)
3016 (regexp (if (consp gnus-list-identifiers)
3017 (mapconcat 'identity gnus-list-identifiers " *\\|")
3018 gnus-list-identifiers))
3019 (inhibit-read-only t))
3020 (when regexp
3021 (save-excursion
3022 (save-restriction
3023 (article-narrow-to-head)
3024 (goto-char (point-min))
3025 (while (re-search-forward
3026 (concat "^Subject: +\\(R[Ee]: +\\)*\\(" regexp " *\\)")
3027 nil t)
3028 (delete-region (match-beginning 2) (match-end 0))
3029 (beginning-of-line))
3030 (when (re-search-forward
3031 "^Subject: +\\(\\(R[Ee]: +\\)+\\)R[Ee]: +" nil t)
3032 (delete-region (match-beginning 1) (match-end 1))))))))
eec82323
LMI		 3033
3034(defun article-hide-pem (&optional arg)
3035 "Toggle hiding of any PEM headers and signatures in the current article.
3036If given a negative prefix, always show; if given a positive prefix,
3037always hide."
3038 (interactive (gnus-article-hidden-arg))
3039 (unless (gnus-article-check-hidden-text 'pem arg)
3040 (save-excursion
23f87bed 3041 (let ((inhibit-read-only t) end)
eec82323 3042 (goto-char (point-min))
16409b0b
GM		 3043 ;; Hide the horrendously ugly "header".
3044 (when (and (search-forward
3045 "\n-----BEGIN PRIVACY-ENHANCED MESSAGE-----\n"
3046 nil t)
3047 (setq end (1+ (match-beginning 0))))
23f87bed 3048 (gnus-add-wash-type 'pem)
16409b0b
GM		 3049 (gnus-article-hide-text-type
3050 end
3051 (if (search-forward "\n\n" nil t)
3052 (match-end 0)
3053 (point-max))
3054 'pem)
3055 ;; Hide the trailer as well
3056 (when (search-forward "\n-----END PRIVACY-ENHANCED MESSAGE-----\n"
3057 nil t)
3058 (gnus-article-hide-text-type
3059 (match-beginning 0) (match-end 0) 'pem)))))))
3060
3061(defun article-strip-banner ()
23f87bed
MB		 3062 "Strip the banners specified by the `banner' group parameter and by
3063`gnus-article-address-banner-alist'."
16409b0b 3064 (interactive)
23f87bed
MB		 3065 (save-excursion
3066 (save-restriction
3067 (let ((inhibit-point-motion-hooks t))
3068 (when (gnus-parameter-banner gnus-newsgroup-name)
3069 (article-really-strip-banner
3070 (gnus-parameter-banner gnus-newsgroup-name)))
3071 (when gnus-article-address-banner-alist
cf5a5c38
MB		 3072 ;; Note that the From header is decoded here, so it is
3073 ;; required that the *-extract-address-components function
3074 ;; supports non-ASCII text.
d71c0855
MB		 3075 (let ((from (save-restriction
3076 (widen)
3077 (article-narrow-to-head)
3078 (mail-fetch-field "from"))))
3079 (when (and from
3080 (setq from
3081 (cadr (funcall gnus-extract-address-components
3082 from))))
3083 (catch 'found
3084 (dolist (pair gnus-article-address-banner-alist)
3085 (when (string-match (car pair) from)
3086 (throw 'found
3087 (article-really-strip-banner (cdr pair)))))))))))))
23f87bed
MB		 3088
3089(defun article-really-strip-banner (banner)
3090 "Strip the banner specified by the argument."
16409b0b
GM		 3091 (save-excursion
3092 (save-restriction
3093 (let ((inhibit-point-motion-hooks t)
16409b0b 3094 (gnus-signature-limit nil)
23f87bed
MB		 3095 (inhibit-read-only t))
3096 (article-goto-body)
3097 (cond
3098 ((eq banner 'signature)
3099 (when (gnus-article-narrow-to-signature)
3100 (widen)
3101 (forward-line -1)
3102 (delete-region (point) (point-max))))
3103 ((symbolp banner)
3104 (if (setq banner (cdr (assq banner gnus-article-banner-alist)))
3105 (while (re-search-forward banner nil t)
3106 (delete-region (match-beginning 0) (match-end 0)))))
3107 ((stringp banner)
3108 (while (re-search-forward banner nil t)
3109 (delete-region (match-beginning 0) (match-end 0)))))))))
16409b0b
GM		 3110
3111(defun article-babel ()
3112 "Translate article using an online translation service."
3113 (interactive)
3114 (require 'babel)
01c52d31 3115 (gnus-with-article-buffer
16409b0b 3116 (when (article-goto-body)
01c52d31 3117 (let* ((start (point))
16409b0b
GM		 3118 (end (point-max))
3119 (orig (buffer-substring start end))
23f87bed 3120 (trans (babel-as-string orig)))
16409b0b
GM		 3121 (save-restriction
3122 (narrow-to-region start end)
3123 (delete-region start end)
23f87bed 3124 (insert trans))))))
eec82323
LMI		 3125
3126(defun article-hide-signature (&optional arg)
3127 "Hide the signature in the current article.
3128If given a negative prefix, always show; if given a positive prefix,
3129always hide."
3130 (interactive (gnus-article-hidden-arg))
3131 (unless (gnus-article-check-hidden-text 'signature arg)
3132 (save-excursion
3133 (save-restriction
4e7d0221 3134 (let ((inhibit-read-only t))
eec82323
LMI		 3135 (when (gnus-article-narrow-to-signature)
3136 (gnus-article-hide-text-type
23f87bed
MB		 3137 (point-min) (point-max) 'signature))))))
3138 (gnus-set-mode-line 'article))
eec82323 3139
16409b0b
GM		 3140(defun article-strip-headers-in-body ()
3141 "Strip offensive headers from bodies."
3142 (interactive)
3143 (save-excursion
3144 (article-goto-body)
3145 (let ((case-fold-search t))
3146 (when (looking-at "x-no-archive:")
3147 (gnus-delete-line)))))
3148
eec82323
LMI		 3149(defun article-strip-leading-blank-lines ()
3150 "Remove all blank lines from the beginning of the article."
3151 (interactive)
3152 (save-excursion
3153 (let ((inhibit-point-motion-hooks t)
23f87bed 3154 (inhibit-read-only t))
16409b0b 3155 (when (article-goto-body)
eec82323
LMI		 3156 (while (and (not (eobp))
3157 (looking-at "[ \t]*$"))
3158 (gnus-delete-line))))))
3159
16409b0b
GM		 3160(defun article-narrow-to-head ()
3161 "Narrow the buffer to the head of the message.
3162Point is left at the beginning of the narrowed-to region."
3163 (narrow-to-region
3164 (goto-char (point-min))
3165 (if (search-forward "\n\n" nil 1)
3166 (1- (point))
3167 (point-max)))
3168 (goto-char (point-min)))
3169
3170(defun article-goto-body ()
3171 "Place point at the start of the body."
3172 (goto-char (point-min))
3173 (cond
3174 ;; This variable is only bound when dealing with separate
3175 ;; MIME body parts.
3176 (article-goto-body-goes-to-point-min-p
3177 t)
3178 ((search-forward "\n\n" nil t)
3179 t)
3180 (t
3181 (goto-char (point-max))
3182 nil)))
3183
eec82323
LMI		 3184(defun article-strip-multiple-blank-lines ()
3185 "Replace consecutive blank lines with one empty line."
3186 (interactive)
3187 (save-excursion
3188 (let ((inhibit-point-motion-hooks t)
23f87bed 3189 (inhibit-read-only t))
eec82323 3190 ;; First make all blank lines empty.
16409b0b 3191 (article-goto-body)
eec82323 3192 (while (re-search-forward "^[ \t]+$" nil t)
16409b0b
GM		 3193 (unless (gnus-annotation-in-region-p
3194 (match-beginning 0) (match-end 0))
3195 (replace-match "" nil t)))
eec82323 3196 ;; Then replace multiple empty lines with a single empty line.
16409b0b 3197 (article-goto-body)
23f87bed 3198 (while (re-search-forward "\n\n\\(\n+\\)" nil t)
16409b0b
GM		 3199 (unless (gnus-annotation-in-region-p
3200 (match-beginning 0) (match-end 0))
23f87bed 3201 (delete-region (match-beginning 1) (match-end 1)))))))
eec82323
LMI		 3202
3203(defun article-strip-leading-space ()
3204 "Remove all white space from the beginning of the lines in the article."
3205 (interactive)
3206 (save-excursion
3207 (let ((inhibit-point-motion-hooks t)
23f87bed 3208 (inhibit-read-only t))
16409b0b 3209 (article-goto-body)
eec82323
LMI		 3210 (while (re-search-forward "^[ \t]+" nil t)
3211 (replace-match "" t t)))))
3212
16409b0b
GM		 3213(defun article-strip-trailing-space ()
3214 "Remove all white space from the end of the lines in the article."
3215 (interactive)
3216 (save-excursion
3217 (let ((inhibit-point-motion-hooks t)
23f87bed 3218 (inhibit-read-only t))
16409b0b
GM		 3219 (article-goto-body)
3220 (while (re-search-forward "[ \t]+$" nil t)
3221 (replace-match "" t t)))))
3222
eec82323
LMI		 3223(defun article-strip-blank-lines ()
3224 "Strip leading, trailing and multiple blank lines."
3225 (interactive)
3226 (article-strip-leading-blank-lines)
3227 (article-remove-trailing-blank-lines)
3228 (article-strip-multiple-blank-lines))
3229
6748645f
LMI		 3230(defun article-strip-all-blank-lines ()
3231 "Strip all blank lines."
3232 (interactive)
3233 (save-excursion
3234 (let ((inhibit-point-motion-hooks t)
23f87bed 3235 (inhibit-read-only t))
16409b0b 3236 (article-goto-body)
6748645f
LMI		 3237 (while (re-search-forward "^[ \t]*\n" nil t)
3238 (replace-match "" t t)))))
3239
eec82323
LMI		 3240(defun gnus-article-narrow-to-signature ()
3241 "Narrow to the signature; return t if a signature is found, else nil."
6748645f 3242 (let ((inhibit-point-motion-hooks t))
6748645f
LMI		 3243 (when (gnus-article-search-signature)
3244 (forward-line 1)
3245 ;; Check whether we have some limits to what we consider
3246 ;; to be a signature.
3247 (let ((limits (if (listp gnus-signature-limit) gnus-signature-limit
3248 (list gnus-signature-limit)))
3249 limit limited)
3250 (while (setq limit (pop limits))
3251 (if (or (and (integerp limit)
3252 (< (- (point-max) (point)) limit))
3253 (and (floatp limit)
3254 (< (count-lines (point) (point-max)) limit))
23f87bed 3255 (and (functionp limit)
6748645f
LMI		 3256 (funcall limit))
3257 (and (stringp limit)
3258 (not (re-search-forward limit nil t))))
3259 () ; This limit did not succeed.
3260 (setq limited t
3261 limits nil)))
3262 (unless limited
3263 (narrow-to-region (point) (point-max))
3264 t)))))
eec82323
LMI		 3265
3266(defun gnus-article-search-signature ()
3267 "Search the current buffer for the signature separator.
3268Put point at the beginning of the signature separator."
3269 (let ((cur (point)))
3270 (goto-char (point-max))
3271 (if (if (stringp gnus-signature-separator)
3272 (re-search-backward gnus-signature-separator nil t)
3273 (let ((seps gnus-signature-separator))
3274 (while (and seps
3275 (not (re-search-backward (car seps) nil t)))
3276 (pop seps))
3277 seps))
3278 t
3279 (goto-char cur)
3280 nil)))
3281
eec82323
LMI		 3282(defun gnus-article-hidden-arg ()
3283 "Return the current prefix arg as a number, or 0 if no prefix."
3284 (list (if current-prefix-arg
3285 (prefix-numeric-value current-prefix-arg)
3286 0)))
3287
3288(defun gnus-article-check-hidden-text (type arg)
3289 "Return nil if hiding is necessary.
f0529b5b 3290Arg can be nil or a number. nil and positive means hide, negative
eec82323
LMI		 3291means show, 0 means toggle."
3292 (save-excursion
3293 (save-restriction
eec82323
LMI		 3294 (let ((hide (gnus-article-hidden-text-p type)))
3295 (cond
3296 ((or (null arg)
3297 (> arg 0))
3298 nil)
3299 ((< arg 0)
4481aa98
SZ		 3300 (gnus-article-show-hidden-text type)
3301 t)
eec82323
LMI		 3302 (t
3303 (if (eq hide 'hidden)
4481aa98
SZ		 3304 (progn
3305 (gnus-article-show-hidden-text type)
3306 t)
eec82323
LMI		 3307 nil)))))))
3308
3309(defun gnus-article-hidden-text-p (type)
3310 "Say whether the current buffer contains hidden text of type TYPE."
6748645f 3311 (let ((pos (text-property-any (point-min) (point-max) 'article-type type)))
eec82323 3312 (while (and pos
16409b0b
GM		 3313 (not (get-text-property pos 'invisible))
3314 (not (get-text-property pos 'dummy-invisible)))
eec82323
LMI		 3315 (setq pos
3316 (text-property-any (1+ pos) (point-max) 'article-type type)))
3317 (if pos
3318 'hidden
16409b0b 3319 nil)))
eec82323 3320
520aa572 3321(defun gnus-article-show-hidden-text (type &optional dummy)
eec82323 3322 "Show all hidden text of type TYPE.
520aa572 3323Originally it is hide instead of DUMMY."
4e7d0221 3324 (let ((inhibit-read-only t)
520aa572 3325 (inhibit-point-motion-hooks t))
a1506d29 3326 (gnus-remove-text-properties-when
520aa572 3327 'article-type type
a1506d29 3328 (point-min) (point-max)
520aa572 3329 (cons 'article-type (cons type
23f87bed
MB		 3330 gnus-hidden-properties)))
3331 (gnus-delete-wash-type type)))
eec82323
LMI		 3332
3333(defconst article-time-units
3334 `((year . ,(* 365.25 24 60 60))
3335 (week . ,(* 7 24 60 60))
3336 (day . ,(* 24 60 60))
3337 (hour . ,(* 60 60))
3338 (minute . 60)
3339 (second . 1))
3340 "Mapping from time units to seconds.")
3341
23f87bed
MB		 3342(defun gnus-article-forward-header ()
3343 "Move point to the start of the next header.
3344If the current header is a continuation header, this can be several
3345lines forward."
3346 (let ((ended nil))
3347 (while (not ended)
3348 (forward-line 1)
3349 (if (looking-at "[ \t]+[^ \t]")
3350 (forward-line 1)
3351 (setq ended t)))))
3352
31640842 3353(defun article-date-ut (&optional type highlight)
eec82323
LMI		 3354 "Convert DATE date to universal time in the current article.
3355If TYPE is `local', convert to local time; if it is `lapsed', output
16409b0b
GM		 3356how much time has lapsed since DATE. For `lapsed', the value of
3357`gnus-article-date-lapsed-new-header' says whether the \"X-Sent:\" header
3358should replace the \"Date:\" one, or should be added below it."
eec82323 3359 (interactive (list 'ut t))
31640842
MB		 3360 (let* ((tdate-regexp "^Date:[ \t]\\|^X-Sent:[ \t]")
3361 (date-regexp (cond ((not gnus-article-date-lapsed-new-header)
3362 tdate-regexp)
3363 ((eq type 'lapsed)
3364 "^X-Sent:[ \t]")
3365 (article-lapsed-timer
3366 "^Date:[ \t]")
3367 (t
3368 tdate-regexp)))
3369 (case-fold-search t)
3370 (inhibit-read-only t)
eec82323 3371 (inhibit-point-motion-hooks t)
31640842 3372 pos date bface eface)
16409b0b
GM		 3373 (save-excursion
3374 (save-restriction
31640842
MB		 3375 (widen)
3376 (goto-char (point-min))
3377 (while (or (setq date (get-text-property (setq pos (point))
3378 'original-date))
3379 (when (setq pos (next-single-property-change
3380 (point) 'original-date))
3381 (setq date (get-text-property pos 'original-date))
3382 t))
3383 (narrow-to-region pos (or (text-property-any pos (point-max)
3384 'original-date nil)
3385 (point-max)))
16409b0b 3386 (goto-char (point-min))
31640842 3387 (when (re-search-forward tdate-regexp nil t)
01c52d31
MB		 3388 (setq bface (get-text-property (point-at-bol) 'face)
3389 eface (get-text-property (1- (point-at-eol)) 'face)))
31640842
MB		 3390 (goto-char (point-min))
3391 (setq pos nil)
3392 ;; Delete any old Date headers.
3393 (while (re-search-forward date-regexp nil t)
3394 (if pos
01c52d31
MB		 3395 (delete-region (point-at-bol) (progn
3396 (gnus-article-forward-header)
3397 (point)))
3398 (delete-region (point-at-bol) (progn
3399 (gnus-article-forward-header)
3400 (forward-char -1)
3401 (point)))
31640842
MB		 3402 (setq pos (point))))
3403 (when (and (not pos)
3404 (re-search-forward tdate-regexp nil t))
3405 (forward-line 1))
3406 (gnus-goto-char pos)
3407 (insert (article-make-date-line date (or type 'ut)))
3408 (unless pos
3409 (insert "\n")
3410 (forward-line -1))
3411 ;; Do highlighting.
3412 (beginning-of-line)
3413 (when (looking-at "\\([^:]+\\): *\\(.*\\)$")
3414 (put-text-property (match-beginning 1) (1+ (match-end 1))
3415 'face bface)
3416 (put-text-property (match-beginning 2) (match-end 2)
3417 'face eface))
3418 (put-text-property (point-min) (1- (point-max)) 'original-date date)
3419 (goto-char (point-max))
3420 (widen))))))
eec82323
LMI		 3421
3422(defun article-make-date-line (date type)
3423 "Return a DATE line of TYPE."
23f87bed
MB		 3424 (unless (memq type '(local ut original user iso8601 lapsed english))
3425 (error "Unknown conversion type: %s" type))
3426 (condition-case ()
3427 (let ((time (date-to-time date)))
16409b0b 3428 (cond
23f87bed
MB		 3429 ;; Convert to the local timezone.
3430 ((eq type 'local)
01c52d31 3431 (concat "Date: " (message-make-date time)))
23f87bed
MB		 3432 ;; Convert to Universal Time.
3433 ((eq type 'ut)
3434 (concat "Date: "
01c52d31
MB		 3435 (substring
3436 (message-make-date
3437 (let* ((e (parse-time-string date))
3438 (tm (apply 'encode-time e))
3439 (ms (car tm))
3440 (ls (- (cadr tm) (car (current-time-zone time)))))
3441 (cond ((< ls 0) (list (1- ms) (+ ls 65536)))
3442 ((> ls 65535) (list (1+ ms) (- ls 65536)))
3443 (t (list ms ls)))))
3444 0 -5)
3445 "UT"))
23f87bed
MB		 3446 ;; Get the original date from the article.
3447 ((eq type 'original)
3448 (concat "Date: " (if (string-match "\n+$" date)
3449 (substring date 0 (match-beginning 0))
3450 date)))
3451 ;; Let the user define the format.
3452 ((eq type 'user)
3453 (let ((format (or (condition-case nil
3454 (with-current-buffer gnus-summary-buffer
3455 gnus-article-time-format)
3456 (error nil))
3457 gnus-article-time-format)))
3458 (if (functionp format)
3459 (funcall format time)
3460 (concat "Date: " (format-time-string format time)))))
3461 ;; ISO 8601.
3462 ((eq type 'iso8601)
3463 (let ((tz (car (current-time-zone time))))
3464 (concat
3465 "Date: "
3466 (format-time-string "%Y%m%dT%H%M%S" time)
3467 (format "%s%02d%02d"
3468 (if (> tz 0) "+" "-") (/ (abs tz) 3600)
3469 (/ (% (abs tz) 3600) 60)))))
3470 ;; Do an X-Sent lapsed format.
3471 ((eq type 'lapsed)
3472 ;; If the date is seriously mangled, the timezone functions are
3473 ;; liable to bug out, so we ignore all errors.
3474 (let* ((now (current-time))
3475 (real-time (subtract-time now time))
3476 (real-sec (and real-time
3477 (+ (* (float (car real-time)) 65536)
3478 (cadr real-time))))
3479 (sec (and real-time (abs real-sec)))
3480 num prev)
3481 (cond
3482 ((null real-time)
3483 "X-Sent: Unknown")
3484 ((zerop sec)
3485 "X-Sent: Now")
3486 (t
3487 (concat
3488 "X-Sent: "
3489 ;; This is a bit convoluted, but basically we go
3490 ;; through the time units for years, weeks, etc,
3491 ;; and divide things to see whether that results
3492 ;; in positive answers.
3493 (mapconcat
3494 (lambda (unit)
3495 (if (zerop (setq num (ffloor (/ sec (cdr unit)))))
3496 ;; The (remaining) seconds are too few to
3497 ;; be divided into this time unit.
3498 ""
3499 ;; It's big enough, so we output it.
3500 (setq sec (- sec (* num (cdr unit))))
3501 (prog1
3502 (concat (if prev ", " "") (int-to-string
3503 (floor num))
3504 " " (symbol-name (car unit))
3505 (if (> num 1) "s" ""))
3506 (setq prev t))))
3507 article-time-units "")
3508 ;; If dates are odd, then it might appear like the
3509 ;; article was sent in the future.
3510 (if (> real-sec 0)
3511 " ago"
3512 " in the future"))))))
3513 ;; Display the date in proper English
3514 ((eq type 'english)
3515 (let ((dtime (decode-time time)))
3516 (concat
3517 "Date: the "
3518 (number-to-string (nth 3 dtime))
3519 (let ((digit (% (nth 3 dtime) 10)))
3520 (cond
3521 ((memq (nth 3 dtime) '(11 12 13)) "th")
3522 ((= digit 1) "st")
3523 ((= digit 2) "nd")
3524 ((= digit 3) "rd")
3525 (t "th")))
3526 " of "
3527 (nth (1- (nth 4 dtime)) gnus-english-month-names)
3528 " "
3529 (number-to-string (nth 5 dtime))
3530 " at "
3531 (format "%02d" (nth 2 dtime))
3532 ":"
3533 (format "%02d" (nth 1 dtime)))))))
3534 (error
a601fb74 3535 (format "Date: %s (from Gnus)" date))))
eec82323
LMI		 3536
3537(defun article-date-local (&optional highlight)
3538 "Convert the current article date to the local timezone."
3539 (interactive (list t))
3540 (article-date-ut 'local highlight))
3541
23f87bed
MB		 3542(defun article-date-english (&optional highlight)
3543 "Convert the current article date to something that is proper English."
3544 (interactive (list t))
3545 (article-date-ut 'english highlight))
3546
eec82323
LMI		 3547(defun article-date-original (&optional highlight)
3548 "Convert the current article date to what it was originally.
3549This is only useful if you have used some other date conversion
3550function and want to see what the date was before converting."
3551 (interactive (list t))
3552 (article-date-ut 'original highlight))
3553
3554(defun article-date-lapsed (&optional highlight)
3555 "Convert the current article date to time lapsed since it was sent."
3556 (interactive (list t))
3557 (article-date-ut 'lapsed highlight))
3558
6748645f
LMI		 3559(defun article-update-date-lapsed ()
3560 "Function to be run from a timer to update the lapsed time line."
e0a8aa09
LT		 3561 (save-match-data
3562 (let (deactivate-mark)
3563 (save-excursion
3564 (ignore-errors
3565 (walk-windows
3566 (lambda (w)
3567 (set-buffer (window-buffer w))
3568 (when (eq major-mode 'gnus-article-mode)
3569 (let ((mark (point-marker)))
3570 (goto-char (point-min))
3571 (when (re-search-forward "^X-Sent:" nil t)
3572 (article-date-lapsed t))
3573 (goto-char (marker-position mark))
3574 (move-marker mark nil))))
3575 nil 'visible))))))
6748645f
LMI		 3576
3577(defun gnus-start-date-timer (&optional n)
3578 "Start a timer to update the X-Sent header in the article buffers.
3579The numerical prefix says how frequently (in seconds) the function
3580is to run."
3581 (interactive "p")
3582 (unless n
3583 (setq n 1))
3584 (gnus-stop-date-timer)
3585 (setq article-lapsed-timer
01c52d31 3586 (run-at-time 1 n 'article-update-date-lapsed)))
6748645f
LMI		 3587
3588(defun gnus-stop-date-timer ()
3589 "Stop the X-Sent timer."
3590 (interactive)
3591 (when article-lapsed-timer
3592 (nnheader-cancel-timer article-lapsed-timer)
3593 (setq article-lapsed-timer nil)))
3594
eec82323
LMI		 3595(defun article-date-user (&optional highlight)
3596 "Convert the current article date to the user-defined format.
3597This format is defined by the `gnus-article-time-format' variable."
3598 (interactive (list t))
3599 (article-date-ut 'user highlight))
3600
6748645f
LMI		 3601(defun article-date-iso8601 (&optional highlight)
3602 "Convert the current article date to ISO8601."
3603 (interactive (list t))
3604 (article-date-ut 'iso8601 highlight))
3605
31640842
MB		 3606(defmacro gnus-article-save-original-date (&rest forms)
3607 "Save the original date as a text property and evaluate FORMS."
3608 `(let* ((case-fold-search t)
3609 (start (progn
3610 (goto-char (point-min))
3611 (when (and (re-search-forward "^date:[\t\n ]+" nil t)
3612 (not (bolp)))
3613 (match-end 0))))
3614 (date (when (and start
01c52d31 3615 (re-search-forward "[\t ]*\n\\(?:[^\t ]\\|\\'\\)"
31640842
MB		 3616 nil t))
3617 (buffer-substring-no-properties start
3618 (match-beginning 0)))))
3619 (goto-char (point-max))
3620 (skip-chars-backward "\n")
3621 (put-text-property (point-min) (point) 'original-date date)
3622 ,@forms
3623 (goto-char (point-max))
3624 (skip-chars-backward "\n")
3625 (put-text-property (point-min) (point) 'original-date date)))
3626
23f87bed
MB		 3627;; (defun article-show-all ()
3628;; "Show all hidden text in the article buffer."
3629;; (interactive)
3630;; (save-excursion
3631;; (let ((inhibit-read-only t))
3632;; (gnus-article-unhide-text (point-min) (point-max)))))
3633
3634(defun article-remove-leading-whitespace ()
3635 "Remove excessive whitespace from all headers."
eec82323
LMI		 3636 (interactive)
3637 (save-excursion
23f87bed
MB		 3638 (save-restriction
3639 (let ((inhibit-read-only t))
3640 (article-narrow-to-head)
3641 (goto-char (point-min))
3642 (while (re-search-forward "^[^ :]+: \\([ \t]+\\)" nil t)
3643 (delete-region (match-beginning 1) (match-end 1)))))))
eec82323
LMI		 3644
3645(defun article-emphasize (&optional arg)
3646 "Emphasize text according to `gnus-emphasis-alist'."
3647 (interactive (gnus-article-hidden-arg))
3648 (unless (gnus-article-check-hidden-text 'emphasis arg)
3649 (save-excursion
a1506d29 3650 (let ((alist (or
16409b0b 3651 (condition-case nil
a1506d29
JB		 3652 (with-current-buffer gnus-summary-buffer
3653 gnus-article-emphasis-alist)
16409b0b
GM		 3654 (error))
3655 gnus-emphasis-alist))
4e7d0221 3656 (inhibit-read-only t)
eec82323
LMI		 3657 (props (append '(article-type emphasis)
3658 gnus-hidden-properties))
3659 regexp elem beg invisible visible face)
16409b0b 3660 (article-goto-body)
eec82323
LMI		 3661 (setq beg (point))
3662 (while (setq elem (pop alist))
3663 (goto-char beg)
3664 (setq regexp (car elem)
3665 invisible (nth 1 elem)
3666 visible (nth 2 elem)
3667 face (nth 3 elem))
3668 (while (re-search-forward regexp nil t)
23f87bed
MB		 3669 (when (and (match-beginning visible) (match-beginning invisible))
3670 (gnus-article-hide-text
3671 (match-beginning invisible) (match-end invisible) props)
3672 (gnus-article-unhide-text-type
3673 (match-beginning visible) (match-end visible) 'emphasis)
3674 (gnus-put-overlay-excluding-newlines
3675 (match-beginning visible) (match-end visible) 'face face)
3676 (gnus-add-wash-type 'emphasis)
3677 (goto-char (match-end invisible)))))))))
eec82323 3678
16409b0b
GM		 3679(defun gnus-article-setup-highlight-words (&optional highlight-words)
3680 "Setup newsgroup emphasis alist."
3681 (unless gnus-article-emphasis-alist
3682 (let ((name (and gnus-newsgroup-name
3683 (gnus-group-real-name gnus-newsgroup-name))))
3684 (make-local-variable 'gnus-article-emphasis-alist)
a1506d29
JB		 3685 (setq gnus-article-emphasis-alist
3686 (nconc
16409b0b
GM		 3687 (let ((alist gnus-group-highlight-words-alist) elem highlight)
3688 (while (setq elem (pop alist))
3689 (when (and name (string-match (car elem) name))
3690 (setq alist nil
3691 highlight (copy-sequence (cdr elem)))))
3692 highlight)
3693 (copy-sequence highlight-words)
3694 (if gnus-newsgroup-name
a1506d29 3695 (copy-sequence (gnus-group-find-parameter
16409b0b
GM		 3696 gnus-newsgroup-name 'highlight-words t)))
3697 gnus-emphasis-alist)))))
3698
9efa445f
DN		 3699(defvar gnus-summary-article-menu)
3700(defvar gnus-summary-post-menu)
eec82323
LMI		 3701
3702;;; Saving functions.
3703
3704(defun gnus-article-save (save-buffer file &optional num)
3705 "Save the currently selected article."
26c9afc3
MB		 3706 (when (or (get gnus-default-article-saver :headers)
3707 (not gnus-save-all-headers))
3708 ;; Remove headers according to `gnus-saved-headers' or the value
3709 ;; of the `:headers' property that the saver function might have.
eec82323 3710 (let ((gnus-visible-headers
26c9afc3
MB		 3711 (or (symbol-value (get gnus-default-article-saver :headers))
3712 gnus-saved-headers gnus-visible-headers))
eec82323 3713 (gnus-article-buffer save-buffer))
80de1778 3714 (with-current-buffer save-buffer
6748645f 3715 (article-hide-headers 1 t))))
eec82323
LMI		 3716 (save-window-excursion
3717 (if (not gnus-default-article-saver)
a8151ef7 3718 (error "No default saver is defined")
eec82323 3719 ;; !!! Magic! The saving functions all save
16409b0b 3720 ;; `gnus-save-article-buffer' (or so they think), but we
eec82323
LMI		 3721 ;; bind that variable to our save-buffer.
3722 (set-buffer gnus-article-buffer)
3723 (let* ((gnus-save-article-buffer save-buffer)
3724 (filename
3725 (cond
3726 ((not gnus-prompt-before-saving) 'default)
3727 ((eq gnus-prompt-before-saving 'always) nil)
3728 (t file)))
3729 (gnus-number-of-articles-to-be-saved
3730 (when (eq gnus-prompt-before-saving t)
3731 num))) ; Magic
6748645f 3732 (set-buffer gnus-article-current-summary)
eec82323
LMI		 3733 (funcall gnus-default-article-saver filename)))))
3734
3735(defun gnus-read-save-file-name (prompt &optional filename
26c9afc3
MB		 3736 function group headers variable
3737 dir-var)
eec82323
LMI		 3738 (let ((default-name
3739 (funcall function group headers (symbol-value variable)))
3740 result)
4325195c 3741 (setq result
a1506d29 3742 (expand-file-name
4325195c
DL		 3743 (cond
3744 ((eq filename 'default)
3745 default-name)
3746 ((eq filename t)
3747 default-name)
3748 (filename filename)
3749 (t
26c9afc3
MB		 3750 (when (symbol-value dir-var)
3751 (setq default-name (expand-file-name
3752 (file-name-nondirectory default-name)
3753 (symbol-value dir-var))))
4325195c
DL		 3754 (let* ((split-name (gnus-get-split-value gnus-split-methods))
3755 (prompt
3756 (format prompt
3757 (if (and gnus-number-of-articles-to-be-saved
3758 (> gnus-number-of-articles-to-be-saved 1))
3759 (format "these %d articles"
3760 gnus-number-of-articles-to-be-saved)
3761 "this article")))
3762 (file
3763 ;; Let the split methods have their say.
3764 (cond
3765 ;; No split name was found.
3766 ((null split-name)
3767 (read-file-name
3768 (concat prompt " (default "
81df110a 3769 (file-name-nondirectory default-name) "): ")
4325195c
DL		 3770 (file-name-directory default-name)
3771 default-name))
3772 ;; A single group name is returned.
3773 ((stringp split-name)
3774 (setq default-name
3775 (funcall function split-name headers
3776 (symbol-value variable)))
3777 (read-file-name
3778 (concat prompt " (default "
81df110a 3779 (file-name-nondirectory default-name) "): ")
4325195c
DL		 3780 (file-name-directory default-name)
3781 default-name))
3782 ;; A single split name was found
3783 ((= 1 (length split-name))
3784 (let* ((name (expand-file-name
23f87bed
MB		 3785 (car split-name)
3786 gnus-article-save-directory))
4325195c
DL		 3787 (dir (cond ((file-directory-p name)
3788 (file-name-as-directory name))
3789 ((file-exists-p name) name)
3790 (t gnus-article-save-directory))))
3791 (read-file-name
81df110a 3792 (concat prompt " (default " name "): ")
4325195c
DL		 3793 dir name)))
3794 ;; A list of splits was found.
3795 (t
3796 (setq split-name (nreverse split-name))
3797 (let (result)
3798 (let ((file-name-history
3799 (nconc split-name file-name-history)))
3800 (setq result
3801 (expand-file-name
3802 (read-file-name
81df110a 3803 (concat prompt " (`M-p' for defaults): ")
4325195c
DL		 3804 gnus-article-save-directory
3805 (car split-name))
3806 gnus-article-save-directory)))
3807 (car (push result file-name-history)))))))
3808 ;; Create the directory.
3809 (gnus-make-directory (file-name-directory file))
23f87bed 3810 ;; If we have read a directory, we append the default file name.
4325195c 3811 (when (file-directory-p file)
23f87bed
MB		 3812 (setq file (expand-file-name (file-name-nondirectory
3813 default-name)
4325195c
DL		 3814 (file-name-as-directory file))))
3815 ;; Possibly translate some characters.
3816 (nnheader-translate-file-chars file))))))
eec82323 3817 (gnus-make-directory (file-name-directory result))
26c9afc3
MB		 3818 (when variable
3819 (set variable result))
3820 (when dir-var
3821 (set dir-var (file-name-directory result)))
3822 result))
eec82323
LMI		 3823
3824(defun gnus-article-archive-name (group)
3825 "Return the first instance of an \"Archive-name\" in the current buffer."
3826 (let ((case-fold-search t))
3827 (when (re-search-forward "archive-name: *\\([^ \n\t]+\\)[ \t]*$" nil t)
3828 (nnheader-concat gnus-article-save-directory
3829 (match-string 1)))))
3830
3831(defun gnus-article-nndoc-name (group)
3832 "If GROUP is an nndoc group, return the name of the parent group."
3833 (when (eq (car (gnus-find-method-for-group group)) 'nndoc)
3834 (gnus-group-get-parameter group 'save-article-group)))
3835
3836(defun gnus-summary-save-in-rmail (&optional filename)
3837 "Append this article to Rmail file.
3838Optional argument FILENAME specifies file name.
3839Directory to save to is default to `gnus-article-save-directory'."
eec82323 3840 (setq filename (gnus-read-save-file-name
81df110a 3841 "Save %s in rmail file" filename
eec82323
LMI		 3842 gnus-rmail-save-name gnus-newsgroup-name
3843 gnus-current-headers 'gnus-newsgroup-last-rmail))
3844 (gnus-eval-in-buffer-window gnus-save-article-buffer
3845 (save-excursion
3846 (save-restriction
3847 (widen)
6748645f
LMI		 3848 (gnus-output-to-rmail filename))))
3849 filename)
eec82323
LMI		 3850
3851(defun gnus-summary-save-in-mail (&optional filename)
3852 "Append this article to Unix mail file.
3853Optional argument FILENAME specifies file name.
3854Directory to save to is default to `gnus-article-save-directory'."
eec82323 3855 (setq filename (gnus-read-save-file-name
81df110a 3856 "Save %s in Unix mail file" filename
eec82323
LMI		 3857 gnus-mail-save-name gnus-newsgroup-name
3858 gnus-current-headers 'gnus-newsgroup-last-mail))
3859 (gnus-eval-in-buffer-window gnus-save-article-buffer
3860 (save-excursion
3861 (save-restriction
3862 (widen)
3863 (if (and (file-readable-p filename)
23f87bed 3864 (file-regular-p filename)
eec82323 3865 (mail-file-babyl-p filename))
16409b0b 3866 (rmail-output-to-rmail-file filename t)
6748645f
LMI		 3867 (gnus-output-to-mail filename)))))
3868 filename)
eec82323 3869
26c9afc3
MB		 3870(put 'gnus-summary-save-in-file :decode t)
3871(put 'gnus-summary-save-in-file :headers 'gnus-saved-headers)
eec82323
LMI		 3872(defun gnus-summary-save-in-file (&optional filename overwrite)
3873 "Append this article to file.
3874Optional argument FILENAME specifies file name.
3875Directory to save to is default to `gnus-article-save-directory'."
eec82323 3876 (setq filename (gnus-read-save-file-name
81df110a 3877 "Save %s in file" filename
eec82323
LMI		 3878 gnus-file-save-name gnus-newsgroup-name
3879 gnus-current-headers 'gnus-newsgroup-last-file))
3880 (gnus-eval-in-buffer-window gnus-save-article-buffer
3881 (save-excursion
3882 (save-restriction
3883 (widen)
3884 (when (and overwrite
3885 (file-exists-p filename))
3886 (delete-file filename))
6748645f
LMI		 3887 (gnus-output-to-file filename))))
3888 filename)
eec82323 3889
26c9afc3
MB		 3890(put 'gnus-summary-write-to-file :decode t)
3891(put 'gnus-summary-write-to-file :function 'gnus-summary-save-in-file)
3892(put 'gnus-summary-write-to-file :headers 'gnus-saved-headers)
eec82323 3893(defun gnus-summary-write-to-file (&optional filename)
23f87bed 3894 "Write this article to a file, overwriting it if the file exists.
eec82323
LMI		 3895Optional argument FILENAME specifies file name.
3896The directory to save in defaults to `gnus-article-save-directory'."
26c9afc3
MB		 3897 (setq filename (gnus-read-save-file-name
3898 "Save %s in file" filename
3899 gnus-file-save-name gnus-newsgroup-name
3900 gnus-current-headers nil 'gnus-newsgroup-last-directory))
3901 (gnus-summary-save-in-file filename t))
eec82323 3902
26c9afc3
MB		 3903(put 'gnus-summary-save-body-in-file :decode t)
3904(defun gnus-summary-save-body-in-file (&optional filename overwrite)
eec82323
LMI		 3905 "Append this article body to a file.
3906Optional argument FILENAME specifies file name.
3907The directory to save in defaults to `gnus-article-save-directory'."
eec82323 3908 (setq filename (gnus-read-save-file-name
81df110a 3909 "Save %s body in file" filename
eec82323
LMI		 3910 gnus-file-save-name gnus-newsgroup-name
3911 gnus-current-headers 'gnus-newsgroup-last-file))
3912 (gnus-eval-in-buffer-window gnus-save-article-buffer
3913 (save-excursion
3914 (save-restriction
3915 (widen)
16409b0b 3916 (when (article-goto-body)
eec82323 3917 (narrow-to-region (point) (point-max)))
26c9afc3
MB		 3918 (when (and overwrite
3919 (file-exists-p filename))
3920 (delete-file filename))
6748645f
LMI		 3921 (gnus-output-to-file filename))))
3922 filename)
eec82323 3923
26c9afc3
MB		 3924(put 'gnus-summary-write-body-to-file :decode t)
3925(put 'gnus-summary-write-body-to-file
3926 :function 'gnus-summary-save-body-in-file)
3927(defun gnus-summary-write-body-to-file (&optional filename)
3928 "Write this article body to a file, overwriting it if the file exists.
3929Optional argument FILENAME specifies file name.
3930The directory to save in defaults to `gnus-article-save-directory'."
3931 (setq filename (gnus-read-save-file-name
3932 "Save %s body in file" filename
3933 gnus-file-save-name gnus-newsgroup-name
3934 gnus-current-headers nil 'gnus-newsgroup-last-directory))
3935 (gnus-summary-save-body-in-file filename t))
3936
eec82323
LMI		 3937(defun gnus-summary-save-in-pipe (&optional command)
3938 "Pipe this article to subprocess."
eec82323 3939 (setq command
16409b0b
GM		 3940 (cond ((and (eq command 'default)
3941 gnus-last-shell-command)
eec82323 3942 gnus-last-shell-command)
676a7cc9
SZ		 3943 ((stringp command)
3944 command)
eec82323
LMI		 3945 (t (read-string
3946 (format
3947 "Shell command on %s: "
3948 (if (and gnus-number-of-articles-to-be-saved
3949 (> gnus-number-of-articles-to-be-saved 1))
3950 (format "these %d articles"
3951 gnus-number-of-articles-to-be-saved)
3952 "this article"))
3953 gnus-last-shell-command))))
3954 (when (string-equal command "")
676a7cc9
SZ		 3955 (if gnus-last-shell-command
3956 (setq command gnus-last-shell-command)
715a2ca2 3957 (error "A command is required")))
eec82323
LMI		 3958 (gnus-eval-in-buffer-window gnus-article-buffer
3959 (save-restriction
3960 (widen)
3961 (shell-command-on-region (point-min) (point-max) command nil)))
3962 (setq gnus-last-shell-command command))
3963
23f87bed
MB		 3964(defun gnus-summary-pipe-to-muttprint (&optional command)
3965 "Pipe this article to muttprint."
01c52d31 3966 (setq command (read-string
23f87bed
MB		 3967 "Print using command: " gnus-summary-muttprint-program
3968 nil gnus-summary-muttprint-program))
3969 (gnus-summary-save-in-pipe command))
3970
eec82323
LMI		 3971;;; Article file names when saving.
3972
3973(defun gnus-capitalize-newsgroup (newsgroup)
3974 "Capitalize NEWSGROUP name."
3975 (when (not (zerop (length newsgroup)))
3976 (concat (char-to-string (upcase (aref newsgroup 0)))
3977 (substring newsgroup 1))))
3978
3979(defun gnus-Numeric-save-name (newsgroup headers &optional last-file)
3980 "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE.
3981If variable `gnus-use-long-file-name' is non-nil, it is ~/News/News.group/num.
3982Otherwise, it is like ~/News/news/group/num."
3983 (let ((default
3984 (expand-file-name
3985 (concat (if (gnus-use-long-file-name 'not-save)
3986 (gnus-capitalize-newsgroup newsgroup)
3987 (gnus-newsgroup-directory-form newsgroup))
3988 "/" (int-to-string (mail-header-number headers)))
3989 gnus-article-save-directory)))
3990 (if (and last-file
3991 (string-equal (file-name-directory default)
3992 (file-name-directory last-file))
3993 (string-match "^[0-9]+$" (file-name-nondirectory last-file)))
3994 default
3995 (or last-file default))))
3996
3997(defun gnus-numeric-save-name (newsgroup headers &optional last-file)
3998 "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE.
3999If variable `gnus-use-long-file-name' is non-nil, it is
2ff9f5b4 4000~/News/news.group/num. Otherwise, it is like ~/News/news/group/num."
eec82323
LMI		 4001 (let ((default
4002 (expand-file-name
4003 (concat (if (gnus-use-long-file-name 'not-save)
4004 newsgroup
4005 (gnus-newsgroup-directory-form newsgroup))
4006 "/" (int-to-string (mail-header-number headers)))
4007 gnus-article-save-directory)))
4008 (if (and last-file
4009 (string-equal (file-name-directory default)
4010 (file-name-directory last-file))
4011 (string-match "^[0-9]+$" (file-name-nondirectory last-file)))
4012 default
4013 (or last-file default))))
4014
eec82323
LMI		 4015(defun gnus-plain-save-name (newsgroup headers &optional last-file)
4016 "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE.
4017If variable `gnus-use-long-file-name' is non-nil, it is
4018~/News/news.group. Otherwise, it is like ~/News/news/group/news."
4019 (or last-file
4020 (expand-file-name
4021 (if (gnus-use-long-file-name 'not-save)
4022 newsgroup
23f87bed
MB		 4023 (file-relative-name
4024 (expand-file-name "news" (gnus-newsgroup-directory-form newsgroup))
4025 default-directory))
eec82323
LMI		 4026 gnus-article-save-directory)))
4027
23f87bed
MB		 4028(defun gnus-sender-save-name (newsgroup headers &optional last-file)
4029 "Generate file name from sender."
4030 (let ((from (mail-header-from headers)))
4031 (expand-file-name
4032 (if (and from (string-match "\\([^ <]+\\)@" from))
4033 (match-string 1 from)
4034 "nobody")
4035 gnus-article-save-directory)))
4036
4037(defun article-verify-x-pgp-sig ()
4038 "Verify X-PGP-Sig."
bbbe940b 4039 ;; <ftp://ftp.isc.org/pub/pgpcontrol/FORMAT>
23f87bed
MB		 4040 (interactive)
4041 (if (gnus-buffer-live-p gnus-original-article-buffer)
4042 (let ((sig (with-current-buffer gnus-original-article-buffer
4043 (gnus-fetch-field "X-PGP-Sig")))
4044 items info headers)
4045 (when (and sig
4046 mml2015-use
4047 (mml2015-clear-verify-function))
4048 (with-temp-buffer
4049 (insert-buffer-substring gnus-original-article-buffer)
4050 (setq items (split-string sig))
4051 (message-narrow-to-head)
4052 (let ((inhibit-point-motion-hooks t)
4053 (case-fold-search t))
4054 ;; Don't verify multiple headers.
4055 (setq headers (mapconcat (lambda (header)
4056 (concat header ": "
4057 (mail-fetch-field header)
4058 "\n"))
4059 (split-string (nth 1 items) ",") "")))
4060 (delete-region (point-min) (point-max))
4061 (insert "-----BEGIN PGP SIGNED MESSAGE-----\n\n")
4062 (insert "X-Signed-Headers: " (nth 1 items) "\n")
4063 (insert headers)
4064 (widen)
4065 (forward-line)
4066 (while (not (eobp))
4067 (if (looking-at "^-")
4068 (insert "- "))
4069 (forward-line))
4070 (insert "\n-----BEGIN PGP SIGNATURE-----\n")
4071 (insert "Version: " (car items) "\n\n")
4072 (insert (mapconcat 'identity (cddr items) "\n"))
4073 (insert "\n-----END PGP SIGNATURE-----\n")
4074 (let ((mm-security-handle (list (format "multipart/signed"))))
4075 (mml2015-clean-buffer)
4076 (let ((coding-system-for-write (or gnus-newsgroup-charset
4077 'iso-8859-1)))
4078 (funcall (mml2015-clear-verify-function)))
4079 (setq info
4080 (or (mm-handle-multipart-ctl-parameter
4081 mm-security-handle 'gnus-details)
4082 (mm-handle-multipart-ctl-parameter
4083 mm-security-handle 'gnus-info)))))
4084 (when info
4085 (let ((inhibit-read-only t) bface eface)
4086 (save-restriction
4087 (message-narrow-to-head)
4088 (goto-char (point-max))
4089 (forward-line -1)
01c52d31
MB		 4090 (setq bface (get-text-property (point-at-bol) 'face)
4091 eface (get-text-property (1- (point-at-eol)) 'face))
23f87bed
MB		 4092 (message-remove-header "X-Gnus-PGP-Verify")
4093 (if (re-search-forward "^X-PGP-Sig:" nil t)
4094 (forward-line)
4095 (goto-char (point-max)))
4096 (narrow-to-region (point) (point))
4097 (insert "X-Gnus-PGP-Verify: " info "\n")
4098 (goto-char (point-min))
4099 (forward-line)
4100 (while (not (eobp))
4101 (if (not (looking-at "^[ \t]"))
4102 (insert " "))
4103 (forward-line))
4104 ;; Do highlighting.
4105 (goto-char (point-min))
4106 (when (looking-at "\\([^:]+\\): *")
4107 (put-text-property (match-beginning 1) (1+ (match-end 1))
4108 'face bface)
4109 (put-text-property (match-end 0) (point-max)
4110 'face eface)))))))))
4111
4112(defun article-verify-cancel-lock ()
4113 "Verify Cancel-Lock header."
4114 (interactive)
4115 (if (gnus-buffer-live-p gnus-original-article-buffer)
4116 (canlock-verify gnus-original-article-buffer)))
4117
eec82323 4118(eval-and-compile
01c52d31 4119 (mapc
eec82323
LMI		 4120 (lambda (func)
4121 (let (afunc gfunc)
4122 (if (consp func)
4123 (setq afunc (car func)
4124 gfunc (cdr func))
4125 (setq afunc func
4126 gfunc (intern (format "gnus-%s" func))))
16409b0b 4127 (defalias gfunc
23f87bed 4128 (when (fboundp afunc)
16409b0b
GM		 4129 `(lambda (&optional interactive &rest args)
4130 ,(documentation afunc t)
4131 (interactive (list t))
80de1778 4132 (with-current-buffer gnus-article-buffer
16409b0b
GM		 4133 (if interactive
4134 (call-interactively ',afunc)
4135 (apply ',afunc args))))))))
eec82323 4136 '(article-hide-headers
23f87bed
MB		 4137 article-verify-x-pgp-sig
4138 article-verify-cancel-lock
eec82323
LMI		 4139 article-hide-boring-headers
4140 article-treat-overstrike
01c52d31 4141 article-treat-ansi-sequences
16409b0b
GM		 4142 article-fill-long-lines
4143 article-capitalize-sentences
eec82323 4144 article-remove-cr
23f87bed 4145 article-remove-leading-whitespace
eec82323 4146 article-display-x-face
23f87bed 4147 article-display-face
eec82323 4148 article-de-quoted-unreadable
16409b0b
GM		 4149 article-de-base64-unreadable
4150 article-decode-HZ
4151 article-wash-html
23f87bed 4152 article-unsplit-urls
16409b0b 4153 article-hide-list-identifiers
16409b0b
GM		 4154 article-strip-banner
4155 article-babel
eec82323
LMI		 4156 article-hide-pem
4157 article-hide-signature
16409b0b 4158 article-strip-headers-in-body
eec82323
LMI		 4159 article-remove-trailing-blank-lines
4160 article-strip-leading-blank-lines
4161 article-strip-multiple-blank-lines
4162 article-strip-leading-space
16409b0b 4163 article-strip-trailing-space
eec82323 4164 article-strip-blank-lines
6748645f 4165 article-strip-all-blank-lines
eec82323 4166 article-date-local
23f87bed 4167 article-date-english
6748645f 4168 article-date-iso8601
eec82323
LMI		 4169 article-date-original
4170 article-date-ut
16409b0b
GM		 4171 article-decode-mime-words
4172 article-decode-charset
4173 article-decode-encoded-words
eec82323
LMI		 4174 article-date-user
4175 article-date-lapsed
4176 article-emphasize
6748645f 4177 article-treat-dumbquotes
16409b0b 4178 article-normalize-headers
01c52d31 4179 ;;(article-show-all . gnus-article-show-all-headers)
23f87bed 4180 )))
eec82323
LMI		 4181\f
4182;;;
4183;;; Gnus article mode
4184;;;
4185
4186(put 'gnus-article-mode 'mode-class 'special)
4187
16409b0b
GM		 4188(set-keymap-parent gnus-article-mode-map widget-keymap)
4189
a8151ef7
LMI		 4190(gnus-define-keys gnus-article-mode-map
4191 " " gnus-article-goto-next-page
4192 "\177" gnus-article-goto-prev-page
4193 [delete] gnus-article-goto-prev-page
16409b0b 4194 [backspace] gnus-article-goto-prev-page
a8151ef7
LMI		 4195 "\C-c^" gnus-article-refer-article
4196 "h" gnus-article-show-summary
4197 "s" gnus-article-show-summary
4198 "\C-c\C-m" gnus-article-mail
4199 "?" gnus-article-describe-briefly
16409b0b 4200 "e" gnus-summary-edit-article
a8151ef7
LMI		 4201 "<" beginning-of-buffer
4202 ">" end-of-buffer
4203 "\C-c\C-i" gnus-info-find-node
4204 "\C-c\C-b" gnus-bug
23f87bed
MB		 4205 "R" gnus-article-reply-with-original
4206 "F" gnus-article-followup-with-original
520aa572
SZ		 4207 "\C-hk" gnus-article-describe-key
4208 "\C-hc" gnus-article-describe-key-briefly
0b6799c3 4209 "\C-hb" gnus-article-describe-bindings
a8151ef7
LMI		 4210
4211 "\C-d" gnus-article-read-summary-keys
4212 "\M-*" gnus-article-read-summary-keys
4213 "\M-#" gnus-article-read-summary-keys
4214 "\M-^" gnus-article-read-summary-keys
4215 "\M-g" gnus-article-read-summary-keys)
4216
4217(substitute-key-definition
4218 'undefined 'gnus-article-read-summary-keys gnus-article-mode-map)
eec82323 4219
95838435
MB		 4220(gnus-define-keys (gnus-article-send-map "S" gnus-article-mode-map)
4221 "W" gnus-article-wide-reply-with-original)
4222(if (featurep 'xemacs)
4223 (set-keymap-default-binding gnus-article-send-map
4224 'gnus-article-read-summary-send-keys)
4225 (define-key gnus-article-send-map [t] 'gnus-article-read-summary-send-keys))
4226
eec82323 4227(defun gnus-article-make-menu-bar ()
23f87bed
MB		 4228 (unless (boundp 'gnus-article-commands-menu)
4229 (gnus-summary-make-menu-bar))
eec82323
LMI		 4230 (gnus-turn-off-edit-menu 'article)
4231 (unless (boundp 'gnus-article-article-menu)
4232 (easy-menu-define
4233 gnus-article-article-menu gnus-article-mode-map ""
4234 '("Article"
4235 ["Scroll forwards" gnus-article-goto-next-page t]
4236 ["Scroll backwards" gnus-article-goto-prev-page t]
4237 ["Show summary" gnus-article-show-summary t]
4238 ["Fetch Message-ID at point" gnus-article-refer-article t]
6748645f
LMI		 4239 ["Mail to address at point" gnus-article-mail t]
4240 ["Send a bug report" gnus-bug t]))
eec82323
LMI		 4241
4242 (easy-menu-define
4243 gnus-article-treatment-menu gnus-article-mode-map ""
bb367cba 4244 ;; Fixme: this should use :active (and maybe :visible).
eec82323
LMI		 4245 '("Treatment"
4246 ["Hide headers" gnus-article-hide-headers t]
4247 ["Hide signature" gnus-article-hide-signature t]
4248 ["Hide citation" gnus-article-hide-citation t]
4249 ["Treat overstrike" gnus-article-treat-overstrike t]
01c52d31 4250 ["Treat ANSI sequences" gnus-article-treat-ansi-sequences t]
eec82323 4251 ["Remove carriage return" gnus-article-remove-cr t]
23f87bed 4252 ["Remove leading whitespace" gnus-article-remove-leading-whitespace t]
16409b0b
GM		 4253 ["Remove quoted-unreadable" gnus-article-de-quoted-unreadable t]
4254 ["Remove base64" gnus-article-de-base64-unreadable t]
4255 ["Treat html" gnus-article-wash-html t]
23f87bed 4256 ["Remove newlines from within URLs" gnus-article-unsplit-urls t]
16409b0b 4257 ["Decode HZ" gnus-article-decode-HZ t]))
eec82323 4258
6748645f 4259 ;; Note "Commands" menu is defined in gnus-sum.el for consistency
eec82323 4260
23f87bed 4261 ;; Note "Post" menu is defined in gnus-sum.el for consistency
eec82323 4262
6748645f 4263 (gnus-run-hooks 'gnus-article-menu-hook)))
eec82323
LMI		 4264
4265(defun gnus-article-mode ()
4266 "Major mode for displaying an article.
4267
4268All normal editing commands are switched off.
4269
4270The following commands are available in addition to all summary mode
4271commands:
4272\\<gnus-article-mode-map>
4273\\[gnus-article-next-page]\t Scroll the article one page forwards
4274\\[gnus-article-prev-page]\t Scroll the article one page backwards
4275\\[gnus-article-refer-article]\t Go to the article referred to by an article id near point
4276\\[gnus-article-show-summary]\t Display the summary buffer
4277\\[gnus-article-mail]\t Send a reply to the address near point
4278\\[gnus-article-describe-briefly]\t Describe the current mode briefly
4279\\[gnus-info-find-node]\t Go to the Gnus info node"
4280 (interactive)
0eb586fc 4281 (kill-all-local-variables)
eec82323
LMI		 4282 (gnus-simplify-mode-line)
4283 (setq mode-name "Article")
4284 (setq major-mode 'gnus-article-mode)
4285 (make-local-variable 'minor-mode-alist)
eec82323 4286 (use-local-map gnus-article-mode-map)
1653df0f 4287 (when (gnus-visual-p 'article-menu 'menu)
23f87bed
MB		 4288 (gnus-article-make-menu-bar)
4289 (when gnus-summary-tool-bar-map
4290 (set (make-local-variable 'tool-bar-map) gnus-summary-tool-bar-map)))
eec82323
LMI		 4291 (gnus-update-format-specifications nil 'article-mode)
4292 (set (make-local-variable 'page-delimiter) gnus-page-delimiter)
23f87bed 4293 (set (make-local-variable 'gnus-page-broken) nil)
6748645f
LMI		 4294 (make-local-variable 'gnus-button-marker-list)
4295 (make-local-variable 'gnus-article-current-summary)
16409b0b
GM		 4296 (make-local-variable 'gnus-article-mime-handles)
4297 (make-local-variable 'gnus-article-decoded-p)
4298 (make-local-variable 'gnus-article-mime-handle-alist)
4299 (make-local-variable 'gnus-article-wash-types)
23f87bed
MB		 4300 (make-local-variable 'gnus-article-image-alist)
4301 (make-local-variable 'gnus-article-charset)
4302 (make-local-variable 'gnus-article-ignored-charsets)
524705ae
MB		 4303 ;; Prevent Emacs 22 from displaying non-break space with `nobreak-space'
4304 ;; face.
fc1c32c1 4305 (set (make-local-variable 'nobreak-char-display) nil)
e4a89ccf 4306 (setq cursor-in-non-selected-windows nil)
01c52d31 4307 (setq truncate-lines gnus-article-truncate-lines)
eec82323 4308 (gnus-set-default-directory)
16409b0b 4309 (buffer-disable-undo)
01c52d31
MB		 4310 (setq buffer-read-only t
4311 show-trailing-whitespace nil)
eec82323 4312 (set-syntax-table gnus-article-mode-syntax-table)
16409b0b 4313 (mm-enable-multibyte)
cfcd5c91 4314 (gnus-run-mode-hooks 'gnus-article-mode-hook))
eec82323 4315
676c1893 4316(defvar gnus-button-marker-list nil
01c52d31
MB		 4317 "Regexp matching any of the regexps from `gnus-button-alist'.
4318Internal variable.")
676c1893 4319
eec82323
LMI		 4320(defun gnus-article-setup-buffer ()
4321 "Initialize the article buffer."
4322 (let* ((name (if gnus-single-article-buffer "*Article*"
4323 (concat "*Article " gnus-newsgroup-name "*")))
4324 (original
4325 (progn (string-match "\\*Article" name)
4326 (concat " *Original Article"
4327 (substring name (match-end 0))))))
4328 (setq gnus-article-buffer name)
4329 (setq gnus-original-article-buffer original)
16409b0b 4330 (setq gnus-article-mime-handle-alist nil)
01c52d31
MB		 4331 (with-current-buffer gnus-summary-buffer
4332 ;; This might be a variable local to the summary buffer.
4333 (unless gnus-single-article-buffer
eec82323
LMI		 4334 (setq gnus-article-buffer name)
4335 (setq gnus-original-article-buffer original)
4336 (gnus-set-global-variables)))
16409b0b 4337 (gnus-article-setup-highlight-words)
eec82323 4338 ;; Init original article buffer.
80de1778 4339 (with-current-buffer (gnus-get-buffer-create gnus-original-article-buffer)
16409b0b 4340 (mm-enable-multibyte)
eec82323 4341 (setq major-mode 'gnus-original-article-mode)
eec82323 4342 (make-local-variable 'gnus-original-article))
aba1948a
MB		 4343 (if (and (get-buffer name)
4344 (with-current-buffer name
4345 (if gnus-article-edit-mode
4346 (if (y-or-n-p "Article mode edit in progress; discard? ")
4347 (progn
4348 (set-buffer-modified-p nil)
4349 (gnus-kill-buffer name)
4350 (message "")
4351 nil)
4352 (error "Action aborted"))
4353 t)))
80de1778 4354 (with-current-buffer name
23f87bed 4355 (set (make-local-variable 'gnus-article-edit-mode) nil)
16409b0b
GM		 4356 (when gnus-article-mime-handles
4357 (mm-destroy-parts gnus-article-mime-handles)
4358 (setq gnus-article-mime-handles nil))
4359 ;; Set it to nil in article-buffer!
a1506d29 4360 (setq gnus-article-mime-handle-alist nil)
16409b0b 4361 (buffer-disable-undo)
eec82323 4362 (setq buffer-read-only t)
23f87bed
MB		 4363 ;; This list just keeps growing if we don't reset it.
4364 (setq gnus-button-marker-list nil)
eec82323
LMI		 4365 (unless (eq major-mode 'gnus-article-mode)
4366 (gnus-article-mode))
4367 (current-buffer))
80de1778 4368 (with-current-buffer (gnus-get-buffer-create name)
eec82323
LMI		 4369 (gnus-article-mode)
4370 (make-local-variable 'gnus-summary-buffer)
01c52d31
MB		 4371 (setq gnus-summary-buffer
4372 (gnus-summary-buffer-name gnus-newsgroup-name))
16409b0b 4373 (gnus-summary-set-local-parameters gnus-newsgroup-name)
eec82323
LMI		 4374 (current-buffer)))))
4375
4376;; Set article window start at LINE, where LINE is the number of lines
4377;; from the head of the article.
4378(defun gnus-article-set-window-start (&optional line)
01c52d31
MB		 4379 (let ((article-window (gnus-get-buffer-window gnus-article-buffer t)))
4380 (when article-window
4381 (set-window-start
4382 article-window
80de1778 4383 (with-current-buffer gnus-article-buffer
01c52d31
MB		 4384 (goto-char (point-min))
4385 (if (not line)
4386 (point-min)
4387 (gnus-message 6 "Moved to bookmark")
4388 (search-forward "\n\n" nil t)
4389 (forward-line line)
4390 (point)))))))
eec82323
LMI		 4391
4392(defun gnus-article-prepare (article &optional all-headers header)
4393 "Prepare ARTICLE in article mode buffer.
4394ARTICLE should either be an article number or a Message-ID.
4395If ARTICLE is an id, HEADER should be the article headers.
4396If ALL-HEADERS is non-nil, no headers are hidden."
4397 (save-excursion
4398 ;; Make sure we start in a summary buffer.
4399 (unless (eq major-mode 'gnus-summary-mode)
4400 (set-buffer gnus-summary-buffer))
4401 (setq gnus-summary-buffer (current-buffer))
eec82323
LMI		 4402 (let* ((gnus-article (if header (mail-header-number header) article))
4403 (summary-buffer (current-buffer))
6748645f 4404 (gnus-tmp-internal-hook gnus-article-internal-prepare-hook)
eec82323
LMI		 4405 (group gnus-newsgroup-name)
4406 result)
4407 (save-excursion
4408 (gnus-article-setup-buffer)
4409 (set-buffer gnus-article-buffer)
4410 ;; Deactivate active regions.
4411 (when (and (boundp 'transient-mark-mode)
4412 transient-mark-mode)
4413 (setq mark-active nil))
4e7d0221 4414 (if (not (setq result (let ((inhibit-read-only t))
eec82323
LMI		 4415 (gnus-request-article-this-buffer
4416 article group))))
4417 ;; There is no such article.
4418 (save-excursion
4419 (when (and (numberp article)
4420 (not (memq article gnus-newsgroup-sparse)))
4421 (setq gnus-article-current
4422 (cons gnus-newsgroup-name article))
4423 (set-buffer gnus-summary-buffer)
4424 (setq gnus-current-article article)
23f87bed
MB		 4425 (if (and (memq article gnus-newsgroup-undownloaded)
4426 (not (gnus-online (gnus-find-method-for-group
4427 gnus-newsgroup-name))))
6748645f
LMI		 4428 (progn
4429 (gnus-summary-set-agent-mark article)
4430 (message "Message marked for downloading"))
4431 (gnus-summary-mark-article article gnus-canceled-mark)
4432 (unless (memq article gnus-newsgroup-sparse)
16409b0b 4433 (gnus-error 1 "No such article (may have expired or been canceled)")))))
6748645f
LMI		 4434 (if (or (eq result 'pseudo)
4435 (eq result 'nneething))
eec82323 4436 (progn
80de1778 4437 (with-current-buffer summary-buffer
6748645f 4438 (push article gnus-newsgroup-history)
eec82323 4439 (setq gnus-last-article gnus-current-article
eec82323
LMI		 4440 gnus-current-article 0
4441 gnus-current-headers nil
4442 gnus-article-current nil)
4443 (if (eq result 'nneething)
4444 (gnus-configure-windows 'summary)
4445 (gnus-configure-windows 'article))
4446 (gnus-set-global-variables))
16409b0b
GM		 4447 (let ((gnus-article-mime-handle-alist-1
4448 gnus-article-mime-handle-alist))
4449 (gnus-set-mode-line 'article)))
eec82323
LMI		 4450 ;; The result from the `request' was an actual article -
4451 ;; or at least some text that is now displayed in the
4452 ;; article buffer.
4453 (when (and (numberp article)
4454 (not (eq article gnus-current-article)))
4455 ;; Seems like a new article has been selected.
4456 ;; `gnus-current-article' must be an article number.
80de1778 4457 (with-current-buffer summary-buffer
6748645f 4458 (push article gnus-newsgroup-history)
eec82323 4459 (setq gnus-last-article gnus-current-article
eec82323
LMI		 4460 gnus-current-article article
4461 gnus-current-headers
4462 (gnus-summary-article-header gnus-current-article)
4463 gnus-article-current
4464 (cons gnus-newsgroup-name gnus-current-article))
4465 (unless (vectorp gnus-current-headers)
4466 (setq gnus-current-headers nil))
6748645f
LMI		 4467 (gnus-summary-goto-subject gnus-current-article)
4468 (when (gnus-summary-show-thread)
4469 ;; If the summary buffer really was folded, the
4470 ;; previous goto may not actually have gone to
4471 ;; the right article, but the thread root instead.
4472 ;; So we go again.
4473 (gnus-summary-goto-subject gnus-current-article))
4474 (gnus-run-hooks 'gnus-mark-article-hook)
eec82323
LMI		 4475 (gnus-set-mode-line 'summary)
4476 (when (gnus-visual-p 'article-highlight 'highlight)
6748645f 4477 (gnus-run-hooks 'gnus-visual-mark-article-hook))
eec82323 4478 ;; Set the global newsgroup variables here.
eec82323
LMI		 4479 (gnus-set-global-variables)
4480 (setq gnus-have-all-headers
6748645f 4481 (or all-headers gnus-show-all-headers))))
e0bad764
DL		 4482 (save-excursion
4483 (gnus-configure-windows 'article))
eec82323
LMI		 4484 (when (or (numberp article)
4485 (stringp article))
16409b0b 4486 (gnus-article-prepare-display)
eec82323
LMI		 4487 ;; Do page break.
4488 (goto-char (point-min))
23f87bed
MB		 4489 (when gnus-break-pages
4490 (gnus-narrow-to-page)))
16409b0b
GM		 4491 (let ((gnus-article-mime-handle-alist-1
4492 gnus-article-mime-handle-alist))
4493 (gnus-set-mode-line 'article))
4494 (article-goto-body)
23f87bed
MB		 4495 (unless (bobp)
4496 (forward-line -1))
6748645f 4497 (set-window-point (get-buffer-window (current-buffer)) (point))
16409b0b 4498 (gnus-configure-windows 'article)
eec82323
LMI		 4499 t))))))
4500
16409b0b
GM		 4501;;;###autoload
4502(defun gnus-article-prepare-display ()
4503 "Make the current buffer look like a nice article."
4504 ;; Hooks for getting information from the article.
4505 ;; This hook must be called before being narrowed.
4506 (let ((gnus-article-buffer (current-buffer))
23f87bed
MB		 4507 buffer-read-only
4508 (inhibit-read-only t))
16409b0b
GM		 4509 (unless (eq major-mode 'gnus-article-mode)
4510 (gnus-article-mode))
4511 (setq buffer-read-only nil
23f87bed
MB		 4512 gnus-article-wash-types nil
4513 gnus-article-image-alist nil)
16409b0b
GM		 4514 (gnus-run-hooks 'gnus-tmp-internal-hook)
4515 (when gnus-display-mime-function
4516 (funcall gnus-display-mime-function))
4517 (gnus-run-hooks 'gnus-article-prepare-hook)))
4518
01c52d31
MB		 4519;;;
4520;;; Gnus Sticky Article Mode
4521;;;
4522
4523(define-derived-mode gnus-sticky-article-mode gnus-article-mode "StickyArticle"
4524 "Mode for sticky articles."
4525 ;; Release bindings that won't work.
4526 (substitute-key-definition 'gnus-article-read-summary-keys 'undefined
4527 gnus-sticky-article-mode-map)
4528 (substitute-key-definition 'gnus-article-refer-article 'undefined
4529 gnus-sticky-article-mode-map)
4530 (dolist (k '("e" "h" "s" "F" "R"))
4531 (define-key gnus-sticky-article-mode-map k nil))
4532 (define-key gnus-sticky-article-mode-map "k" 'gnus-kill-sticky-article-buffer)
4533 (define-key gnus-sticky-article-mode-map "q" 'bury-buffer)
4534 (define-key gnus-sticky-article-mode-map "\C-hc" 'describe-key-briefly)
4535 (define-key gnus-sticky-article-mode-map "\C-hk" 'describe-key))
4536
4537(defun gnus-sticky-article (arg)
4538 "Make the current article sticky.
4539If a prefix ARG is given, ask for a name for this sticky article buffer."
4540 (interactive "P")
4541 (gnus-summary-show-thread)
4542 (gnus-summary-select-article nil nil 'pseudo)
4543 (let (new-art-buf-name)
4544 (gnus-eval-in-buffer-window gnus-article-buffer
4545 (setq new-art-buf-name
4546 (concat
4547 "*Sticky Article: "
4548 (if arg
4549 (read-from-minibuffer "Sticky article buffer name: ")
4550 (gnus-with-article-headers
4551 (gnus-article-goto-header "subject")
4552 (setq new-art-buf-name
4553 (buffer-substring-no-properties
4554 (line-beginning-position) (line-end-position)))
4555 (goto-char (point-min))
4556 (gnus-article-goto-header "from")
4557 (setq new-art-buf-name
4558 (concat
4559 new-art-buf-name ", "
4560 (buffer-substring-no-properties
4561 (line-beginning-position) (line-end-position))))
4562 (goto-char (point-min))
4563 (gnus-article-goto-header "date")
4564 (setq new-art-buf-name
4565 (concat
4566 new-art-buf-name ", "
4567 (buffer-substring-no-properties
4568 (line-beginning-position) (line-end-position))))))
4569 "*"))
4570 (if (and (gnus-buffer-live-p new-art-buf-name)
4571 (with-current-buffer new-art-buf-name
4572 (eq major-mode 'gnus-sticky-article-mode)))
4573 (switch-to-buffer new-art-buf-name)
4574 (setq new-art-buf-name (rename-buffer new-art-buf-name t)))
4575 (gnus-sticky-article-mode))
4576 (setq gnus-article-buffer new-art-buf-name))
4577 (gnus-summary-recenter)
4578 (gnus-summary-position-point))
4579
4580(defun gnus-kill-sticky-article-buffer (&optional buffer)
4581 "Kill the given sticky article BUFFER.
4582If none is given, assume the current buffer and kill it if it has
4583`gnus-sticky-article-mode'."
4584 (interactive)
4585 (unless buffer
4586 (setq buffer (current-buffer)))
4587 (with-current-buffer buffer
4588 (when (eq major-mode 'gnus-sticky-article-mode)
4589 (gnus-kill-buffer buffer))))
4590
4591(defun gnus-kill-sticky-article-buffers (arg)
4592 "Kill all sticky article buffers.
4593If a prefix ARG is given, ask for confirmation."
4594 (interactive "P")
4595 (dolist (buf (gnus-buffers))
4596 (with-current-buffer buf
4597 (when (eq major-mode 'gnus-sticky-article-mode)
4598 (if (not arg)
4599 (gnus-kill-buffer buf)
4600 (when (yes-or-no-p (concat "Kill buffer " (buffer-name buf) "? "))
4601 (gnus-kill-buffer buf)))))))
4602
16409b0b
GM		 4603;;;
4604;;; Gnus MIME viewing functions
4605;;;
4606
4607(defvar gnus-mime-button-line-format "%{%([%p. %d%T]%)%}%e\n"
23f87bed
MB		 4608 "Format of the MIME buttons.
4609
4610Valid specifiers include:
16409b0b
GM		 4611%t The MIME type
4612%T MIME type, along with additional info
4613%n The `name' parameter
4614%d The description, if any
4615%l The length of the encoded part
4616%p The part identifier number
23f87bed
MB		 4617%e Dots if the part isn't displayed
4618
4619General format specifiers can also be used. See Info node
4620`(gnus)Formatting Variables'.")
16409b0b
GM		 4621
4622(defvar gnus-mime-button-line-format-alist
4623 '((?t gnus-tmp-type ?s)
4624 (?T gnus-tmp-type-long ?s)
4625 (?n gnus-tmp-name ?s)
4626 (?d gnus-tmp-description ?s)
4627 (?p gnus-tmp-id ?s)
4628 (?l gnus-tmp-length ?d)
4629 (?e gnus-tmp-dots ?s)))
4630
4631(defvar gnus-mime-button-commands
4632 '((gnus-article-press-button "\r" "Toggle Display")
4633 (gnus-mime-view-part "v" "View Interactively...")
4634 (gnus-mime-view-part-as-type "t" "View As Type...")
23f87bed 4635 (gnus-mime-view-part-as-charset "C" "View As charset...")
16409b0b 4636 (gnus-mime-save-part "o" "Save...")
23f87bed 4637 (gnus-mime-save-part-and-strip "\C-o" "Save and Strip")
01c52d31 4638 (gnus-mime-replace-part "r" "Replace part")
23f87bed 4639 (gnus-mime-delete-part "d" "Delete part")
16409b0b
GM		 4640 (gnus-mime-copy-part "c" "View As Text, In Other Buffer")
4641 (gnus-mime-inline-part "i" "View As Text, In This Buffer")
01c52d31 4642 (gnus-mime-view-part-internally "E" "View Internally") ;; Why `E'?
23f87bed
MB		 4643 (gnus-mime-view-part-externally "e" "View Externally")
4644 (gnus-mime-print-part "p" "Print")
e0bad764 4645 (gnus-mime-pipe-part "|" "Pipe To Command...")
23f87bed 4646 (gnus-mime-action-on-part "." "Take action on the part...")))
16409b0b
GM		 4647
4648(defun gnus-article-mime-part-status ()
4649 (if gnus-article-mime-handle-alist-1
23f87bed
MB		 4650 (if (eq 1 (length gnus-article-mime-handle-alist-1))
4651 " (1 part)"
4652 (format " (%d parts)" (length gnus-article-mime-handle-alist-1)))
16409b0b
GM		 4653 ""))
4654
4655(defvar gnus-mime-button-map
4656 (let ((map (make-sparse-keymap)))
16409b0b
GM		 4657 (define-key map gnus-mouse-2 'gnus-article-push-button)
4658 (define-key map gnus-down-mouse-3 'gnus-mime-button-menu)
4659 (dolist (c gnus-mime-button-commands)
4660 (define-key map (cadr c) (car c)))
4661 map))
4662
23f87bed
MB		 4663(easy-menu-define
4664 gnus-mime-button-menu gnus-mime-button-map "MIME button menu."
4665 `("MIME Part"
4666 ,@(mapcar (lambda (c)
01c52d31 4667 (vector (caddr c) (car c) :active t))
23f87bed
MB		 4668 gnus-mime-button-commands)))
4669
23f87bed
MB		 4670(defun gnus-mime-button-menu (event prefix)
4671 "Construct a context-sensitive menu of MIME commands."
4672 (interactive "e\nP")
4673 (save-window-excursion
4674 (let ((pos (event-start event)))
4675 (select-window (posn-window pos))
4676 (goto-char (posn-point pos))
4677 (gnus-article-check-buffer)
4678 (popup-menu gnus-mime-button-menu nil prefix))))
16409b0b
GM		 4679
4680(defun gnus-mime-view-all-parts (&optional handles)
4681 "View all the MIME parts."
4682 (interactive)
01c52d31 4683 (with-current-buffer gnus-article-buffer
16409b0b
GM		 4684 (let ((handles (or handles gnus-article-mime-handles))
4685 (mail-parse-charset gnus-newsgroup-charset)
a1506d29 4686 (mail-parse-ignored-charsets
23f87bed
MB		 4687 (with-current-buffer gnus-summary-buffer
4688 gnus-newsgroup-ignored-charsets)))
4689 (when handles
4690 (mm-remove-parts handles)
4691 (goto-char (point-min))
4692 (or (search-forward "\n\n") (goto-char (point-max)))
4693 (let ((inhibit-read-only t))
4694 (delete-region (point) (point-max))
4695 (mm-display-parts handles))))))
4696
01c52d31
MB		 4697(defun gnus-article-jump-to-part (n)
4698 "Jump to MIME part N."
4699 (interactive "P")
4700 (pop-to-buffer gnus-article-buffer)
4701 ;; FIXME: why is it necessary?
4702 (sit-for 0)
4703 (let ((parts (length gnus-article-mime-handle-alist)))
4704 (or n (setq n
4705 (string-to-number
4706 (read-string ;; Emacs 21 doesn't have `read-number'.
4707 (format "Jump to part (2..%s): " parts)))))
4708 (unless (and (integerp n) (<= n parts) (>= n 1))
4709 (setq n
4710 (progn
4711 (gnus-message 7 "Invalid part `%s', using %s instead."
4712 n parts)
4713 parts)))
4714 (gnus-message 9 "Jumping to part %s." n)
4715 (cond ((>= gnus-auto-select-part 1)
4716 (while (and (<= n parts)
4717 (not (gnus-article-goto-part n)))
4718 (setq n (1+ n))))
4719 ((< gnus-auto-select-part 0)
4720 (while (and (>= n 1)
4721 (not (gnus-article-goto-part n)))
4722 (setq n (1- n))))
4723 (t
4724 (gnus-article-goto-part n)))))
4725
4726(eval-when-compile
4727 (defsubst gnus-article-edit-part (handles &optional current-id)
4728 "Edit an article in order to delete a mime part.
4729This function is exclusively used by `gnus-mime-save-part-and-strip'
4730and `gnus-mime-delete-part', and not provided at run-time normally."
4731 (gnus-article-edit-article
4732 `(lambda ()
4733 (buffer-disable-undo)
4734 (erase-buffer)
4735 (let ((mail-parse-charset (or gnus-article-charset
4736 ',gnus-newsgroup-charset))
4737 (mail-parse-ignored-charsets
4738 (or gnus-article-ignored-charsets
4739 ',gnus-newsgroup-ignored-charsets))
4740 (mbl mml-buffer-list))
4741 (setq mml-buffer-list nil)
4742 (insert-buffer-substring gnus-original-article-buffer)
4743 (mime-to-mml ',handles)
4744 (setq gnus-article-mime-handles nil)
4745 (let ((mbl1 mml-buffer-list))
4746 (setq mml-buffer-list mbl)
4747 (set (make-local-variable 'mml-buffer-list) mbl1))
4748 (gnus-make-local-hook 'kill-buffer-hook)
4749 (add-hook 'kill-buffer-hook 'mml-destroy-buffers t t)))
4750 `(lambda (no-highlight)
4751 (let ((mail-parse-charset (or gnus-article-charset
4752 ',gnus-newsgroup-charset))
4753 (message-options message-options)
4754 (message-options-set-recipient)
4755 (mail-parse-ignored-charsets
4756 (or gnus-article-ignored-charsets
4757 ',gnus-newsgroup-ignored-charsets)))
4758 (mml-to-mime)
4759 (mml-destroy-buffers)
4760 (remove-hook 'kill-buffer-hook
4761 'mml-destroy-buffers t)
4762 (kill-local-variable 'mml-buffer-list))
4763 (gnus-summary-edit-article-done
4764 ,(or (mail-header-references gnus-current-headers) "")
4765 ,(gnus-group-read-only-p)
4766 ,gnus-summary-buffer no-highlight))
4767 t)
4768 (gnus-article-edit-done)
4769 (gnus-summary-expand-window)
4770 (gnus-summary-show-article)
4771 (when (and current-id (integerp gnus-auto-select-part))
4772 (gnus-article-jump-to-part
4773 (if (text-property-any (point-min) (point-max)
4774 'gnus-part (+ current-id gnus-auto-select-part))
4775 (+ current-id gnus-auto-select-part)
4776 (with-current-buffer gnus-article-buffer
4777 (length gnus-article-mime-handle-alist)))))))
4778
4779(defun gnus-mime-replace-part (file)
4780 "Replace MIME part under point with an external body."
4781 ;; Useful if file has already been saved to disk
4782 (interactive
4783 (list
4784 (mm-with-multibyte
4785 (read-file-name "Replace MIME part with file: "
4786 (or mm-default-directory default-directory)
4787 nil nil))))
4788 (gnus-mime-save-part-and-strip file))
4789
4790(defun gnus-mime-save-part-and-strip (&optional file)
4791 "Save the MIME part under point then replace it with an external body.
4792If FILE is given, use it for the external part."
23f87bed
MB		 4793 (interactive)
4794 (gnus-article-check-buffer)
4795 (when (gnus-group-read-only-p)
4796 (error "The current group does not support deleting of parts"))
4797 (when (mm-complicated-handles gnus-article-mime-handles)
4798 (error "\
4799The current article has a complicated MIME structure, giving up..."))
01c52d31
MB		 4800 (let* ((data (get-text-property (point) 'gnus-data))
4801 (id (get-text-property (point) 'gnus-part))
4802 param
4803 (handles gnus-article-mime-handles))
4804 (unless file
4805 (setq file
4806 (and data (mm-save-part data "Delete MIME part and save to: "))))
4807 (when file
4808 (with-current-buffer (mm-handle-buffer data)
4809 (erase-buffer)
4810 (insert "Content-Type: " (mm-handle-media-type data))
4811 (mml-insert-parameter-string (cdr (mm-handle-type data))
4812 '(charset))
4813 ;; Add a filename for the sake of saving the part again.
4814 (mml-insert-parameter
4815 (mail-header-encode-parameter "name" (file-name-nondirectory file)))
4816 (insert "\n")
4817 (insert "Content-ID: " (message-make-message-id) "\n")
4818 (insert "Content-Transfer-Encoding: binary\n")
4819 (insert "\n"))
4820 (setcdr data
4821 (cdr (mm-make-handle nil
4822 `("message/external-body"
4823 (access-type . "LOCAL-FILE")
4824 (name . ,file)))))
4825 ;; (set-buffer gnus-summary-buffer)
4826 (gnus-article-edit-part handles id))))
4827
4828;; A function like `gnus-summary-save-parts' (`X m', `<MIME> <Extract all
4829;; parts...>') but with stripping would be nice.
23f87bed
MB		 4830
4831(defun gnus-mime-delete-part ()
4832 "Delete the MIME part under point.
4833Replace it with some information about the removed part."
4834 (interactive)
4835 (gnus-article-check-buffer)
4836 (when (gnus-group-read-only-p)
4837 (error "The current group does not support deleting of parts"))
4838 (when (mm-complicated-handles gnus-article-mime-handles)
4839 (error "\
4840The current article has a complicated MIME structure, giving up..."))
01c52d31
MB		 4841 (when (or gnus-expert-user
4842 (gnus-yes-or-no-p "\
4843Deleting parts may malfunction or destroy the article; continue? "))
23f87bed 4844 (let* ((data (get-text-property (point) 'gnus-data))
01c52d31 4845 (id (get-text-property (point) 'gnus-part))
23f87bed
MB		 4846 (handles gnus-article-mime-handles)
4847 (none "(none)")
4848 (description
bbbe940b
MB		 4849 (let ((desc (mm-handle-description data)))
4850 (when desc
4851 (mail-decode-encoded-word-string desc))))
23f87bed
MB		 4852 (filename
4853 (or (mail-content-type-get (mm-handle-disposition data) 'filename)
4854 none))
4855 (type (mm-handle-media-type data)))
4856 (unless data
4857 (error "No MIME part under point"))
4858 (with-current-buffer (mm-handle-buffer data)
4859 (let ((bsize (format "%s" (buffer-size))))
4860 (erase-buffer)
4861 (insert
4862 (concat
4863 ",----\n"
4864 "| The following attachment has been deleted:\n"
4865 "|\n"
4866 "| Type: " type "\n"
4867 "| Filename: " filename "\n"
4868 "| Size (encoded): " bsize " Byte\n"
bbbe940b
MB		 4869 (when description
4870 (concat "| Description: " description "\n"))
23f87bed
MB		 4871 "`----\n"))
4872 (setcdr data
4873 (cdr (mm-make-handle
4874 nil `("text/plain") nil nil
4875 (list "attachment")
4876 (format "Deleted attachment (%s bytes)" bsize))))))
01c52d31
MB		 4877 ;; (set-buffer gnus-summary-buffer)
4878 (gnus-article-edit-part handles id))))
16409b0b
GM		 4879
4880(defun gnus-mime-save-part ()
4881 "Save the MIME part under point."
4882 (interactive)
4883 (gnus-article-check-buffer)
4884 (let ((data (get-text-property (point) 'gnus-data)))
23f87bed
MB		 4885 (when data
4886 (mm-save-part data))))
16409b0b
GM		 4887
4888(defun gnus-mime-pipe-part ()
4889 "Pipe the MIME part under point to a process."
4890 (interactive)
4891 (gnus-article-check-buffer)
4892 (let ((data (get-text-property (point) 'gnus-data)))
23f87bed
MB		 4893 (when data
4894 (mm-pipe-part data))))
16409b0b
GM		 4895
4896(defun gnus-mime-view-part ()
4897 "Interactively choose a viewing method for the MIME part under point."
4898 (interactive)
4899 (gnus-article-check-buffer)
4900 (let ((data (get-text-property (point) 'gnus-data)))
23f87bed
MB		 4901 (when data
4902 (setq gnus-article-mime-handles
4903 (mm-merge-handles
4904 gnus-article-mime-handles (setq data (copy-sequence data))))
4905 (mm-interactively-view-part data))))
16409b0b
GM		 4906
4907(defun gnus-mime-view-part-as-type-internal ()
4908 (gnus-article-check-buffer)
54e573e6
MB		 4909 (let* ((handle (get-text-property (point) 'gnus-data))
4910 (name (or
4911 ;; Content-Type: foo/bar; name=...
4912 (mail-content-type-get (mm-handle-type handle) 'name)
4913 ;; Content-Disposition: attachment; filename=...
4914 (cdr (assq 'filename (cdr (mm-handle-disposition handle))))))
16409b0b 4915 (def-type (and name (mm-default-file-encoding name))))
01c52d31
MB		 4916 (or (and def-type (cons def-type 0))
4917 (and handle
4918 (equal (mm-handle-media-supertype handle) "text")
4919 '("text/plain" . 0))
4920 '("application/octet-stream" . 0))))
16409b0b 4921
54e573e6
MB		 4922(defun gnus-mime-view-part-as-type (&optional mime-type pred)
4923 "Choose a MIME media type, and view the part as such.
4924If non-nil, PRED is a predicate to use during completion to limit the
4925available media-types."
23f87bed
MB		 4926 (interactive)
4927 (unless mime-type
54e573e6
MB		 4928 (setq mime-type
4929 (let ((default (gnus-mime-view-part-as-type-internal)))
4930 (completing-read
4931 (format "View as MIME type (default %s): "
4932 (car default))
4933 (mapcar #'list (mailcap-mime-types))
4934 pred nil nil nil
4935 (car default)))))
16409b0b
GM		 4936 (gnus-article-check-buffer)
4937 (let ((handle (get-text-property (point) 'gnus-data)))
23f87bed 4938 (when handle
531bedc3
MB		 4939 (when (equal (mm-handle-media-type handle) "message/external-body")
4940 (unless (mm-handle-cache handle)
4941 (mm-extern-cache-contents handle))
4942 (setq handle (mm-handle-cache handle)))
23f87bed
MB		 4943 (setq handle
4944 (mm-make-handle (mm-handle-buffer handle)
4945 (cons mime-type (cdr (mm-handle-type handle)))
4946 (mm-handle-encoding handle)
4947 (mm-handle-undisplayer handle)
4948 (mm-handle-disposition handle)
4949 (mm-handle-description handle)
4950 nil
4951 (mm-handle-id handle)))
4952 (setq gnus-article-mime-handles
4953 (mm-merge-handles gnus-article-mime-handles handle))
01c52d31
MB		 4954 (when (mm-handle-displayed-p handle)
4955 (mm-remove-part handle))
23f87bed
MB		 4956 (gnus-mm-display-part handle))))
4957
01c52d31 4958(defun gnus-mime-copy-part (&optional handle arg)
23f87bed
MB		 4959 "Put the MIME part under point into a new buffer.
4960If `auto-compression-mode' is enabled, compressed files like .gz and .bz2
4961are decompressed."
01c52d31 4962 (interactive (list nil current-prefix-arg))
16409b0b 4963 (gnus-article-check-buffer)
01c52d31
MB		 4964 (unless handle
4965 (setq handle (get-text-property (point) 'gnus-data)))
4966 (when handle
4967 (let ((filename (or (mail-content-type-get (mm-handle-type handle)
4968 'name)
4969 (mail-content-type-get (mm-handle-disposition handle)
4970 'filename)))
4971 contents dont-decode charset coding-system)
4972 (mm-with-unibyte-buffer
4973 (mm-insert-part handle)
4974 (setq contents (or (condition-case nil
4975 (mm-decompress-buffer filename nil 'sig)
4976 (error
4977 (setq dont-decode t)
4978 nil))
4979 (buffer-string))))
4980 (setq filename (cond (filename (file-name-nondirectory filename))
4981 (dont-decode "*raw data*")
4982 (t "*decoded*")))
4983 (cond
4984 (dont-decode)
4985 ((not arg)
4986 (unless (setq charset (mail-content-type-get
4987 (mm-handle-type handle) 'charset))
4988 (unless (setq coding-system (mm-with-unibyte-buffer
4989 (insert contents)
4990 (mm-find-buffer-file-coding-system)))
4991 (setq charset gnus-newsgroup-charset))))
4992 ((numberp arg)
4993 (setq charset (or (cdr (assq arg
4994 gnus-summary-show-article-charset-alist))
4995 (mm-read-coding-system "Charset: ")))))
4996 (switch-to-buffer (generate-new-buffer filename))
4997 (if (or coding-system
4998 (and charset
4999 (setq coding-system (mm-charset-to-coding-system charset))
5000 (not (eq charset 'ascii))))
5001 (progn
5002 (mm-enable-multibyte)
5003 (insert (mm-decode-coding-string contents coding-system))
5004 (setq buffer-file-coding-system
5005 (if (boundp 'last-coding-system-used)
5006 (symbol-value 'last-coding-system-used)
5007 coding-system)))
5008 (mm-disable-multibyte)
5009 (insert contents)
5010 (setq buffer-file-coding-system mm-binary-coding-system))
23f87bed
MB		 5011 ;; We do it this way to make `normal-mode' set the appropriate mode.
5012 (unwind-protect
5013 (progn
01c52d31 5014 (setq buffer-file-name (expand-file-name filename))
23f87bed
MB		 5015 (normal-mode))
5016 (setq buffer-file-name nil))
5017 (goto-char (point-min)))))
5018
5019(defun gnus-mime-print-part (&optional handle filename)
5020 "Print the MIME part under point."
5021 (interactive (list nil (ps-print-preprint current-prefix-arg)))
5022 (gnus-article-check-buffer)
5023 (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
5024 (contents (and handle (mm-get-part handle)))
5025 (file (mm-make-temp-file (expand-file-name "mm." mm-tmp-directory)))
5026 (printer (mailcap-mime-info (mm-handle-media-type handle) "print")))
5027 (when contents
5028 (if printer
5029 (unwind-protect
5030 (progn
5031 (mm-save-part-to-file handle file)
5032 (call-process shell-file-name nil
5033 (generate-new-buffer " *mm*")
5034 nil
5035 shell-command-switch
5036 (mm-mailcap-command
5037 printer file (mm-handle-type handle))))
5038 (delete-file file))
5039 (with-temp-buffer
5040 (insert contents)
5041 (gnus-print-buffer))
5042 (ps-despool filename)))))
16409b0b 5043
e0bad764 5044(defun gnus-mime-inline-part (&optional handle arg)
01c52d31
MB		 5045 "Insert the MIME part under point into the current buffer.
5046Compressed files like .gz and .bz2 are decompressed."
e0bad764 5047 (interactive (list nil current-prefix-arg))
16409b0b 5048 (gnus-article-check-buffer)
01c52d31
MB		 5049 (unless handle
5050 (setq handle (get-text-property (point) 'gnus-data)))
5051 (when handle
5052 (let ((b (point))
5053 (inhibit-read-only t)
5054 contents charset coding-system)
23f87bed
MB		 5055 (if (and (not arg) (mm-handle-undisplayer handle))
5056 (mm-remove-part handle)
01c52d31
MB		 5057 (mm-with-unibyte-buffer
5058 (mm-insert-part handle)
5059 (setq contents
5060 (or (mm-decompress-buffer
5061 (or (mail-content-type-get (mm-handle-type handle)
5062 'name)
5063 (mail-content-type-get (mm-handle-disposition handle)
5064 'filename))
5065 nil t)
5066 (buffer-string))))
23f87bed
MB		 5067 (cond
5068 ((not arg)
01c52d31
MB		 5069 (unless (setq charset (mail-content-type-get
5070 (mm-handle-type handle) 'charset))
5071 (unless (setq coding-system
5072 (mm-with-unibyte-buffer
5073 (insert contents)
5074 (mm-find-buffer-file-coding-system)))
5075 (setq charset gnus-newsgroup-charset))))
23f87bed
MB		 5076 ((numberp arg)
5077 (if (mm-handle-undisplayer handle)
5078 (mm-remove-part handle))
5079 (setq charset
5080 (or (cdr (assq arg
5081 gnus-summary-show-article-charset-alist))
56c30d72
MB		 5082 (mm-read-coding-system "Charset: "))))
5083 (t
5084 (if (mm-handle-undisplayer handle)
850c333d 5085 (mm-remove-part handle))))
23f87bed 5086 (forward-line 2)
850c333d
MB		 5087 (mm-insert-inline
5088 handle
01c52d31
MB		 5089 (if (or coding-system
5090 (and charset
5091 (setq coding-system
5092 (mm-charset-to-coding-system charset))
5093 (not (eq coding-system 'ascii))))
5094 (mm-decode-coding-string contents coding-system)
850c333d 5095 (mm-string-to-multibyte contents)))
23f87bed
MB		 5096 (goto-char b)))))
5097
6b554e88
MB		 5098(defun gnus-mime-strip-charset-parameters (handle)
5099 "Strip charset parameters from HANDLE."
5100 (if (stringp (car handle))
5101 (mapc #'gnus-mime-strip-charset-parameters (cdr handle))
5102 (let* ((type (mm-handle-type (if (equal (mm-handle-media-type handle)
5103 "message/external-body")
5104 (progn
5105 (unless (mm-handle-cache handle)
5106 (mm-extern-cache-contents handle))
5107 (mm-handle-cache handle))
5108 handle)))
5109 (charset (assq 'charset (cdr type))))
5110 (when charset
5111 (delq charset type)))))
5112
23f87bed
MB		 5113(defun gnus-mime-view-part-as-charset (&optional handle arg)
5114 "Insert the MIME part under point into the current buffer using the
5115specified charset."
5116 (interactive (list nil current-prefix-arg))
5117 (gnus-article-check-buffer)
163cb72d
MB		 5118 (let ((handle (or handle (get-text-property (point) 'gnus-data)))
5119 (fun (get-text-property (point) 'gnus-callback))
5120 (gnus-newsgroup-ignored-charsets 'gnus-all)
6b554e88 5121 gnus-newsgroup-charset form preferred parts)
23f87bed 5122 (when handle
01c52d31
MB		 5123 (when (prog1
5124 (and fun
5125 (setq gnus-newsgroup-charset
5126 (or (cdr (assq
5127 arg
5128 gnus-summary-show-article-charset-alist))
5129 (mm-read-coding-system "Charset: "))))
5130 (if (mm-handle-undisplayer handle)
5131 (mm-remove-part handle)))
6b554e88
MB		 5132 (gnus-mime-strip-charset-parameters handle)
5133 (when (and (consp (setq form (cdr-safe fun)))
5134 (setq form (ignore-errors
5135 (assq 'gnus-mime-display-alternative form)))
5136 (setq preferred (caddr form))
5137 (progn
5138 (when (eq (car preferred) 'quote)
5139 (setq preferred (cadr preferred)))
5140 (not (equal preferred
5141 (get-text-property (point) 'gnus-data))))
5142 (setq parts (get-text-property (point) 'gnus-part))
5143 (setq parts (cdr (assq parts
5144 gnus-article-mime-handle-alist)))
5145 (equal (mm-handle-media-type parts) "multipart/alternative")
5146 (setq parts (reverse (cdr parts))))
5147 (setcar (cddr form)
5148 (list 'quote (or (cadr (member preferred parts))
5149 (car parts)))))
163cb72d 5150 (funcall fun handle)))))
23f87bed
MB		 5151
5152(defun gnus-mime-view-part-externally (&optional handle)
16409b0b
GM		 5153 "View the MIME part under point with an external viewer."
5154 (interactive)
5155 (gnus-article-check-buffer)
5156 (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
5157 (mm-user-display-methods nil)
5158 (mm-inlined-types nil)
5159 (mail-parse-charset gnus-newsgroup-charset)
a1506d29 5160 (mail-parse-ignored-charsets
54e573e6
MB		 5161 (with-current-buffer gnus-summary-buffer
5162 gnus-newsgroup-ignored-charsets))
5163 (type (mm-handle-media-type handle))
5164 (method (mailcap-mime-info type))
5165 (mm-enable-external t))
5166 (if (not (stringp method))
5167 (gnus-mime-view-part-as-type
524705ae 5168 nil (lambda (types) (stringp (mailcap-mime-info (car types)))))
54e573e6
MB		 5169 (when handle
5170 (if (mm-handle-undisplayer handle)
5171 (mm-remove-part handle)
5172 (mm-display-part handle))))))
16409b0b 5173
23f87bed 5174(defun gnus-mime-view-part-internally (&optional handle)
16409b0b 5175 "View the MIME part under point with an internal viewer.
23f87bed 5176If no internal viewer is available, use an external viewer."
16409b0b
GM		 5177 (interactive)
5178 (gnus-article-check-buffer)
5179 (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
5180 (mm-inlined-types '(".*"))
5181 (mm-inline-large-images t)
5182 (mail-parse-charset gnus-newsgroup-charset)
a1506d29 5183 (mail-parse-ignored-charsets
54e573e6
MB		 5184 (with-current-buffer gnus-summary-buffer
5185 gnus-newsgroup-ignored-charsets))
23f87bed 5186 (inhibit-read-only t))
54e573e6
MB		 5187 (if (not (mm-inlinable-p handle))
5188 (gnus-mime-view-part-as-type
524705ae 5189 nil (lambda (types) (mm-inlinable-p handle (car types))))
54e573e6
MB		 5190 (when handle
5191 (if (mm-handle-undisplayer handle)
5192 (mm-remove-part handle)
5193 (mm-display-part handle))))))
16409b0b 5194
e0bad764
DL		 5195(defun gnus-mime-action-on-part (&optional action)
5196 "Do something with the MIME attachment at \(point\)."
5197 (interactive
23f87bed 5198 (list (completing-read "Action: " gnus-mime-action-alist nil t)))
e0bad764
DL		 5199 (gnus-article-check-buffer)
5200 (let ((action-pair (assoc action gnus-mime-action-alist)))
5201 (if action-pair
5202 (funcall (cdr action-pair)))))
5203
01c52d31
MB		 5204(defun gnus-article-part-wrapper (n function &optional no-handle interactive)
5205 "Call FUNCTION on MIME part N.
5206Unless NO-HANDLE, call FUNCTION with N-th MIME handle as it's only argument.
5207If INTERACTIVE, call FUNCTION interactivly."
5208 (let (window frame)
5209 ;; Check whether the article is displayed.
5210 (unless (and (gnus-buffer-live-p gnus-article-buffer)
5211 (setq window (get-buffer-window gnus-article-buffer t))
5212 (frame-visible-p (setq frame (window-frame window))))
5213 (error "No article is displayed"))
5214 (with-current-buffer gnus-article-buffer
5215 ;; Check whether the article displays the right contents.
5216 (unless (with-current-buffer gnus-summary-buffer
5217 (eq gnus-current-article (gnus-summary-article-number)))
5218 (error "You should select the right article first"))
5219 (if n
5220 (setq n (prefix-numeric-value n))
5221 (let ((pt (point)))
5222 (setq n (or (get-text-property pt 'gnus-part)
5223 (and (not (bobp))
5224 (get-text-property (1- pt) 'gnus-part))
5225 (get-text-property (prog2
5226 (forward-line 1)
5227 (point)
5228 (goto-char pt))
5229 'gnus-part)
5230 (get-text-property
5231 (or (and (setq pt (previous-single-property-change
5232 pt 'gnus-part))
5233 (1- pt))
5234 (next-single-property-change (point) 'gnus-part)
5235 (point))
5236 'gnus-part)
5237 1))))
5238 ;; Check whether the specified part exists.
5239 (when (> n (length gnus-article-mime-handle-alist))
5240 (error "No such part")))
5241 (unless
5242 (progn
5243 ;; To select the window is needed so that the cursor
5244 ;; might be visible on the MIME button.
5245 (select-window (prog1
5246 window
5247 (setq window (selected-window))
5248 ;; Article may be displayed in the other frame.
5249 (gnus-select-frame-set-input-focus
5250 (prog1
5251 frame
5252 (setq frame (selected-frame))))))
5253 (when (gnus-article-goto-part n)
5254 ;; We point the cursor and the arrow at the MIME button
5255 ;; when the `function' prompt the user for something.
5256 (let ((cursor-in-non-selected-windows t)
5257 (overlay-arrow-string "=>")
5258 (overlay-arrow-position (point-marker)))
5259 (unwind-protect
5260 (cond
5261 ((and no-handle interactive)
5262 (call-interactively function))
5263 (no-handle
5264 (funcall function))
5265 (interactive
5266 (call-interactively
5267 function
5268 (cdr (assq n gnus-article-mime-handle-alist))))
5269 (t
5270 (funcall function
5271 (cdr (assq n gnus-article-mime-handle-alist)))))
5272 (set-marker overlay-arrow-position nil)
5273 (unless gnus-auto-select-part
5274 (gnus-select-frame-set-input-focus frame)
5275 (select-window window))))
5276 t))
5277 (if gnus-inhibit-mime-unbuttonizing
5278 ;; This is the default though the program shouldn't reach here.
5279 (error "No such part")
5280 ;; The part which doesn't have the MIME button is selected.
5281 ;; So, we display all the buttons and redo it.
5282 (let ((gnus-inhibit-mime-unbuttonizing t))
5283 (gnus-summary-show-article)
5284 (gnus-article-part-wrapper n function no-handle))))))
16409b0b
GM		 5285
5286(defun gnus-article-pipe-part (n)
5287 "Pipe MIME part N, which is the numerical prefix."
01c52d31 5288 (interactive "P")
16409b0b
GM		 5289 (gnus-article-part-wrapper n 'mm-pipe-part))
5290
5291(defun gnus-article-save-part (n)
5292 "Save MIME part N, which is the numerical prefix."
01c52d31 5293 (interactive "P")
16409b0b
GM		 5294 (gnus-article-part-wrapper n 'mm-save-part))
5295
5296(defun gnus-article-interactively-view-part (n)
5297 "View MIME part N interactively, which is the numerical prefix."
01c52d31 5298 (interactive "P")
16409b0b
GM		 5299 (gnus-article-part-wrapper n 'mm-interactively-view-part))
5300
5301(defun gnus-article-copy-part (n)
5302 "Copy MIME part N, which is the numerical prefix."
01c52d31 5303 (interactive "P")
16409b0b
GM		 5304 (gnus-article-part-wrapper n 'gnus-mime-copy-part))
5305
23f87bed
MB		 5306(defun gnus-article-view-part-as-charset (n)
5307 "View MIME part N using a specified charset.
5308N is the numerical prefix."
01c52d31 5309 (interactive "P")
23f87bed
MB		 5310 (gnus-article-part-wrapper n 'gnus-mime-view-part-as-charset))
5311
5312(defun gnus-article-view-part-externally (n)
16409b0b 5313 "View MIME part N externally, which is the numerical prefix."
01c52d31 5314 (interactive "P")
23f87bed 5315 (gnus-article-part-wrapper n 'gnus-mime-view-part-externally))
16409b0b
GM		 5316
5317(defun gnus-article-inline-part (n)
5318 "Inline MIME part N, which is the numerical prefix."
01c52d31 5319 (interactive "P")
16409b0b
GM		 5320 (gnus-article-part-wrapper n 'gnus-mime-inline-part))
5321
01c52d31
MB		 5322(defun gnus-article-save-part-and-strip (n)
5323 "Save MIME part N and replace it with an external body.
5324N is the numerical prefix."
5325 (interactive "P")
5326 (gnus-article-part-wrapper n 'gnus-mime-save-part-and-strip t))
5327
5328(defun gnus-article-replace-part (n)
5329 "Replace MIME part N with an external body.
5330N is the numerical prefix."
5331 (interactive "P")
5332 (gnus-article-part-wrapper n 'gnus-mime-replace-part t t))
5333
5334(defun gnus-article-delete-part (n)
5335 "Delete MIME part N and add some information about the removed part.
5336N is the numerical prefix."
5337 (interactive "P")
5338 (gnus-article-part-wrapper n 'gnus-mime-delete-part t))
5339
5340(defun gnus-article-view-part-as-type (n)
5341 "Choose a MIME media type, and view part N as such.
5342N is the numerical prefix."
5343 (interactive "P")
5344 (gnus-article-part-wrapper n 'gnus-mime-view-part-as-type t))
5345
16409b0b
GM		 5346(defun gnus-article-mime-match-handle-first (condition)
5347 (if condition
01c52d31
MB		 5348 (let (n)
5349 (dolist (ihandle gnus-article-mime-handle-alist)
a1506d29 5350 (if (and (cond
16409b0b
GM		 5351 ((functionp condition)
5352 (funcall condition (cdr ihandle)))
a1506d29 5353 ((eq condition 'undisplayed)
16409b0b
GM		 5354 (not (or (mm-handle-undisplayer (cdr ihandle))
5355 (equal (mm-handle-media-type (cdr ihandle))
5356 "multipart/alternative"))))
5357 ((eq condition 'undisplayed-alternative)
5358 (not (mm-handle-undisplayer (cdr ihandle))))
5359 (t t))
5360 (gnus-article-goto-part (car ihandle))
5361 (or (not n) (< (car ihandle) n)))
5362 (setq n (car ihandle))))
5363 (or n 1))
5364 1))
5365
5366(defun gnus-article-view-part (&optional n)
5367 "View MIME part N, which is the numerical prefix."
5368 (interactive "P")
01c52d31 5369 (with-current-buffer gnus-article-buffer
a1506d29 5370 (or (numberp n) (setq n (gnus-article-mime-match-handle-first
16409b0b
GM		 5371 gnus-article-mime-match-handle-function)))
5372 (when (> n (length gnus-article-mime-handle-alist))
5373 (error "No such part"))
5374 (let ((handle (cdr (assq n gnus-article-mime-handle-alist))))
5375 (when (gnus-article-goto-part n)
5376 (if (equal (car handle) "multipart/alternative")
5377 (gnus-article-press-button)
5378 (when (eq (gnus-mm-display-part handle) 'internal)
5379 (gnus-set-window-start)))))))
5380
e0bad764
DL		 5381(defsubst gnus-article-mime-total-parts ()
5382 (if (bufferp (car gnus-article-mime-handles))
5383 1 ;; single part
5384 (1- (length gnus-article-mime-handles))))
5385
16409b0b
GM		 5386(defun gnus-mm-display-part (handle)
5387 "Display HANDLE and fix MIME button."
5388 (let ((id (get-text-property (point) 'gnus-part))
5389 (point (point))
23f87bed 5390 (inhibit-read-only t))
16409b0b
GM		 5391 (forward-line 1)
5392 (prog1
5393 (let ((window (selected-window))
5394 (mail-parse-charset gnus-newsgroup-charset)
a1506d29 5395 (mail-parse-ignored-charsets
23f87bed 5396 (if (gnus-buffer-live-p gnus-summary-buffer)
01c52d31 5397 (with-current-buffer gnus-summary-buffer
23f87bed
MB		 5398 gnus-newsgroup-ignored-charsets)
5399 nil)))
16409b0b
GM		 5400 (save-excursion
5401 (unwind-protect
23f87bed 5402 (let ((win (gnus-get-buffer-window (current-buffer) t))
16409b0b
GM		 5403 (beg (point)))
5404 (when win
5405 (select-window win))
5406 (goto-char point)
5407 (forward-line)
5408 (if (mm-handle-displayed-p handle)
5409 ;; This will remove the part.
5410 (mm-display-part handle)
5411 (save-restriction
23f87bed
MB		 5412 (narrow-to-region (point)
5413 (if (eobp) (point) (1+ (point))))
16409b0b
GM		 5414 (mm-display-part handle)
5415 ;; We narrow to the part itself and
5416 ;; then call the treatment functions.
5417 (goto-char (point-min))
5418 (forward-line 1)
5419 (narrow-to-region (point) (point-max))
5420 (gnus-treat-article
5421 nil id
e0bad764 5422 (gnus-article-mime-total-parts)
16409b0b 5423 (mm-handle-media-type handle)))))
23f87bed
MB		 5424 (if (window-live-p window)
5425 (select-window window)))))
16409b0b 5426 (goto-char point)
23f87bed 5427 (gnus-delete-line)
16409b0b
GM		 5428 (gnus-insert-mime-button
5429 handle id (list (mm-handle-displayed-p handle)))
5430 (goto-char point))))
5431
5432(defun gnus-article-goto-part (n)
5433 "Go to MIME part N."
23f87bed 5434 (gnus-goto-char (text-property-any (point-min) (point-max) 'gnus-part n)))
16409b0b
GM		 5435
5436(defun gnus-insert-mime-button (handle gnus-tmp-id &optional displayed)
5437 (let ((gnus-tmp-name
23f87bed
MB		 5438 (or (mail-content-type-get (mm-handle-type handle) 'name)
5439 (mail-content-type-get (mm-handle-disposition handle) 'filename)
5440 (mail-content-type-get (mm-handle-type handle) 'url)
16409b0b
GM		 5441 ""))
5442 (gnus-tmp-type (mm-handle-media-type handle))
4599d0ec 5443 (gnus-tmp-description (or (mm-handle-description handle) ""))
16409b0b
GM		 5444 (gnus-tmp-dots
5445 (if (if displayed (car displayed)
5446 (mm-handle-displayed-p handle))
5447 "" "..."))
5448 (gnus-tmp-length (with-current-buffer (mm-handle-buffer handle)
5449 (buffer-size)))
5450 gnus-tmp-type-long b e)
5451 (when (string-match ".*/" gnus-tmp-name)
5452 (setq gnus-tmp-name (replace-match "" t t gnus-tmp-name)))
5453 (setq gnus-tmp-type-long (concat gnus-tmp-type
5454 (and (not (equal gnus-tmp-name ""))
5455 (concat "; " gnus-tmp-name))))
23f87bed
MB		 5456 (unless (equal gnus-tmp-description "")
5457 (setq gnus-tmp-type-long (concat " --- " gnus-tmp-type-long)))
16409b0b
GM		 5458 (unless (bolp)
5459 (insert "\n"))
5460 (setq b (point))
5461 (gnus-eval-format
5462 gnus-mime-button-line-format gnus-mime-button-line-format-alist
01c52d31
MB		 5463 `(keymap ,gnus-mime-button-map
5464 gnus-callback gnus-mm-display-part
5465 gnus-part ,gnus-tmp-id
5466 article-type annotation
5467 gnus-data ,handle))
23f87bed
MB		 5468 (setq e (if (bolp)
5469 ;; Exclude a newline.
5470 (1- (point))
5471 (point)))
01c52d31
MB		 5472 (when gnus-article-button-face
5473 (gnus-overlay-put (gnus-make-overlay b e nil t)
5474 'face gnus-article-button-face))
16409b0b
GM		 5475 (widget-convert-button
5476 'link b e
5477 :mime-handle handle
5478 :action 'gnus-widget-press-button
5479 :button-keymap gnus-mime-button-map
5480 :help-echo
5481 (lambda (widget/window &optional overlay pos)
5482 ;; Needed to properly clear the message due to a bug in
5483 ;; wid-edit (XEmacs only).
5484 (if (boundp 'help-echo-owns-message)
5485 (setq help-echo-owns-message t))
5486 (format
5487 "%S: %s the MIME part; %S: more options"
5488 (aref gnus-mouse-2 0)
5489 ;; XEmacs will get a single widget arg; Emacs 21 will get
5490 ;; window, overlay, position.
5491 (if (mm-handle-displayed-p
5492 (if overlay
e0bad764
DL		 5493 (with-current-buffer (gnus-overlay-buffer overlay)
5494 (widget-get (widget-at (gnus-overlay-start overlay))
16409b0b
GM		 5495 :mime-handle))
5496 (widget-get widget/window :mime-handle)))
5497 "hide" "show")
5498 (aref gnus-down-mouse-3 0))))))
5499
5500(defun gnus-widget-press-button (elems el)
5501 (goto-char (widget-get elems :from))
5502 (gnus-article-press-button))
5503
5504(defvar gnus-displaying-mime nil)
5505
5506(defun gnus-display-mime (&optional ihandles)
5507 "Display the MIME parts."
5508 (save-excursion
5509 (save-selected-window
5510 (let ((window (get-buffer-window gnus-article-buffer))
5511 (point (point)))
5512 (when window
5513 (select-window window)
5514 ;; We have to do this since selecting the window
5515 ;; may change the point. So we set the window point.
5516 (set-window-point window point)))
73043f7d
MB		 5517 (let ((handles ihandles)
5518 (inhibit-read-only t)
5519 handle)
5520 (cond (handles)
5521 ((setq handles (mm-dissect-buffer nil gnus-article-loose-mime))
5522 (when gnus-article-emulate-mime
5523 (mm-uu-dissect-text-parts handles)))
5524 (gnus-article-emulate-mime
5525 (setq handles (mm-uu-dissect))))
16409b0b
GM		 5526 (when (and (not ihandles)
5527 (not gnus-displaying-mime))
5528 ;; Top-level call; we clean up.
5529 (when gnus-article-mime-handles
5530 (mm-destroy-parts gnus-article-mime-handles)
5531 (setq gnus-article-mime-handle-alist nil));; A trick.
5532 (setq gnus-article-mime-handles handles)
5533 ;; We allow users to glean info from the handles.
5534 (when gnus-article-mime-part-function
5535 (gnus-mime-part-function handles)))
5536 (if (and handles
5537 (or (not (stringp (car handles)))
5538 (cdr handles)))
5539 (progn
5540 (when (and (not ihandles)
5541 (not gnus-displaying-mime))
5542 ;; Clean up for mime parts.
5543 (article-goto-body)
5544 (delete-region (point) (point-max)))
5545 (let ((gnus-displaying-mime t))
5546 (gnus-mime-display-part handles)))
5547 (save-restriction
5548 (article-goto-body)
5549 (narrow-to-region (point) (point-max))
5550 (gnus-treat-article nil 1 1)
5551 (widen)))
5552 (unless ihandles
5553 ;; Highlight the headers.
5554 (save-excursion
5555 (save-restriction
5556 (article-goto-body)
5557 (narrow-to-region (point-min) (point))
31640842 5558 (gnus-article-save-original-date
f362b760
MB		 5559 (gnus-treat-article 'head)))))))
5560 ;; Cope with broken MIME messages.
5561 (goto-char (point-max))
5562 (unless (bolp)
5563 (insert "\n"))))
16409b0b 5564
23f87bed
MB		 5565(defcustom gnus-mime-display-multipart-as-mixed nil
5566 "Display \"multipart\" parts as \"multipart/mixed\".
5567
5568If t, it overrides nil values of
5569`gnus-mime-display-multipart-alternative-as-mixed' and
5570`gnus-mime-display-multipart-related-as-mixed'."
5571 :group 'gnus-article-mime
5572 :type 'boolean)
5573
5574(defcustom gnus-mime-display-multipart-alternative-as-mixed nil
5575 "Display \"multipart/alternative\" parts as \"multipart/mixed\"."
bf247b6e 5576 :version "22.1"
23f87bed
MB		 5577 :group 'gnus-article-mime
5578 :type 'boolean)
5579
5580(defcustom gnus-mime-display-multipart-related-as-mixed nil
5581 "Display \"multipart/related\" parts as \"multipart/mixed\".
5582
5583If displaying \"text/html\" is discouraged \(see
5584`mm-discouraged-alternatives'\) images or other material inside a
5585\"multipart/related\" part might be overlooked when this variable is nil."
bf247b6e 5586 :version "22.1"
23f87bed
MB		 5587 :group 'gnus-article-mime
5588 :type 'boolean)
16409b0b
GM		 5589
5590(defun gnus-mime-display-part (handle)
5591 (cond
430d3ed7
MB		 5592 ;; Maybe a broken MIME message.
5593 ((null handle))
16409b0b
GM		 5594 ;; Single part.
5595 ((not (stringp (car handle)))
5596 (gnus-mime-display-single handle))
5597 ;; User-defined multipart
5598 ((cdr (assoc (car handle) gnus-mime-multipart-functions))
5599 (funcall (cdr (assoc (car handle) gnus-mime-multipart-functions))
5600 handle))
5601 ;; multipart/alternative
5602 ((and (equal (car handle) "multipart/alternative")
23f87bed
MB		 5603 (not (or gnus-mime-display-multipart-as-mixed
5604 gnus-mime-display-multipart-alternative-as-mixed)))
16409b0b
GM		 5605 (let ((id (1+ (length gnus-article-mime-handle-alist))))
5606 (push (cons id handle) gnus-article-mime-handle-alist)
5607 (gnus-mime-display-alternative (cdr handle) nil nil id)))
5608 ;; multipart/related
5609 ((and (equal (car handle) "multipart/related")
23f87bed
MB		 5610 (not (or gnus-mime-display-multipart-as-mixed
5611 gnus-mime-display-multipart-related-as-mixed)))
16409b0b
GM		 5612 ;;;!!!We should find the start part, but we just default
5613 ;;;!!!to the first part.
23f87bed
MB		 5614 ;;(gnus-mime-display-part (cadr handle))
5615 ;;;!!! Most multipart/related is an HTML message plus images.
5616 ;;;!!! Unfortunately we are unable to let W3 display those
5617 ;;;!!! included images, so we just display it as a mixed multipart.
5618 ;;(gnus-mime-display-mixed (cdr handle))
5619 ;;;!!! No, w3 can display everything just fine.
16409b0b 5620 (gnus-mime-display-part (cadr handle)))
23f87bed
MB		 5621 ((equal (car handle) "multipart/signed")
5622 (gnus-add-wash-type 'signed)
5623 (gnus-mime-display-security handle))
5624 ((equal (car handle) "multipart/encrypted")
5625 (gnus-add-wash-type 'encrypted)
5626 (gnus-mime-display-security handle))
16409b0b
GM		 5627 ;; Other multiparts are handled like multipart/mixed.
5628 (t
5629 (gnus-mime-display-mixed (cdr handle)))))
5630
5631(defun gnus-mime-part-function (handles)
5632 (if (stringp (car handles))
5633 (mapcar 'gnus-mime-part-function (cdr handles))
5634 (funcall gnus-article-mime-part-function handles)))
5635
5636(defun gnus-mime-display-mixed (handles)
5637 (mapcar 'gnus-mime-display-part handles))
5638
5639(defun gnus-mime-display-single (handle)
5640 (let ((type (mm-handle-media-type handle))
5641 (ignored gnus-ignored-mime-types)
5642 (not-attachment t)
5643 (move nil)
5644 display text)
5645 (catch 'ignored
5646 (progn
5647 (while ignored
5648 (when (string-match (pop ignored) type)
5649 (throw 'ignored nil)))
5650 (if (and (setq not-attachment
5651 (and (not (mm-inline-override-p handle))
5652 (or (not (mm-handle-disposition handle))
5653 (equal (car (mm-handle-disposition handle))
5654 "inline")
5655 (mm-attachment-override-p handle))))
5656 (mm-automatic-display-p handle)
23f87bed
MB		 5657 (or (and
5658 (mm-inlinable-p handle)
5659 (mm-inlined-p handle))
16409b0b
GM		 5660 (mm-automatic-external-display-p type)))
5661 (setq display t)
5662 (when (equal (mm-handle-media-supertype handle) "text")
5663 (setq text t)))
e0bad764
DL		 5664 (let ((id (1+ (length gnus-article-mime-handle-alist)))
5665 beg)
16409b0b 5666 (push (cons id handle) gnus-article-mime-handle-alist)
531bedc3
MB		 5667 (when (and display
5668 (equal (mm-handle-media-supertype handle) "message"))
5669 (insert-char
5670 ?\n
5671 (cond ((not (bolp)) 2)
5672 ((or (bobp) (eq (char-before (1- (point))) ?\n)) 0)
5673 (t 1))))
16409b0b
GM		 5674 (when (or (not display)
5675 (not (gnus-unbuttonized-mime-type-p type)))
16409b0b
GM		 5676 (gnus-insert-mime-button
5677 handle id (list (or display (and not-attachment text))))
5678 (gnus-article-insert-newline)
23f87bed 5679 ;; Remember modify the number of forward lines.
e0bad764
DL		 5680 (setq move t))
5681 (setq beg (point))
16409b0b
GM		 5682 (cond
5683 (display
5684 (when move
23f87bed 5685 (forward-line -1)
16409b0b
GM		 5686 (setq beg (point)))
5687 (let ((mail-parse-charset gnus-newsgroup-charset)
a1506d29 5688 (mail-parse-ignored-charsets
16409b0b
GM		 5689 (save-excursion (condition-case ()
5690 (set-buffer gnus-summary-buffer)
5691 (error))
5692 gnus-newsgroup-ignored-charsets)))
5693 (mm-display-part handle t))
5694 (goto-char (point-max)))
5695 ((and text not-attachment)
5696 (when move
23f87bed 5697 (forward-line -1)
16409b0b
GM		 5698 (setq beg (point)))
5699 (gnus-article-insert-newline)
53cfefc8
MB		 5700 (mm-insert-inline
5701 handle
01c52d31
MB		 5702 (let ((charset (or (mail-content-type-get (mm-handle-type handle)
5703 'charset)
5704 (and (equal type "text/calendar") 'utf-8))))
53cfefc8
MB		 5705 (cond ((not charset)
5706 (mm-string-as-multibyte (mm-get-part handle)))
5707 ((eq charset 'gnus-decoded)
5708 (with-current-buffer (mm-handle-buffer handle)
5709 (buffer-string)))
5710 (t
5711 (mm-decode-string (mm-get-part handle) charset)))))
16409b0b
GM		 5712 (goto-char (point-max))))
5713 ;; Do highlighting.
5714 (save-excursion
5715 (save-restriction
5716 (narrow-to-region beg (point))
01c52d31
MB		 5717 (if (eq handle gnus-article-mime-handles)
5718 ;; The format=flowed case.
5719 (gnus-treat-article nil 1 1 (mm-handle-media-type handle))
5720 ;; Don't count signature parts that are never displayed.
5721 ;; The part number should be re-calculated supposing this
5722 ;; might be a message/rfc822 part.
5723 (let (handles)
5724 (dolist (part gnus-article-mime-handles)
5725 (unless (or (stringp part)
5726 (equal (car (mm-handle-type part))
5727 "application/pgp-signature"))
5728 (push part handles)))
5729 (gnus-treat-article
5730 nil (length (memq handle handles)) (length handles)
5731 (mm-handle-media-type handle)))))))))))
16409b0b
GM		 5732
5733(defun gnus-unbuttonized-mime-type-p (type)
5734 "Say whether TYPE is to be unbuttonized."
5735 (unless gnus-inhibit-mime-unbuttonizing
23f87bed
MB		 5736 (when (catch 'found
5737 (let ((types gnus-unbuttonized-mime-types))
5738 (while types
5739 (when (string-match (pop types) type)
5740 (throw 'found t)))))
5741 (not (catch 'found
5742 (let ((types gnus-buttonized-mime-types))
5743 (while types
5744 (when (string-match (pop types) type)
5745 (throw 'found t)))))))))
16409b0b
GM		 5746
5747(defun gnus-article-insert-newline ()
5748 "Insert a newline, but mark it as undeletable."
5749 (gnus-put-text-property
5750 (point) (progn (insert "\n") (point)) 'gnus-undeletable t))
5751
5752(defun gnus-mime-display-alternative (handles &optional preferred ibegend id)
5753 (let* ((preferred (or preferred (mm-preferred-alternative handles)))
5754 (ihandles handles)
5755 (point (point))
23f87bed 5756 handle (inhibit-read-only t) from props begend not-pref)
16409b0b
GM		 5757 (save-window-excursion
5758 (save-restriction
5759 (when ibegend
5760 (narrow-to-region (car ibegend)
5761 (or (cdr ibegend)
5762 (progn
5763 (goto-char (car ibegend))
5764 (forward-line 2)
5765 (point))))
5766 (delete-region (point-min) (point-max))
5767 (mm-remove-parts handles))
5768 (setq begend (list (point-marker)))
5769 ;; Do the toggle.
5770 (unless (setq not-pref (cadr (member preferred ihandles)))
5771 (setq not-pref (car ihandles)))
5772 (when (or ibegend
23f87bed 5773 (not preferred)
16409b0b
GM		 5774 (not (gnus-unbuttonized-mime-type-p
5775 "multipart/alternative")))
5776 (gnus-add-text-properties
5777 (setq from (point))
5778 (progn
5779 (insert (format "%d. " id))
5780 (point))
5781 `(gnus-callback
5782 (lambda (handles)
5783 (unless ,(not ibegend)
5784 (setq gnus-article-mime-handle-alist
5785 ',gnus-article-mime-handle-alist))
5786 (gnus-mime-display-alternative
5787 ',ihandles ',not-pref ',begend ,id))
01c52d31 5788 keymap ,gnus-mime-button-map
16409b0b
GM		 5789 ,gnus-mouse-face-prop ,gnus-article-mouse-face
5790 face ,gnus-article-button-face
16409b0b 5791 gnus-part ,id
7dafe00b 5792 article-type multipart))
16409b0b
GM		 5793 (widget-convert-button 'link from (point)
5794 :action 'gnus-widget-press-button
5795 :button-keymap gnus-widget-button-keymap)
5796 ;; Do the handles
5797 (while (setq handle (pop handles))
5798 (gnus-add-text-properties
5799 (setq from (point))
5800 (progn
5801 (insert (format "(%c) %-18s"
5802 (if (equal handle preferred) ?* ? )
5803 (mm-handle-media-type handle)))
5804 (point))
5805 `(gnus-callback
5806 (lambda (handles)
5807 (unless ,(not ibegend)
5808 (setq gnus-article-mime-handle-alist
5809 ',gnus-article-mime-handle-alist))
5810 (gnus-mime-display-alternative
5811 ',ihandles ',handle ',begend ,id))
01c52d31 5812 keymap ,gnus-mime-button-map
16409b0b
GM		 5813 ,gnus-mouse-face-prop ,gnus-article-mouse-face
5814 face ,gnus-article-button-face
16409b0b
GM		 5815 gnus-part ,id
5816 gnus-data ,handle))
5817 (widget-convert-button 'link from (point)
5818 :action 'gnus-widget-press-button
5819 :button-keymap gnus-widget-button-keymap)
5820 (insert " "))
5821 (insert "\n\n"))
5822 (when preferred
5823 (if (stringp (car preferred))
5824 (gnus-display-mime preferred)
5825 (let ((mail-parse-charset gnus-newsgroup-charset)
a1506d29 5826 (mail-parse-ignored-charsets
01c52d31
MB		 5827 (with-current-buffer gnus-summary-buffer
5828 gnus-newsgroup-ignored-charsets)))
16409b0b
GM		 5829 (mm-display-part preferred)
5830 ;; Do highlighting.
5831 (save-excursion
5832 (save-restriction
5833 (narrow-to-region (car begend) (point-max))
5834 (gnus-treat-article
5835 nil (length gnus-article-mime-handle-alist)
e0bad764 5836 (gnus-article-mime-total-parts)
16409b0b
GM		 5837 (mm-handle-media-type handle))))))
5838 (goto-char (point-max))
5839 (setcdr begend (point-marker)))))
5840 (when ibegend
5841 (goto-char point))))
5842
23f87bed
MB		 5843(defconst gnus-article-wash-status-strings
5844 (let ((alist '((cite "c" "Possible hidden citation text"
5845 " " "All citation text visible")
5846 (headers "h" "Hidden headers"
5847 " " "All headers visible.")
5848 (pgp "p" "Encrypted or signed message status hidden"
5849 " " "No hidden encryption nor digital signature status")
5850 (signature "s" "Signature has been hidden"
5851 " " "Signature is visible")
5852 (overstrike "o" "Overstrike (^H) characters applied"
5853 " " "No overstrike characters applied")
5854 (emphasis "e" "/*_Emphasis_*/ characters applied"
5855 " " "No /*_emphasis_*/ characters applied")))
5856 result)
5857 (dolist (entry alist result)
5858 (let ((key (nth 0 entry))
5859 (on (copy-sequence (nth 1 entry)))
5860 (on-help (nth 2 entry))
5861 (off (copy-sequence (nth 3 entry)))
5862 (off-help (nth 4 entry)))
5863 (put-text-property 0 1 'help-echo on-help on)
5864 (put-text-property 0 1 'help-echo off-help off)
5865 (push (list key on off) result))))
5866 "Alist of strings describing wash status in the mode line.
5867Each entry has the form (KEY ON OF), where the KEY is a symbol
5868representing the particular washing function, ON is the string to use
5869in the article mode line when the washing function is active, and OFF
5870is the string to use when it is inactive.")
5871
5872(defun gnus-article-wash-status-entry (key value)
5873 (let ((entry (assoc key gnus-article-wash-status-strings)))
5874 (if value (nth 1 entry) (nth 2 entry))))
5875
eec82323
LMI		 5876(defun gnus-article-wash-status ()
5877 "Return a string which display status of article washing."
01c52d31 5878 (with-current-buffer gnus-article-buffer
16409b0b
GM		 5879 (let ((cite (memq 'cite gnus-article-wash-types))
5880 (headers (memq 'headers gnus-article-wash-types))
5881 (boring (memq 'boring-headers gnus-article-wash-types))
5882 (pgp (memq 'pgp gnus-article-wash-types))
5883 (pem (memq 'pem gnus-article-wash-types))
23f87bed
MB		 5884 (signed (memq 'signed gnus-article-wash-types))
5885 (encrypted (memq 'encrypted gnus-article-wash-types))
16409b0b
GM		 5886 (signature (memq 'signature gnus-article-wash-types))
5887 (overstrike (memq 'overstrike gnus-article-wash-types))
5888 (emphasis (memq 'emphasis gnus-article-wash-types)))
23f87bed
MB		 5889 (concat
5890 (gnus-article-wash-status-entry 'cite cite)
5891 (gnus-article-wash-status-entry 'headers (or headers boring))
5892 (gnus-article-wash-status-entry 'pgp (or pgp pem signed encrypted))
5893 (gnus-article-wash-status-entry 'signature signature)
5894 (gnus-article-wash-status-entry 'overstrike overstrike)
5895 (gnus-article-wash-status-entry 'emphasis emphasis)))))
5896
5897(defun gnus-add-wash-type (type)
5898 "Add a washing of TYPE to the current status."
5899 (add-to-list 'gnus-article-wash-types type))
5900
5901(defun gnus-delete-wash-type (type)
5902 "Add a washing of TYPE to the current status."
5903 (setq gnus-article-wash-types (delq type gnus-article-wash-types)))
5904
5905(defun gnus-add-image (category image)
5906 "Add IMAGE of CATEGORY to the list of displayed images."
5907 (let ((entry (assq category gnus-article-image-alist)))
5908 (unless entry
5909 (setq entry (list category))
5910 (push entry gnus-article-image-alist))
5911 (nconc entry (list image))))
5912
5913(defun gnus-delete-images (category)
5914 "Delete all images in CATEGORY."
5915 (let ((entry (assq category gnus-article-image-alist)))
5916 (dolist (image (cdr entry))
5917 (gnus-remove-image image category))
5918 (setq gnus-article-image-alist (delq entry gnus-article-image-alist))
5919 (gnus-delete-wash-type category)))
eec82323 5920
16409b0b 5921(defalias 'gnus-article-hide-headers-if-wanted 'gnus-article-maybe-hide-headers)
6748645f
LMI		 5922
5923(defun gnus-article-maybe-hide-headers ()
eec82323
LMI		 5924 "Hide unwanted headers if `gnus-have-all-headers' is nil.
5925Provided for backwards compatibility."
16409b0b 5926 (when (and (or (not (gnus-buffer-live-p gnus-summary-buffer))
01c52d31
MB		 5927 (not (with-current-buffer gnus-summary-buffer
5928 gnus-have-all-headers)))
16409b0b
GM		 5929 (not gnus-inhibit-hiding))
5930 (gnus-article-hide-headers)))
eec82323
LMI		 5931
5932;;; Article savers.
5933
5934(defun gnus-output-to-file (file-name)
26c9afc3
MB		 5935 "Append the current article to a file named FILE-NAME.
5936If `gnus-article-save-coding-system' is non-nil, it is used to encode
5937text and used as the value of the coding cookie which is added to the
5938top of a file. Otherwise, this function saves a raw article without
5939the coding cookie."
5940 (let* ((artbuf (current-buffer))
5941 (file-name-coding-system nnmail-pathname-coding-system)
5942 (coding gnus-article-save-coding-system)
5943 (coding-system-for-read (if coding
5944 nil ;; Rely on the coding cookie.
5945 mm-text-coding-system))
5946 (coding-system-for-write (or coding
5947 mm-text-coding-system-for-write
5948 mm-text-coding-system))
5949 (exists (file-exists-p file-name)))
16409b0b 5950 (with-temp-buffer
26c9afc3
MB		 5951 (when exists
5952 (insert-file-contents file-name)
5953 (goto-char (point-min))
5954 ;; Remove the existing coding cookie.
5955 (when (looking-at "X-Gnus-Coding-System: .+\n\n")
5956 (delete-region (match-beginning 0) (match-end 0))))
5957 (goto-char (point-max))
eec82323
LMI		 5958 (insert-buffer-substring artbuf)
5959 ;; Append newline at end of the buffer as separator, and then
5960 ;; save it to file.
5961 (goto-char (point-max))
5962 (insert "\n")
26c9afc3
MB		 5963 (when coding
5964 ;; If the coding system is not suitable to encode the text,
5965 ;; ask a user for a proper one.
5966 (when (fboundp 'select-safe-coding-system)
5967 (setq coding (coding-system-base
5968 (save-window-excursion
5969 (select-safe-coding-system (point-min) (point-max)
5970 coding))))
5971 (setq coding-system-for-write
5972 (or (cdr (assq coding '((mule-utf-8 . utf-8))))
5973 coding)))
5974 (goto-char (point-min))
5975 ;; Add the coding cookie.
5976 (insert (format "X-Gnus-Coding-System: -*- coding: %s; -*-\n\n"
5977 coding-system-for-write)))
5978 (if exists
5979 (progn
5980 (write-region (point-min) (point-max) file-name nil 'no-message)
5981 (message "Appended to %s" file-name))
5982 (write-region (point-min) (point-max) file-name))))
5983 t)
eec82323
LMI		 5984
5985(defun gnus-narrow-to-page (&optional arg)
5986 "Narrow the article buffer to a page.
5987If given a numerical ARG, move forward ARG pages."
5988 (interactive "P")
5989 (setq arg (if arg (prefix-numeric-value arg) 0))
80de1778 5990 (with-current-buffer gnus-article-buffer
eec82323
LMI		 5991 (widen)
5992 ;; Remove any old next/prev buttons.
5993 (when (gnus-visual-p 'page-marker)
4e7d0221 5994 (let ((inhibit-read-only t))
eec82323
LMI		 5995 (gnus-remove-text-with-property 'gnus-prev)
5996 (gnus-remove-text-with-property 'gnus-next)))
8f7abae3
MB		 5997 (let (st nd pt)
5998 (when (save-excursion
5999 (cond ((< arg 0)
6000 (if (re-search-backward page-delimiter nil 'move (abs arg))
6001 (prog1
6002 (setq nd (match-beginning 0)
6003 pt nd)
6004 (when (re-search-backward page-delimiter nil t)
6005 (setq st (match-end 0))))
6006 (when (re-search-forward page-delimiter nil t)
6007 (setq nd (match-beginning 0)
6008 pt (point-min)))))
6009 ((> arg 0)
6010 (if (re-search-forward page-delimiter nil 'move arg)
6011 (prog1
6012 (setq st (match-end 0)
6013 pt st)
6014 (when (re-search-forward page-delimiter nil t)
6015 (setq nd (match-beginning 0))))
6016 (when (re-search-backward page-delimiter nil t)
6017 (setq st (match-end 0)
6018 pt (point-max)))))
6019 (t
6020 (when (re-search-backward page-delimiter nil t)
6021 (goto-char (setq st (match-end 0))))
6022 (when (re-search-forward page-delimiter nil t)
6023 (setq nd (match-beginning 0)))
6024 (or st nd))))
6025 (setq gnus-page-broken t)
6026 (when pt (goto-char pt))
6027 (narrow-to-region (or st (point-min)) (or nd (point-max)))
6028 (when (gnus-visual-p 'page-marker)
6029 (save-excursion
6030 (when nd
6031 (goto-char nd)
6032 (gnus-insert-next-page-button))
6033 (when st
6034 (goto-char st)
6035 (gnus-insert-prev-page-button))))))))
eec82323
LMI		 6036
6037;; Article mode commands
6038
6039(defun gnus-article-goto-next-page ()
6040 "Show the next page of the article."
6041 (interactive)
6042 (when (gnus-article-next-page)
6043 (goto-char (point-min))
6044 (gnus-article-read-summary-keys nil (gnus-character-to-event ?n))))
6045
23f87bed 6046
eec82323 6047(defun gnus-article-goto-prev-page ()
23f87bed 6048 "Show the previous page of the article."
eec82323 6049 (interactive)
8f7abae3 6050 (if (save-restriction (widen) (bobp)) ;; Real beginning-of-buffer?
23f87bed 6051 (gnus-article-read-summary-keys nil (gnus-character-to-event ?p))
eec82323
LMI		 6052 (gnus-article-prev-page nil)))
6053
23f87bed
MB		 6054;; This is cleaner but currently breaks `gnus-pick-mode':
6055;;
6056;; (defun gnus-article-goto-next-page ()
6057;; "Show the next page of the article."
6058;; (interactive)
6059;; (gnus-eval-in-buffer-window gnus-summary-buffer
6060;; (gnus-summary-next-page)))
6061;;
6062;; (defun gnus-article-goto-prev-page ()
6063;; "Show the next page of the article."
6064;; (interactive)
6065;; (gnus-eval-in-buffer-window gnus-summary-buffer
6066;; (gnus-summary-prev-page)))
6067
eec82323
LMI		 6068(defun gnus-article-next-page (&optional lines)
6069 "Show the next page of the current article.
6070If end of article, return non-nil. Otherwise return nil.
6071Argument LINES specifies lines to be scrolled up."
6072 (interactive "p")
d8a88581 6073 (move-to-window-line -1)
60ece9b0
MB		 6074 (if (and (not (and gnus-article-over-scroll
6075 (> (count-lines (window-start) (point-max))
6076 (+ (or lines (1- (window-height)))
6077 (or (and (boundp 'scroll-margin)
6078 (symbol-value 'scroll-margin))
6079 0)))))
6080 (save-excursion
6081 (end-of-line)
6082 (and (pos-visible-in-window-p) ;Not continuation line.
6083 (>= (1+ (point)) (point-max))))) ;Allow for trailing newline.
eec82323
LMI		 6084 ;; Nothing in this page.
6085 (if (or (not gnus-page-broken)
6086 (save-excursion
6087 (save-restriction
23f87bed
MB		 6088 (widen)
6089 (forward-line)
6090 (eobp)))) ;Real end-of-buffer?
6091 (progn
6092 (when gnus-article-over-scroll
6093 (gnus-article-next-page-1 lines))
6094 t) ;Nothing more.
eec82323
LMI		 6095 (gnus-narrow-to-page 1) ;Go to next page.
6096 nil)
6097 ;; More in this page.
23f87bed 6098 (gnus-article-next-page-1 lines)
eec82323
LMI		 6099 nil))
6100
d8a88581
MB		 6101(defmacro gnus-article-beginning-of-window ()
6102 "Move point to the beginning of the window.
6103In Emacs, the point is placed at the line number which `scroll-margin'
6104specifies."
6105 (if (featurep 'xemacs)
6106 '(move-to-window-line 0)
6107 '(move-to-window-line
6108 (min (max 0 scroll-margin)
6109 (max 1 (- (window-height)
6110 (if mode-line-format 1 0)
01c52d31 6111 (if header-line-format 1 0)))))))
d8a88581 6112
23f87bed 6113(defun gnus-article-next-page-1 (lines)
4b91459a
MB		 6114 (when (and (not (featurep 'xemacs))
6115 (numberp lines)
6116 (> lines 0)
6117 (numberp (symbol-value 'scroll-margin))
6118 (> (symbol-value 'scroll-margin) 0))
6119 ;; Protect against the bug that Emacs 21.x hangs up when scrolling up for
6120 ;; too many number of lines if `scroll-margin' is set as two or greater.
6121 (setq lines (min lines
6122 (max 0 (- (count-lines (window-start) (point-max))
6123 (symbol-value 'scroll-margin))))))
6124 (condition-case ()
6125 (let ((scroll-in-place nil))
6126 (scroll-up lines))
6127 (end-of-buffer
6128 ;; Long lines may cause an end-of-buffer error.
6129 (goto-char (point-max))))
6130 (gnus-article-beginning-of-window))
23f87bed 6131
eec82323
LMI		 6132(defun gnus-article-prev-page (&optional lines)
6133 "Show previous page of current article.
6134Argument LINES specifies lines to be scrolled down."
6135 (interactive "p")
d8a88581 6136 (move-to-window-line 0)
eec82323
LMI		 6137 (if (and gnus-page-broken
6138 (bobp)
6139 (not (save-restriction (widen) (bobp)))) ;Real beginning-of-buffer?
6140 (progn
6141 (gnus-narrow-to-page -1) ;Go to previous page.
6142 (goto-char (point-max))
60ece9b0
MB		 6143 (recenter (if gnus-article-over-scroll
6144 (if lines
6145 (max (+ lines (or (and (boundp 'scroll-margin)
6146 (symbol-value 'scroll-margin))
6147 0))
6148 3)
6149 (- (window-height) 2))
6150 -1)))
c03ac728
MB		 6151 (prog1
6152 (condition-case ()
6153 (let ((scroll-in-place nil))
6154 (scroll-down lines))
6155 (beginning-of-buffer
6156 (goto-char (point-min))))
6157 (gnus-article-beginning-of-window))))
eec82323 6158
23f87bed
MB		 6159(defun gnus-article-only-boring-p ()
6160 "Decide whether there is only boring text remaining in the article.
6161Something \"interesting\" is a word of at least two letters that does
6162not have a face in `gnus-article-boring-faces'."
6163 (when (and gnus-article-skip-boring
6164 (boundp 'gnus-article-boring-faces)
6165 (symbol-value 'gnus-article-boring-faces))
6166 (save-excursion
531bedc3
MB		 6167 (let ((inhibit-point-motion-hooks t))
6168 (catch 'only-boring
6169 (while (re-search-forward "\\b\\w\\w" nil t)
6170 (forward-char -1)
6171 (when (not (gnus-intersection
6172 (gnus-faces-at (point))
6173 (symbol-value 'gnus-article-boring-faces)))
6174 (throw 'only-boring nil)))
6175 (throw 'only-boring t))))))
23f87bed 6176
eec82323
LMI		 6177(defun gnus-article-refer-article ()
6178 "Read article specified by message-id around point."
6179 (interactive)
23f87bed 6180 (save-excursion
01c52d31
MB		 6181 (re-search-backward "[ \t]\\|^" (point-at-bol) t)
6182 (re-search-forward "<?news:<?\\|<" (point-at-eol) t)
6183 (if (re-search-forward "[^@ ]+@[^ \t>]+" (point-at-eol) t)
23f87bed 6184 (let ((msg-id (concat "<" (match-string 0) ">")))
eec82323 6185 (set-buffer gnus-summary-buffer)
23f87bed 6186 (gnus-summary-refer-article msg-id))
eec82323
LMI		 6187 (error "No references around point"))))
6188
6189(defun gnus-article-show-summary ()
6190 "Reconfigure windows to show summary buffer."
6191 (interactive)
6192 (if (not (gnus-buffer-live-p gnus-summary-buffer))
6193 (error "There is no summary buffer for this article buffer")
a8151ef7 6194 (gnus-article-set-globals)
eec82323 6195 (gnus-configure-windows 'article)
6748645f
LMI		 6196 (gnus-summary-goto-subject gnus-current-article)
6197 (gnus-summary-position-point)))
eec82323
LMI		 6198
6199(defun gnus-article-describe-briefly ()
6200 "Describe article mode commands briefly."
6201 (interactive)
16409b0b 6202 (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		 6203
6204(defun gnus-article-summary-command ()
6205 "Execute the last keystroke in the summary buffer."
6206 (interactive)
6207 (let ((obuf (current-buffer))
6208 (owin (current-window-configuration))
6209 func)
6748645f 6210 (switch-to-buffer gnus-article-current-summary 'norecord)
eec82323
LMI		 6211 (setq func (lookup-key (current-local-map) (this-command-keys)))
6212 (call-interactively func)
6213 (set-buffer obuf)
6214 (set-window-configuration owin)
6215 (set-window-point (get-buffer-window (current-buffer)) (point))))
6216
6217(defun gnus-article-summary-command-nosave ()
6218 "Execute the last keystroke in the summary buffer."
6219 (interactive)
6220 (let (func)
bdaf8a62 6221 (pop-to-buffer gnus-article-current-summary)
eec82323
LMI		 6222 (setq func (lookup-key (current-local-map) (this-command-keys)))
6223 (call-interactively func)))
6224
16409b0b
GM		 6225(defun gnus-article-check-buffer ()
6226 "Beep if not in an article buffer."
6227 (unless (equal major-mode 'gnus-article-mode)
6228 (error "Command invoked outside of a Gnus article buffer")))
6229
eec82323
LMI		 6230(defun gnus-article-read-summary-keys (&optional arg key not-restore-window)
6231 "Read a summary buffer key sequence and execute it from the article buffer."
6232 (interactive "P")
16409b0b 6233 (gnus-article-check-buffer)
eec82323 6234 (let ((nosaves
23f87bed
MB		 6235 '("q" "Q" "c" "r" "\C-c\C-f" "m" "a" "f"
6236 "Zc" "ZC" "ZE" "ZQ" "ZZ" "Zn" "ZR" "ZG" "ZN" "ZP"
6237 "=" "^" "\M-^" "|"))
6238 (nosave-but-article
0b6799c3
MB		 6239 '("A " "A<" "A>" "AM" "AP" "AR" "AT" "A\C-?" "A\M-\r" "A\r" "Ab" "Ae"
6240 "An" "Ap" [?A (meta return)] [?A delete]))
23f87bed 6241 (nosave-in-article
0b6799c3 6242 '("AS" "\C-d"))
23f87bed
MB		 6243 (up-to-top
6244 '("n" "Gn" "p" "Gp"))
6245 keys new-sum-point)
80de1778 6246 (with-current-buffer gnus-article-current-summary
eec82323 6247 (let (gnus-pick-mode)
95838435
MB		 6248 (setq unread-command-events (nconc unread-command-events
6249 (list (or key last-command-event)))
6250 keys (if (featurep 'xemacs)
6251 (events-to-keys (read-key-sequence nil t))
6252 (read-key-sequence nil t)))))
a1506d29 6253
eec82323
LMI		 6254 (message "")
6255
01c52d31
MB		 6256 (cond
6257 ((eq (aref keys (1- (length keys))) ?\C-h)
0b6799c3 6258 (gnus-article-describe-bindings (substring keys 0 -1)))
01c52d31
MB		 6259 ((or (member keys nosaves)
6260 (member keys nosave-but-article)
6261 (member keys nosave-in-article))
6262 (let (func)
6263 (save-window-excursion
6264 (pop-to-buffer gnus-article-current-summary)
6265 ;; We disable the pick minor mode commands.
6266 (let (gnus-pick-mode)
6267 (setq func (lookup-key (current-local-map) keys))))
6268 (if (or (not func)
6269 (numberp func))
6270 (ding)
6271 (unless (member keys nosave-in-article)
6272 (set-buffer gnus-article-current-summary))
6273 (call-interactively func)
6274 (setq new-sum-point (point)))
6275 (when (member keys nosave-but-article)
6276 (pop-to-buffer gnus-article-buffer))))
6277 (t
eec82323
LMI		 6278 ;; These commands should restore window configuration.
6279 (let ((obuf (current-buffer))
23f87bed 6280 (owin (current-window-configuration))
01c52d31 6281 win func in-buffer selected new-sum-start new-sum-hscroll err)
23f87bed 6282 (cond (not-restore-window
01c52d31
MB		 6283 (pop-to-buffer gnus-article-current-summary)
6284 (setq win (selected-window)))
23f87bed
MB		 6285 ((setq win (get-buffer-window gnus-article-current-summary))
6286 (select-window win))
6287 (t
01c52d31
MB		 6288 (let ((summary-buffer gnus-article-current-summary))
6289 (gnus-configure-windows 'article)
6290 (unless (setq win (get-buffer-window summary-buffer 'visible))
6291 (let ((gnus-buffer-configuration
6292 '(article ((vertical 1.0
6293 (summary 0.25 point)
6294 (article 1.0))))))
6295 (gnus-configure-windows 'article))
6296 (setq win (get-buffer-window summary-buffer 'visible)))
6297 (gnus-select-frame-set-input-focus (window-frame win))
6298 (select-window win))))
23f87bed
MB		 6299 (setq in-buffer (current-buffer))
6300 ;; We disable the pick minor mode commands.
6301 (if (and (setq func (let (gnus-pick-mode)
520aa572 6302 (lookup-key (current-local-map) keys)))
01c52d31
MB		 6303 (functionp func)
6304 (condition-case code
6305 (progn
6306 (call-interactively func)
6307 t)
6308 (error
6309 (setq err code)
6310 nil)))
23f87bed 6311 (progn
23f87bed
MB		 6312 (when (eq win (selected-window))
6313 (setq new-sum-point (point)
6314 new-sum-start (window-start win)
9a89f5b0 6315 new-sum-hscroll (window-hscroll win)))
01c52d31
MB		 6316 (when (or (eq in-buffer (current-buffer))
6317 (when (eq obuf (current-buffer))
6318 (set-buffer in-buffer)
6319 t))
520aa572
SZ		 6320 (setq selected (gnus-summary-select-article))
6321 (set-buffer obuf)
6322 (unless not-restore-window
6323 (set-window-configuration owin))
01c52d31
MB		 6324 (when (and (eq selected 'old)
6325 new-sum-point)
520aa572
SZ		 6326 (set-window-start (get-buffer-window (current-buffer))
6327 1)
6328 (set-window-point (get-buffer-window (current-buffer))
01c52d31
MB		 6329 (if (article-goto-body)
6330 (1- (point))
6331 (point))))
23f87bed 6332 (when (and (not not-restore-window)
01c52d31
MB		 6333 new-sum-point
6334 (with-current-buffer (window-buffer win)
6335 (eq major-mode 'gnus-summary-mode)))
23f87bed
MB		 6336 (set-window-point win new-sum-point)
6337 (set-window-start win new-sum-start)
9a89f5b0 6338 (set-window-hscroll win new-sum-hscroll))))
23f87bed 6339 (set-window-configuration owin)
01c52d31
MB		 6340 (if err
6341 (signal (car err) (cdr err))
6342 (ding))))))))
520aa572 6343
95838435
MB		 6344(defun gnus-article-read-summary-send-keys ()
6345 (interactive)
0b6799c3 6346 (let ((unread-command-events (list (gnus-character-to-event ?S))))
95838435
MB		 6347 (gnus-article-read-summary-keys)))
6348
520aa572 6349(defun gnus-article-describe-key (key)
95838435
MB		 6350 "Display documentation of the function invoked by KEY.
6351KEY is a string or a vector."
6352 (interactive (list (let ((cursor-in-echo-area t)) ;; better for XEmacs.
6353 (read-key-sequence "Describe key: "))))
520aa572 6354 (gnus-article-check-buffer)
95838435
MB		 6355 (if (memq (key-binding key t) '(gnus-article-read-summary-keys
6356 gnus-article-read-summary-send-keys))
80de1778 6357 (with-current-buffer gnus-article-current-summary
95838435
MB		 6358 (setq unread-command-events
6359 (if (featurep 'xemacs)
6360 (append key nil)
6361 (mapcar (lambda (x) (if (and (integerp x) (>= x 128))
6362 (list 'meta (- x 128))
6363 x))
6364 key)))
6365 (let ((cursor-in-echo-area t)
6366 gnus-pick-mode)
6367 (describe-key (read-key-sequence nil t))))
520aa572
SZ		 6368 (describe-key key)))
6369
6370(defun gnus-article-describe-key-briefly (key &optional insert)
95838435
MB		 6371 "Display documentation of the function invoked by KEY.
6372KEY is a string or a vector."
6373 (interactive (list (let ((cursor-in-echo-area t)) ;; better for XEmacs.
6374 (read-key-sequence "Describe key: "))
6375 current-prefix-arg))
520aa572 6376 (gnus-article-check-buffer)
95838435
MB		 6377 (if (memq (key-binding key t) '(gnus-article-read-summary-keys
6378 gnus-article-read-summary-send-keys))
80de1778 6379 (with-current-buffer gnus-article-current-summary
95838435
MB		 6380 (setq unread-command-events
6381 (if (featurep 'xemacs)
6382 (append key nil)
6383 (mapcar (lambda (x) (if (and (integerp x) (>= x 128))
6384 (list 'meta (- x 128))
6385 x))
6386 key)))
6387 (let ((cursor-in-echo-area t)
6388 gnus-pick-mode)
6389 (describe-key-briefly (read-key-sequence nil t) insert)))
520aa572 6390 (describe-key-briefly key insert)))
eec82323 6391
0b6799c3
MB		 6392;;`gnus-agent-mode' in gnus-agent.el will define it.
6393(defvar gnus-agent-summary-mode)
e9198520 6394(defvar gnus-draft-mode)
0b6799c3
MB		 6395
6396(defun gnus-article-describe-bindings (&optional prefix)
6397 "Show a list of all defined keys, and their definitions.
6398The optional argument PREFIX, if non-nil, should be a key sequence;
6399then we display only bindings that start with that prefix."
6400 (interactive)
6401 (gnus-article-check-buffer)
6402 (let ((keymap (copy-keymap gnus-article-mode-map))
6403 (map (copy-keymap gnus-article-send-map))
6404 (sumkeys (where-is-internal 'gnus-article-read-summary-keys))
e9198520 6405 agent draft)
0b6799c3
MB		 6406 (define-key keymap "S" map)
6407 (define-key map [t] nil)
6408 (with-current-buffer gnus-article-current-summary
6409 (set-keymap-parent map (key-binding "S"))
8f7abae3
MB		 6410 (let (key def gnus-pick-mode)
6411 (while sumkeys
6412 (setq key (pop sumkeys))
6413 (cond ((and (vectorp key) (= (length key) 1)
6414 (consp (setq def (aref key 0)))
6415 (numberp (car def)) (numberp (cdr def)))
6416 (when (< (max (car def) (cdr def)) 128)
6417 (setq sumkeys
6418 (append (mapcar
6419 #'vector
6420 (nreverse (gnus-uncompress-range def)))
6421 sumkeys))))
6422 ((setq def (key-binding key))
6423 (unless (eq def 'undefined)
6424 (define-key keymap key def))))))
0b6799c3 6425 (when (boundp 'gnus-agent-summary-mode)
e9198520
MB		 6426 (setq agent gnus-agent-summary-mode))
6427 (when (boundp 'gnus-draft-mode)
6428 (setq draft gnus-draft-mode)))
0b6799c3
MB		 6429 (with-temp-buffer
6430 (use-local-map keymap)
6431 (set (make-local-variable 'gnus-agent-summary-mode) agent)
e9198520 6432 (set (make-local-variable 'gnus-draft-mode) draft)
0b6799c3
MB		 6433 (describe-bindings prefix))
6434 (let ((item `((lambda (prefix)
80de1778 6435 (with-current-buffer ,(current-buffer)
0b6799c3
MB		 6436 (gnus-article-describe-bindings prefix)))
6437 ,prefix)))
6438 (with-current-buffer (if (fboundp 'help-buffer)
6439 (let (help-xref-following) (help-buffer))
6440 "*Help*") ;; Emacs 21
6441 (setq help-xref-stack-item item)))))
6442
23f87bed
MB		 6443(defun gnus-article-reply-with-original (&optional wide)
6444 "Start composing a reply mail to the current message.
6445The text in the region will be yanked. If the region isn't active,
6446the entire article will be yanked."
95838435 6447 (interactive)
23f87bed
MB		 6448 (let ((article (cdr gnus-article-current))
6449 contents)
1d0df8af 6450 (if (not (gnus-region-active-p))
23f87bed
MB		 6451 (with-current-buffer gnus-summary-buffer
6452 (gnus-summary-reply (list (list article)) wide))
6453 (setq contents (buffer-substring (point) (mark t)))
6454 ;; Deactivate active regions.
6455 (when (and (boundp 'transient-mark-mode)
6456 transient-mark-mode)
6457 (setq mark-active nil))
6458 (with-current-buffer gnus-summary-buffer
6459 (gnus-summary-reply
6460 (list (list article contents)) wide)))))
6461
95838435
MB		 6462(defun gnus-article-wide-reply-with-original ()
6463 "Start composing a wide reply mail to the current message.
6464The text in the region will be yanked. If the region isn't active,
6465the entire article will be yanked."
6466 (interactive)
6467 (gnus-article-reply-with-original t))
6468
23f87bed
MB		 6469(defun gnus-article-followup-with-original ()
6470 "Compose a followup to the current article.
6471The text in the region will be yanked. If the region isn't active,
6472the entire article will be yanked."
6473 (interactive)
6474 (let ((article (cdr gnus-article-current))
6475 contents)
1d0df8af 6476 (if (not (gnus-region-active-p))
23f87bed
MB		 6477 (with-current-buffer gnus-summary-buffer
6478 (gnus-summary-followup (list (list article))))
6479 (setq contents (buffer-substring (point) (mark t)))
6480 ;; Deactivate active regions.
6481 (when (and (boundp 'transient-mark-mode)
6482 transient-mark-mode)
6483 (setq mark-active nil))
6484 (with-current-buffer gnus-summary-buffer
6485 (gnus-summary-followup
6486 (list (list article contents)))))))
6487
eec82323
LMI		 6488(defun gnus-article-hide (&optional arg force)
6489 "Hide all the gruft in the current article.
23f87bed
MB		 6490This means that signatures, cited text and (some) headers will be
6491hidden.
eec82323 6492If given a prefix, show the hidden text instead."
6748645f 6493 (interactive (append (gnus-article-hidden-arg) (list 'force)))
eec82323 6494 (gnus-article-hide-headers arg)
16409b0b 6495 (gnus-article-hide-list-identifiers arg)
eec82323
LMI		 6496 (gnus-article-hide-citation-maybe arg force)
6497 (gnus-article-hide-signature arg))
6498
6499(defun gnus-article-maybe-highlight ()
6748645f 6500 "Do some article highlighting if article highlighting is requested."
eec82323
LMI		 6501 (when (gnus-visual-p 'article-highlight 'highlight)
6502 (gnus-article-highlight-some)))
6503
6748645f
LMI		 6504(defun gnus-check-group-server ()
6505 ;; Make sure the connection to the server is alive.
6506 (unless (gnus-server-opened
6507 (gnus-find-method-for-group gnus-newsgroup-name))
6508 (gnus-check-server (gnus-find-method-for-group gnus-newsgroup-name))
6509 (gnus-request-group gnus-newsgroup-name t)))
6510
23f87bed
MB		 6511(eval-when-compile
6512 (autoload 'nneething-get-file-name "nneething"))
6513
eec82323
LMI		 6514(defun gnus-request-article-this-buffer (article group)
6515 "Get an article and insert it into this buffer."
6748645f 6516 (let (do-update-line sparse-header)
eec82323
LMI		 6517 (prog1
6518 (save-excursion
6519 (erase-buffer)
6520 (gnus-kill-all-overlays)
6521 (setq group (or group gnus-newsgroup-name))
6522
eec82323
LMI		 6523 ;; Using `gnus-request-article' directly will insert the article into
6524 ;; `nntp-server-buffer' - so we'll save some time by not having to
6525 ;; copy it from the server buffer into the article buffer.
6526
6527 ;; We only request an article by message-id when we do not have the
6528 ;; headers for it, so we'll have to get those.
6529 (when (stringp article)
16409b0b 6530 (gnus-read-header article))
eec82323
LMI		 6531
6532 ;; If the article number is negative, that means that this article
6533 ;; doesn't belong in this newsgroup (possibly), so we find its
6534 ;; message-id and request it by id instead of number.
6535 (when (and (numberp article)
6536 gnus-summary-buffer
6537 (get-buffer gnus-summary-buffer)
6748645f 6538 (gnus-buffer-exists-p gnus-summary-buffer))
80de1778 6539 (with-current-buffer gnus-summary-buffer
eec82323
LMI		 6540 (let ((header (gnus-summary-article-header article)))
6541 (when (< article 0)
6542 (cond
6543 ((memq article gnus-newsgroup-sparse)
6544 ;; This is a sparse gap article.
6545 (setq do-update-line article)
6546 (setq article (mail-header-id header))
16409b0b 6547 (setq sparse-header (gnus-read-header article))
eec82323
LMI		 6548 (setq gnus-newsgroup-sparse
6549 (delq article gnus-newsgroup-sparse)))
6550 ((vectorp header)
6551 ;; It's a real article.
6552 (setq article (mail-header-id header)))
6553 (t
6554 ;; It is an extracted pseudo-article.
6555 (setq article 'pseudo)
6556 (gnus-request-pseudo-article header))))
6557
6558 (let ((method (gnus-find-method-for-group
6559 gnus-newsgroup-name)))
6748645f
LMI		 6560 (when (and (eq (car method) 'nneething)
6561 (vectorp header))
23f87bed
MB		 6562 (let ((dir (nneething-get-file-name
6563 (mail-header-id header))))
6564 (when (and (stringp dir)
6565 (file-directory-p dir))
eec82323
LMI		 6566 (setq article 'nneething)
6567 (gnus-group-enter-directory dir))))))))
6568
6569 (cond
6570 ;; Refuse to select canceled articles.
6571 ((and (numberp article)
6572 gnus-summary-buffer
6573 (get-buffer gnus-summary-buffer)
6748645f 6574 (gnus-buffer-exists-p gnus-summary-buffer)
01c52d31 6575 (eq (cdr (with-current-buffer gnus-summary-buffer
eec82323
LMI		 6576 (assq article gnus-newsgroup-reads)))
6577 gnus-canceled-mark))
6578 nil)
6579 ;; We first check `gnus-original-article-buffer'.
6580 ((and (get-buffer gnus-original-article-buffer)
6581 (numberp article)
01c52d31 6582 (with-current-buffer gnus-original-article-buffer
eec82323
LMI		 6583 (and (equal (car gnus-original-article) group)
6584 (eq (cdr gnus-original-article) article))))
6585 (insert-buffer-substring gnus-original-article-buffer)
6586 'article)
6587 ;; Check the backlog.
6588 ((and gnus-keep-backlog
6589 (gnus-backlog-request-article group article (current-buffer)))
6590 'article)
6591 ;; Check asynchronous pre-fetch.
6592 ((gnus-async-request-fetched-article group article (current-buffer))
6593 (gnus-async-prefetch-next group article gnus-summary-buffer)
6748645f
LMI		 6594 (when (and (numberp article) gnus-keep-backlog)
6595 (gnus-backlog-enter-article group article (current-buffer)))
eec82323
LMI		 6596 'article)
6597 ;; Check the cache.
6598 ((and gnus-use-cache
6599 (numberp article)
6600 (gnus-cache-request-article article group))
6601 'article)
23f87bed
MB		 6602 ;; Check the agent cache.
6603 ((gnus-agent-request-article article group)
6604 'article)
eec82323 6605 ;; Get the article and put into the article buffer.
16409b0b
GM		 6606 ((or (stringp article)
6607 (numberp article))
6608 (let ((gnus-override-method gnus-override-method)
a1506d29 6609 (methods (and (stringp article)
16409b0b 6610 gnus-refer-article-method))
23f87bed
MB		 6611 (backend (car (gnus-find-method-for-group
6612 gnus-newsgroup-name)))
16409b0b 6613 result
4e7d0221 6614 (inhibit-read-only t))
e0bad764
DL		 6615 (if (or (not (listp methods))
6616 (and (symbolp (car methods))
6617 (assq (car methods) nnoo-definition-alist)))
6618 (setq methods (list methods)))
16409b0b
GM		 6619 (when (and (null gnus-override-method)
6620 methods)
6621 (setq gnus-override-method (pop methods)))
6622 (while (not result)
6623 (when (eq gnus-override-method 'current)
c55f89a5
GM		 6624 (setq gnus-override-method
6625 (with-current-buffer gnus-summary-buffer
6626 gnus-current-select-method)))
16409b0b
GM		 6627 (erase-buffer)
6628 (gnus-kill-all-overlays)
6629 (let ((gnus-newsgroup-name group))
6630 (gnus-check-group-server))
23f87bed
MB		 6631 (cond
6632 ((gnus-request-article article group (current-buffer))
16409b0b 6633 (when (numberp article)
a1506d29 6634 (gnus-async-prefetch-next group article
16409b0b
GM		 6635 gnus-summary-buffer)
6636 (when gnus-keep-backlog
6637 (gnus-backlog-enter-article
6638 group article (current-buffer))))
6639 (setq result 'article))
23f87bed
MB		 6640 (methods
6641 (setq gnus-override-method (pop methods)))
6642 ((not (string-match "^400 "
6643 (nnheader-get-report backend)))
6644 ;; If we get 400 server disconnect, reconnect and
6645 ;; retry; otherwise, assume the article has expired.
6646 (setq result 'done))))
16409b0b 6647 (and (eq result 'article) 'article)))
eec82323
LMI		 6648 ;; It was a pseudo.
6649 (t article)))
6650
6748645f
LMI		 6651 ;; Associate this article with the current summary buffer.
6652 (setq gnus-article-current-summary gnus-summary-buffer)
6653
eec82323
LMI		 6654 ;; Take the article from the original article buffer
6655 ;; and place it in the buffer it's supposed to be in.
6656 (when (and (get-buffer gnus-article-buffer)
eec82323
LMI		 6657 (equal (buffer-name (current-buffer))
6658 (buffer-name (get-buffer gnus-article-buffer))))
6659 (save-excursion
6660 (if (get-buffer gnus-original-article-buffer)
6748645f
LMI		 6661 (set-buffer gnus-original-article-buffer)
6662 (set-buffer (gnus-get-buffer-create gnus-original-article-buffer))
16409b0b 6663 (buffer-disable-undo)
eec82323 6664 (setq major-mode 'gnus-original-article-mode)
6748645f 6665 (setq buffer-read-only t))
23f87bed 6666 (let ((inhibit-read-only t))
eec82323
LMI		 6667 (erase-buffer)
6668 (insert-buffer-substring gnus-article-buffer))
16409b0b
GM		 6669 (setq gnus-original-article (cons group article)))
6670
6671 ;; Decode charsets.
6672 (run-hooks 'gnus-article-decode-hook)
6673 ;; Mark article as decoded or not.
6674 (setq gnus-article-decoded-p gnus-article-decode-hook))
eec82323
LMI		 6675
6676 ;; Update sparse articles.
6677 (when (and do-update-line
6678 (or (numberp article)
6679 (stringp article)))
6680 (let ((buf (current-buffer)))
6681 (set-buffer gnus-summary-buffer)
6748645f 6682 (gnus-summary-update-article do-update-line sparse-header)
eec82323 6683 (gnus-summary-goto-subject do-update-line nil t)
23f87bed 6684 (set-window-point (gnus-get-buffer-window (current-buffer) t)
eec82323
LMI		 6685 (point))
6686 (set-buffer buf))))))
6687
6688;;;
6689;;; Article editing
6690;;;
6691
6692(defcustom gnus-article-edit-mode-hook nil
6693 "Hook run in article edit mode buffers."
6694 :group 'gnus-article-various
6695 :type 'hook)
6696
6697(defvar gnus-article-edit-done-function nil)
6698
6699(defvar gnus-article-edit-mode-map nil)
6700
16409b0b 6701;; Should we be using derived.el for this?
eec82323 6702(unless gnus-article-edit-mode-map
23f87bed 6703 (setq gnus-article-edit-mode-map (make-keymap))
16409b0b 6704 (set-keymap-parent gnus-article-edit-mode-map text-mode-map)
eec82323
LMI		 6705
6706 (gnus-define-keys gnus-article-edit-mode-map
23f87bed 6707 "\C-c?" describe-mode
eec82323 6708 "\C-c\C-c" gnus-article-edit-done
23f87bed
MB		 6709 "\C-c\C-k" gnus-article-edit-exit
6710 "\C-c\C-f\C-t" message-goto-to
6711 "\C-c\C-f\C-o" message-goto-from
6712 "\C-c\C-f\C-b" message-goto-bcc
6713 ;;"\C-c\C-f\C-w" message-goto-fcc
6714 "\C-c\C-f\C-c" message-goto-cc
6715 "\C-c\C-f\C-s" message-goto-subject
6716 "\C-c\C-f\C-r" message-goto-reply-to
6717 "\C-c\C-f\C-n" message-goto-newsgroups
6718 "\C-c\C-f\C-d" message-goto-distribution
6719 "\C-c\C-f\C-f" message-goto-followup-to
6720 "\C-c\C-f\C-m" message-goto-mail-followup-to
6721 "\C-c\C-f\C-k" message-goto-keywords
6722 "\C-c\C-f\C-u" message-goto-summary
6723 "\C-c\C-f\C-i" message-insert-or-toggle-importance
6724 "\C-c\C-f\C-a" message-generate-unsubscribed-mail-followup-to
6725 "\C-c\C-b" message-goto-body
6726 "\C-c\C-i" message-goto-signature
6727
6728 "\C-c\C-t" message-insert-to
6729 "\C-c\C-n" message-insert-newsgroups
6730 "\C-c\C-o" message-sort-headers
6731 "\C-c\C-e" message-elide-region
6732 "\C-c\C-v" message-delete-not-region
6733 "\C-c\C-z" message-kill-to-signature
6734 "\M-\r" message-newline-and-reformat
6735 "\C-c\C-a" mml-attach-file
6736 "\C-a" message-beginning-of-line
6737 "\t" message-tab
6738 "\M-;" comment-region)
eec82323
LMI		 6739
6740 (gnus-define-keys (gnus-article-edit-wash-map
6741 "\C-c\C-w" gnus-article-edit-mode-map)
6742 "f" gnus-article-edit-full-stops))
6743
23f87bed
MB		 6744(easy-menu-define
6745 gnus-article-edit-mode-field-menu gnus-article-edit-mode-map ""
6746 '("Field"
6747 ["Fetch To" message-insert-to t]
6748 ["Fetch Newsgroups" message-insert-newsgroups t]
6749 "----"
6750 ["To" message-goto-to t]
6751 ["From" message-goto-from t]
6752 ["Subject" message-goto-subject t]
6753 ["Cc" message-goto-cc t]
6754 ["Reply-To" message-goto-reply-to t]
6755 ["Summary" message-goto-summary t]
6756 ["Keywords" message-goto-keywords t]
6757 ["Newsgroups" message-goto-newsgroups t]
6758 ["Followup-To" message-goto-followup-to t]
6759 ["Mail-Followup-To" message-goto-mail-followup-to t]
6760 ["Distribution" message-goto-distribution t]
6761 ["Body" message-goto-body t]
6762 ["Signature" message-goto-signature t]))
6763
4e7d0221 6764(define-derived-mode gnus-article-edit-mode message-mode "Article Edit"
eec82323
LMI		 6765 "Major mode for editing articles.
6766This is an extended text-mode.
6767
6768\\{gnus-article-edit-mode-map}"
eec82323
LMI		 6769 (make-local-variable 'gnus-article-edit-done-function)
6770 (make-local-variable 'gnus-prev-winconf)
80b47379
SZ		 6771 (set (make-local-variable 'font-lock-defaults)
6772 '(message-font-lock-keywords t))
23f87bed
MB		 6773 (set (make-local-variable 'mail-header-separator) "")
6774 (set (make-local-variable 'gnus-article-edit-mode) t)
6775 (easy-menu-add message-mode-field-menu message-mode-map)
6776 (mml-mode)
eec82323
LMI		 6777 (setq buffer-read-only nil)
6778 (buffer-enable-undo)
80b47379 6779 (widen))
eec82323
LMI		 6780
6781(defun gnus-article-edit (&optional force)
6782 "Edit the current article.
6783This will have permanent effect only in mail groups.
6784If FORCE is non-nil, allow editing of articles even in read-only
6785groups."
6786 (interactive "P")
6787 (when (and (not force)
6788 (gnus-group-read-only-p))
a8151ef7 6789 (error "The current newsgroup does not support article editing"))
6748645f 6790 (gnus-article-date-original)
eec82323 6791 (gnus-article-edit-article
16409b0b 6792 'ignore
6748645f 6793 `(lambda (no-highlight)
16409b0b 6794 'ignore
eec82323
LMI		 6795 (gnus-summary-edit-article-done
6796 ,(or (mail-header-references gnus-current-headers) "")
6748645f 6797 ,(gnus-group-read-only-p) ,gnus-summary-buffer no-highlight))))
eec82323 6798
01c52d31 6799(defun gnus-article-edit-article (start-func exit-func &optional quiet)
eec82323
LMI		 6800 "Start editing the contents of the current article buffer."
6801 (let ((winconf (current-window-configuration)))
6802 (set-buffer gnus-article-buffer)
0683d241
MB		 6803 (let ((message-auto-save-directory
6804 ;; Don't associate the article buffer with a draft file.
6805 nil))
6806 (gnus-article-edit-mode))
16409b0b 6807 (funcall start-func)
23f87bed 6808 (set-buffer-modified-p nil)
eec82323
LMI		 6809 (gnus-configure-windows 'edit-article)
6810 (setq gnus-article-edit-done-function exit-func)
6811 (setq gnus-prev-winconf winconf)
01c52d31
MB		 6812 (unless quiet
6813 (gnus-message 6 "C-c C-c to end edits"))))
eec82323 6814
6748645f 6815(defun gnus-article-edit-done (&optional arg)
eec82323 6816 "Update the article edits and exit."
6748645f 6817 (interactive "P")
eec82323
LMI		 6818 (let ((func gnus-article-edit-done-function)
6819 (buf (current-buffer))
23f87bed
MB		 6820 (start (window-start))
6821 (p (point))
6822 (winconf gnus-prev-winconf))
6823 (widen) ;; Widen it in case that users narrowed the buffer.
6824 (funcall func arg)
6825 (set-buffer buf)
6826 ;; The cache and backlog have to be flushed somewhat.
6827 (when gnus-keep-backlog
6828 (gnus-backlog-remove-article
6829 (car gnus-article-current) (cdr gnus-article-current)))
6830 ;; Flush original article as well.
80de1778
SM		 6831 (when (get-buffer gnus-original-article-buffer)
6832 (with-current-buffer gnus-original-article-buffer
23f87bed
MB		 6833 (setq gnus-original-article nil)))
6834 (when gnus-use-cache
6835 (gnus-cache-update-article
6836 (car gnus-article-current) (cdr gnus-article-current)))
6837 ;; We remove all text props from the article buffer.
6838 (kill-all-local-variables)
01c52d31 6839 (set-text-properties (point-min) (point-max) nil)
23f87bed
MB		 6840 (gnus-article-mode)
6841 (set-window-configuration winconf)
eec82323
LMI		 6842 (set-buffer buf)
6843 (set-window-start (get-buffer-window buf) start)
23f87bed
MB		 6844 (set-window-point (get-buffer-window buf) (point)))
6845 (gnus-summary-show-article))
eec82323
LMI		 6846
6847(defun gnus-article-edit-exit ()
6848 "Exit the article editing without updating."
6849 (interactive)
23f87bed
MB		 6850 (when (or (not (buffer-modified-p))
6851 (yes-or-no-p "Article modified; kill anyway? "))
6852 (let ((curbuf (current-buffer))
6853 (p (point))
6854 (window-start (window-start)))
6855 (erase-buffer)
6856 (if (gnus-buffer-live-p gnus-original-article-buffer)
d8a88581 6857 (insert-buffer-substring gnus-original-article-buffer))
23f87bed
MB		 6858 (let ((winconf gnus-prev-winconf))
6859 (kill-all-local-variables)
6860 (gnus-article-mode)
6861 (set-window-configuration winconf)
6862 ;; Tippy-toe some to make sure that point remains where it was.
6863 (save-current-buffer
6864 (set-buffer curbuf)
6865 (set-window-start (get-buffer-window (current-buffer)) window-start)
6866 (goto-char p))))
6867 (gnus-summary-show-article)))
eec82323
LMI		 6868
6869(defun gnus-article-edit-full-stops ()
6870 "Interactively repair spacing at end of sentences."
6871 (interactive)
6872 (save-excursion
6873 (goto-char (point-min))
6874 (search-forward-regexp "^$" nil t)
6875 (let ((case-fold-search nil))
6876 (query-replace-regexp "\\([.!?][])}]* \\)\\([[({A-Z]\\)" "\\1 \\2"))))
6877
6878;;;
6879;;; Article highlights
6880;;;
6881
6882;; Written by Per Abrahamsen <abraham@iesd.auc.dk>.
6883
6884;;; Internal Variables:
6885
a1506d29 6886(defcustom gnus-button-url-regexp
01c52d31
MB		 6887 (concat
6888 "\\b\\(\\(www\\.\\|\\(s?https?\\|ftp\\|file\\|gopher\\|"
6889 "nntp\\|news\\|telnet\\|wais\\|mailto\\|info\\):\\)"
6890 "\\(//[-a-z0-9_.]+:[0-9]*\\)?"
6891 (if (string-match "[[:digit:]]" "1") ;; Support POSIX?
6892 (let ((chars "-a-z0-9_=#$@~%&*+\\/[:word:]")
6893 (punct "!?:;.,"))
6894 (concat
6895 "\\(?:"
6896 ;; Match paired parentheses, e.g. in Wikipedia URLs:
6897 "[" chars punct "]+" "(" "[" chars punct "]+" "[" chars "]*)" "[" chars "]"
6898 "\\|"
6899 "[" chars punct "]+" "[" chars "]"
6900 "\\)"))
6901 (concat ;; XEmacs 21.4 doesn't support POSIX.
6902 "\\([-a-z0-9_=!?#$@~%&*+\\/:;.,]\\|\\w\\)+"
6903 "\\([-a-z0-9_=#$@~%&*+\\/]\\|\\w\\)"))
6904 "\\)")
eec82323
LMI		 6905 "Regular expression that matches URLs."
6906 :group 'gnus-article-buttons
6907 :type 'regexp)
6908
23f87bed
MB		 6909(defcustom gnus-button-valid-fqdn-regexp
6910 message-valid-fqdn-regexp
6911 "Regular expression that matches a valid FQDN."
bf247b6e 6912 :version "22.1"
23f87bed
MB		 6913 :group 'gnus-article-buttons
6914 :type 'regexp)
6915
97f78c9b
MB		 6916;; Regexp suggested by Felix Wiemann in <87oeuomcz9.fsf@news2.ososo.de>
6917(defcustom gnus-button-valid-localpart-regexp
14e6dc54 6918 "[a-z0-9$%(*-=?[_][^<>\")!;:,{}\n\t @]*"
97f78c9b
MB		 6919 "Regular expression that matches a localpart of mail addresses or MIDs."
6920 :version "22.1"
6921 :group 'gnus-article-buttons
6922 :type 'regexp)
6923
23f87bed
MB		 6924(defcustom gnus-button-man-handler 'manual-entry
6925 "Function to use for displaying man pages.
6926The function must take at least one argument with a string naming the
6927man page."
bf247b6e 6928 :version "22.1"
23f87bed
MB		 6929 :type '(choice (function-item :tag "Man" manual-entry)
6930 (function-item :tag "Woman" woman)
6931 (function :tag "Other"))
6932 :group 'gnus-article-buttons)
6933
6934(defcustom gnus-ctan-url "http://tug.ctan.org/tex-archive/"
6935 "Top directory of a CTAN \(Comprehensive TeX Archive Network\) archive.
6936If the default site is too slow, try to find a CTAN mirror, see
6937<URL:http://tug.ctan.org/tex-archive/CTAN.sites?action=/index.html>. See also
6938the variable `gnus-button-handle-ctan'."
bf247b6e 6939 :version "22.1"
23f87bed
MB		 6940 :group 'gnus-article-buttons
6941 :link '(custom-manual "(gnus)Group Parameters")
6942 :type '(choice (const "http://www.tex.ac.uk/tex-archive/")
6943 (const "http://tug.ctan.org/tex-archive/")
6944 (const "http://www.dante.de/CTAN/")
6945 (string :tag "Other")))
6946
6947(defcustom gnus-button-ctan-handler 'browse-url
6948 "Function to use for displaying CTAN links.
6949The function must take one argument, the string naming the URL."
bf247b6e 6950 :version "22.1"
23f87bed
MB		 6951 :type '(choice (function-item :tag "Browse Url" browse-url)
6952 (function :tag "Other"))
6953 :group 'gnus-article-buttons)
6954
6955(defcustom gnus-button-handle-ctan-bogus-regexp "^/?tex-archive/\\|^/"
6956 "Bogus strings removed from CTAN URLs."
bf247b6e 6957 :version "22.1"
23f87bed
MB		 6958 :group 'gnus-article-buttons
6959 :type '(choice (const "^/?tex-archive/\\|/")
6960 (regexp :tag "Other")))
6961
6962(defcustom gnus-button-ctan-directory-regexp
97f78c9b
MB		 6963 (regexp-opt
6964 (list "archive-tools" "biblio" "bibliography" "digests" "documentation"
6965 "dviware" "fonts" "graphics" "help" "indexing" "info" "language"
6966 "languages" "macros" "nonfree" "obsolete" "support" "systems"
6967 "tds" "tools" "usergrps" "web") t)
23f87bed
MB		 6968 "Regular expression for ctan directories.
6969It should match all directories in the top level of `gnus-ctan-url'."
bf247b6e 6970 :version "22.1"
23f87bed
MB		 6971 :group 'gnus-article-buttons
6972 :type 'regexp)
6973
6974(defcustom gnus-button-mid-or-mail-regexp
97f78c9b 6975 (concat "\\b\\(<?" gnus-button-valid-localpart-regexp "@"
23f87bed
MB		 6976 gnus-button-valid-fqdn-regexp
6977 ">?\\)\\b")
6978 "Regular expression that matches a message ID or a mail address."
bf247b6e 6979 :version "22.1"
23f87bed
MB		 6980 :group 'gnus-article-buttons
6981 :type 'regexp)
6982
6983(defcustom gnus-button-prefer-mid-or-mail 'gnus-button-mid-or-mail-heuristic
6984 "What to do when the button on a string as \"foo123@bar.invalid\" is pushed.
6985Strings like this can be either a message ID or a mail address. If it is one
6986of the symbols `mid' or `mail', Gnus will always assume that the string is a
6987message ID or a mail address, respectively. If this variable is set to the
6988symbol `ask', always query the user what do do. If it is a function, this
aa819354 6989function will be called with the string as its only argument. The function
23f87bed 6990must return `mid', `mail', `invalid' or `ask'."
bf247b6e 6991 :version "22.1"
23f87bed
MB		 6992 :group 'gnus-article-buttons
6993 :type '(choice (function-item :tag "Heuristic function"
6994 gnus-button-mid-or-mail-heuristic)
6995 (const ask)
6996 (const mid)
6997 (const mail)))
6998
6999(defcustom gnus-button-mid-or-mail-heuristic-alist
7000 '((-10.0 . ".+\\$.+@")
7001 (-10.0 . "#")
7002 (-10.0 . "\\*")
7003 (-5.0 . "\\+[^+]*\\+.*@") ;; # two plus signs
7004 (-5.0 . "@[Nn][Ee][Ww][Ss]") ;; /\@news/i
7005 (-5.0 . "@.*[Dd][Ii][Aa][Ll][Uu][Pp]") ;; /\@.*dialup/i;
7006 (-1.0 . "^[^a-z]+@")
7007 ;;
7008 (-5.0 . "\\.[0-9][0-9]+.*@") ;; "\.[0-9]{2,}.*\@"
7009 (-5.0 . "[a-z].*[A-Z].*[a-z].*[A-Z].*@") ;; "([a-z].*[A-Z].*){2,}\@"
7010 (-3.0 . "[A-Z][A-Z][a-z][a-z].*@")
7011 (-5.0 . "\\...?.?@") ;; (-5.0 . "\..{1,3}\@")
7012 ;;
7013 (-2.0 . "^[0-9]")
7014 (-1.0 . "^[0-9][0-9]")
7015 ;;
7016 ;; -3.0 /^[0-9][0-9a-fA-F]{2,2}/;
7017 (-3.0 . "^[0-9][0-9a-fA-F][0-9a-fA-F][^0-9a-fA-F]")
7018 ;; -5.0 /^[0-9][0-9a-fA-F]{3,3}/;
7019 (-5.0 . "^[0-9][0-9a-fA-F][0-9a-fA-F][0-9a-fA-F][^0-9a-fA-F]")
7020 ;;
7021 (-3.0 . "[0-9][0-9][0-9][0-9][0-9][^0-9].*@") ;; "[0-9]{5,}.*\@"
7022 (-3.0 . "[0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][^0-9].*@")
7023 ;; "[0-9]{8,}.*\@"
7024 (-3.0
7025 . "[0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9].*@")
7026 ;; "[0-9]{12,}.*\@"
7027 ;; compensation for TDMA dated mail addresses:
7028 (25.0 . "-dated-[0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9]+.*@")
7029 ;;
7030 (-20.0 . "\\.fsf@") ;; Gnus
7031 (-20.0 . "^slrn")
7032 (-20.0 . "^Pine")
437ce4be 7033 (-20.0 . "^alpine\\.")
23f87bed
MB		 7034 (-20.0 . "_-_") ;; Subject change in thread
7035 ;;
7036 (-20.0 . "\\.ln@") ;; leafnode
7037 (-30.0 . "@ID-[0-9]+\\.[a-zA-Z]+\\.dfncis\\.de")
7038 (-30.0 . "@4[Aa][Xx]\\.com") ;; Forte Agent
7039 ;;
7040 ;; (5.0 . "") ;; $local_part_len <= 7
7041 (10.0 . "^[^0-9]+@")
7042 (3.0 . "^[^0-9]+[0-9][0-9]?[0-9]?@")
7043 ;; ^[^0-9]+[0-9]{1,3}\@ digits only at end of local part
7044 (3.0 . "\@stud")
7045 ;;
7046 (2.0 . "[a-z][a-z][._-][A-Z][a-z].*@")
7047 ;;
7048 (0.5 . "^[A-Z][a-z]")
7049 (0.5 . "^[A-Z][a-z][a-z]")
7050 (1.5 . "^[A-Z][a-z][A-Z][a-z][^a-z]") ;; ^[A-Z][a-z]{3,3}
7051 (2.0 . "^[A-Z][a-z][A-Z][a-z][a-z][^a-z]")) ;; ^[A-Z][a-z]{4,4}
7052 "An alist of \(RATE . REGEXP\) pairs for `gnus-button-mid-or-mail-heuristic'.
7053
7054A negative RATE indicates a message IDs, whereas a positive indicates a mail
7055address. The REGEXP is processed with `case-fold-search' set to nil."
bf247b6e 7056 :version "22.1"
23f87bed
MB		 7057 :group 'gnus-article-buttons
7058 :type '(repeat (cons (number :tag "Rate")
7059 (regexp :tag "Regexp"))))
7060
7061(defun gnus-button-mid-or-mail-heuristic (mid-or-mail)
7062 "Guess whether MID-OR-MAIL is a message ID or a mail address.
7063Returns `mid' if MID-OR-MAIL is a message IDs, `mail' if it's a mail
7064address, `ask' if unsure and `invalid' if the string is invalid."
7065 (let ((case-fold-search nil)
7066 (list gnus-button-mid-or-mail-heuristic-alist)
7067 (result 0) rate regexp lpartlen elem)
7068 (setq lpartlen
7069 (length (gnus-replace-in-string mid-or-mail "^\\(.*\\)@.*$" "\\1")))
7070 (gnus-message 8 "`%s', length of local part=`%s'." mid-or-mail lpartlen)
7071 ;; Certain special cases...
7072 (when (string-match
7073 (concat
7074 "^0[0-9]+-[0-9][0-9][0-9][0-9]@t-online\\.de$\\|"
7075 "^[0-9]+\\.[0-9]+@compuserve\\|"
7076 "@public\\.gmane\\.org")
7077 mid-or-mail)
7078 (gnus-message 8 "`%s' is a known mail address." mid-or-mail)
7079 (setq result 'mail))
7080 (when (string-match "@.*@\\| " mid-or-mail)
7081 (gnus-message 8 "`%s' is invalid." mid-or-mail)
7082 (setq result 'invalid))
7083 ;; Nothing more to do, if result is not a number here...
7084 (when (numberp result)
7085 (while list
7086 (setq elem (car list)
7087 rate (car elem)
7088 regexp (cdr elem)
7089 list (cdr list))
7090 (when (string-match regexp mid-or-mail)
7091 (setq result (+ result rate))
7092 (gnus-message
7093 9 "`%s' matched `%s', rate `%s', result `%s'."
7094 mid-or-mail regexp rate result)))
7095 (when (<= lpartlen 7)
7096 (setq result (+ result 5.0))
7097 (gnus-message 9 "`%s' matched (<= lpartlen 7), result `%s'."
7098 mid-or-mail result))
7099 (when (>= lpartlen 12)
7100 (gnus-message 9 "`%s' matched (>= lpartlen 12)" mid-or-mail)
7101 (cond
7102 ((string-match "[0-9][^0-9]+[0-9].*@" mid-or-mail)
7103 ;; Long local part should contain realname if e-mail address,
7104 ;; too many digits: message-id.
7105 ;; $score -= 5.0 + 0.1 * $local_part_len;
7106 (setq rate (* -1.0 (+ 5.0 (* 0.1 lpartlen))))
7107 (setq result (+ result rate))
7108 (gnus-message
7109 9 "Many digits in `%s', rate `%s', result `%s'."
7110 mid-or-mail rate result))
7111 ((string-match "[^aeiouy][^aeiouy][^aeiouy][^aeiouy]+.*\@"
7112 mid-or-mail)
7113 ;; Too few vowels [^aeiouy]{4,}.*\@
7114 (setq result (+ result -5.0))
7115 (gnus-message
7116 9 "Few vowels in `%s', rate `%s', result `%s'."
7117 mid-or-mail -5.0 result))
7118 (t
7119 (setq result (+ result 5.0))
7120 (gnus-message
7121 9 "`%s', rate `%s', result `%s'." mid-or-mail 5.0 result)))))
7122 (gnus-message 8 "`%s': Final rate is `%s'." mid-or-mail result)
7123 ;; Maybe we should make this a customizable alist: (condition . 'result)
7124 (cond
7125 ((symbolp result) result)
7126 ;; Now convert number into proper results:
7127 ((< result -10.0) 'mid)
7128 ((> result 10.0) 'mail)
7129 (t 'ask))))
7130
7131(defun gnus-button-handle-mid-or-mail (mid-or-mail)
7132 (let* ((pref gnus-button-prefer-mid-or-mail) guessed
7133 (url-mid (concat "news" ":" mid-or-mail))
7134 (url-mailto (concat "mailto" ":" mid-or-mail)))
7135 (gnus-message 9 "mid-or-mail=%s" mid-or-mail)
7136 (when (fboundp pref)
7137 (setq guessed
7138 ;; get rid of surrounding angles...
7139 (funcall pref
7140 (gnus-replace-in-string mid-or-mail "^<\\|>$" "")))
7141 (if (or (eq 'mid guessed) (eq 'mail guessed))
7142 (setq pref guessed)
7143 (setq pref 'ask)))
7144 (if (eq pref 'ask)
7145 (save-window-excursion
7146 (if (y-or-n-p (concat "Is <" mid-or-mail "> a mail address? "))
7147 (setq pref 'mail)
7148 (setq pref 'mid))))
7149 (cond ((eq pref 'mid)
7150 (gnus-message 8 "calling `gnus-button-handle-news' %s" url-mid)
7151 (gnus-button-handle-news url-mid))
7152 ((eq pref 'mail)
7153 (gnus-message 8 "calling `gnus-url-mailto' %s" url-mailto)
7154 (gnus-url-mailto url-mailto))
7155 (t (gnus-message 3 "Invalid string.")))))
7156
01c52d31
MB		 7157(defun gnus-button-handle-custom (fun arg)
7158 "Call function FUN on argument ARG.
7159Both FUN and ARG are supposed to be strings. ARG will be passed
7160as a symbol to FUN."
7161 (funcall (intern fun)
7162 (if (string-match "^customize-apropos" fun)
7163 arg
7164 (intern arg))))
23f87bed
MB		 7165
7166(defvar gnus-button-handle-describe-prefix "^\\(C-h\\|<?[Ff]1>?\\)")
7167
7168;; FIXME: Maybe we should merge some of the functions that do quite similar
7169;; stuff?
7170
7171(defun gnus-button-handle-describe-function (url)
7172 "Call `describe-function' when pushing the corresponding URL button."
7173 (describe-function
7174 (intern
7175 (gnus-replace-in-string url gnus-button-handle-describe-prefix ""))))
7176
7177(defun gnus-button-handle-describe-variable (url)
7178 "Call `describe-variable' when pushing the corresponding URL button."
7179 (describe-variable
7180 (intern
7181 (gnus-replace-in-string url gnus-button-handle-describe-prefix ""))))
7182
7183(defun gnus-button-handle-symbol (url)
7184"Display help on variable or function.
7185Calls `describe-variable' or `describe-function'."
7186 (let ((sym (intern url)))
7187 (cond
7188 ((fboundp sym) (describe-function sym))
7189 ((boundp sym) (describe-variable sym))
7190 (t (gnus-message 3 "`%s' is not a known function of variable." url)))))
7191
7192(defun gnus-button-handle-describe-key (url)
7193 "Call `describe-key' when pushing the corresponding URL button."
7194 (let* ((key-string
7195 (gnus-replace-in-string url gnus-button-handle-describe-prefix ""))
7196 (keys (ignore-errors (eval `(kbd ,key-string)))))
7197 (if keys
7198 (describe-key keys)
7199 (gnus-message 3 "Invalid key sequence in button: %s" key-string))))
7200
7201(defun gnus-button-handle-apropos (url)
7202 "Call `apropos' when pushing the corresponding URL button."
7203 (apropos (gnus-replace-in-string url gnus-button-handle-describe-prefix "")))
7204
7205(defun gnus-button-handle-apropos-command (url)
7206 "Call `apropos' when pushing the corresponding URL button."
7207 (apropos-command
7208 (gnus-replace-in-string url gnus-button-handle-describe-prefix "")))
7209
7210(defun gnus-button-handle-apropos-variable (url)
7211 "Call `apropos' when pushing the corresponding URL button."
7212 (funcall
7213 (if (fboundp 'apropos-variable) 'apropos-variable 'apropos)
7214 (gnus-replace-in-string url gnus-button-handle-describe-prefix "")))
7215
7216(defun gnus-button-handle-apropos-documentation (url)
7217 "Call `apropos' when pushing the corresponding URL button."
7218 (funcall
7219 (if (fboundp 'apropos-documentation) 'apropos-documentation 'apropos)
7220 (gnus-replace-in-string url gnus-button-handle-describe-prefix "")))
7221
7222(defun gnus-button-handle-library (url)
7223 "Call `locate-library' when pushing the corresponding URL button."
7224 (gnus-message 9 "url=`%s'" url)
7225 (let* ((lib (locate-library url))
7226 (file (gnus-replace-in-string (or lib "") "\.elc" ".el")))
7227 (if (not lib)
7228 (gnus-message 1 "Cannot locale library `%s'." url)
7229 (find-file-read-only file))))
7230
7231(defun gnus-button-handle-ctan (url)
7232 "Call `browse-url' when pushing a CTAN URL button."
7233 (funcall
7234 gnus-button-ctan-handler
7235 (concat
7236 gnus-ctan-url
7237 (gnus-replace-in-string url gnus-button-handle-ctan-bogus-regexp ""))))
7238
7239(defcustom gnus-button-tex-level 5
7240 "*Integer that says how many TeX-related buttons Gnus will show.
7241The higher the number, the more buttons will appear and the more false
7242positives are possible. Note that you can set this variable local to
7243specific groups. Setting it higher in TeX groups is probably a good idea.
7244See Info node `(gnus)Group Parameters' and the variable `gnus-parameters' on
7245how to set variables in specific groups."
bf247b6e 7246 :version "22.1"
23f87bed
MB		 7247 :group 'gnus-article-buttons
7248 :link '(custom-manual "(gnus)Group Parameters")
7249 :type 'integer)
7250
7251(defcustom gnus-button-man-level 5
7252 "*Integer that says how many man-related buttons Gnus will show.
7253The higher the number, the more buttons will appear and the more false
7254positives are possible. Note that you can set this variable local to
7255specific groups. Setting it higher in Unix groups is probably a good idea.
7256See Info node `(gnus)Group Parameters' and the variable `gnus-parameters' on
7257how to set variables in specific groups."
bf247b6e 7258 :version "22.1"
23f87bed
MB		 7259 :group 'gnus-article-buttons
7260 :link '(custom-manual "(gnus)Group Parameters")
7261 :type 'integer)
7262
7263(defcustom gnus-button-emacs-level 5
7264 "*Integer that says how many emacs-related buttons Gnus will show.
7265The higher the number, the more buttons will appear and the more false
7266positives are possible. Note that you can set this variable local to
7267specific groups. Setting it higher in Emacs or Gnus related groups is
7268probably a good idea. See Info node `(gnus)Group Parameters' and the variable
7269`gnus-parameters' on how to set variables in specific groups."
bf247b6e 7270 :version "22.1"
23f87bed
MB		 7271 :group 'gnus-article-buttons
7272 :link '(custom-manual "(gnus)Group Parameters")
7273 :type 'integer)
7274
7275(defcustom gnus-button-message-level 5
7276 "*Integer that says how many buttons for news or mail messages will appear.
7277The higher the number, the more buttons will appear and the more false
7278positives are possible."
7279 ;; mail addresses, MIDs, URLs for news, ...
bf247b6e 7280 :version "22.1"
23f87bed
MB		 7281 :group 'gnus-article-buttons
7282 :type 'integer)
7283
7284(defcustom gnus-button-browse-level 5
7285 "*Integer that says how many buttons for browsing will appear.
7286The higher the number, the more buttons will appear and the more false
7287positives are possible."
7288 ;; stuff handled by `browse-url' or `gnus-button-embedded-url'
bf247b6e 7289 :version "22.1"
23f87bed
MB		 7290 :group 'gnus-article-buttons
7291 :type 'integer)
7292
eec82323 7293(defcustom gnus-button-alist
23f87bed
MB		 7294 '(("<\\(url:[>\n\t ]*?\\)?\\(nntp\\|news\\):[>\n\t ]*\\([^>\n\t ]*@[^>\n\t ]*\\)>"
7295 0 (>= gnus-button-message-level 0) gnus-button-handle-news 3)
97f78c9b
MB		 7296 ((concat "\\b\\(nntp\\|news\\):\\("
7297 gnus-button-valid-localpart-regexp "@[a-z0-9.-]+[a-z]\\)")
7298 0 t gnus-button-handle-news 2)
23f87bed
MB		 7299 ("\\(\\b<\\(url:[>\n\t ]*\\)?\\(nntp\\|news\\):[>\n\t ]*\\(//\\)?\\([^>\n\t ]*\\)>\\)"
7300 1 (>= gnus-button-message-level 0) gnus-button-fetch-group 5)
7301 ("\\b\\(nntp\\|news\\):\\(//\\)?\\([^'\">\n\t ]+\\)"
7302 0 (>= gnus-button-message-level 0) gnus-button-fetch-group 3)
7303 ;; RFC 2392 (Don't allow `/' in domain part --> CID)
7304 ("\\bmid:\\(//\\)?\\([^'\">\n\t ]+@[^'\">\n\t /]+\\)"
7305 0 (>= gnus-button-message-level 0) gnus-button-message-id 2)
7306 ("\\bin\\( +article\\| +message\\)? +\\(<\\([^\n @<>]+@[^\n @<>]+\\)>\\)"
7307 2 (>= gnus-button-message-level 0) gnus-button-message-id 3)
01c52d31
MB		 7308 ("\\b\\(mid\\|message-id\\):? +\\(<\\([^\n @<>]+@[^\n @<>]+\\)>\\)"
7309 2 (>= gnus-button-message-level 0) gnus-button-message-id 3)
23f87bed
MB		 7310 ("\\(<URL: *\\)mailto: *\\([^> \n\t]+\\)>"
7311 0 (>= gnus-button-message-level 0) gnus-url-mailto 2)
7312 ;; RFC 2368 (The mailto URL scheme)
531e5812 7313 ("\\bmailto:\\([-a-z.@_+0-9%=?&/]+\\)"
23f87bed
MB		 7314 0 (>= gnus-button-message-level 0) gnus-url-mailto 1)
7315 ("\\bmailto:\\([^ \n\t]+\\)"
7316 0 (>= gnus-button-message-level 0) gnus-url-mailto 1)
7317 ;; CTAN
7318 ((concat "\\bCTAN:[ \t\n]?[^>)!;:,'\n\t ]*\\("
7319 gnus-button-ctan-directory-regexp
7320 "[^][>)!;:,'\n\t ]+\\)")
7321 0 (>= gnus-button-tex-level 1) gnus-button-handle-ctan 1)
7322 ((concat "\\btex-archive/\\("
7323 gnus-button-ctan-directory-regexp
7324 "/[-_.a-z0-9/]+[-_./a-z0-9]+[/a-z0-9]\\)")
7325 1 (>= gnus-button-tex-level 6) gnus-button-handle-ctan 1)
7326 ((concat
7327 "\\b\\("
7328 gnus-button-ctan-directory-regexp
7329 "/[-_.a-z0-9]+/[-_./a-z0-9]+[/a-z0-9]\\)")
7330 1 (>= gnus-button-tex-level 8) gnus-button-handle-ctan 1)
7331 ;; This is info (home-grown style) <info://foo/bar+baz>
7332 ("\\binfo://\\([^'\">\n\t ]+\\)"
7333 0 (>= gnus-button-emacs-level 1) gnus-button-handle-info-url 1)
7334 ;; Info GNOME style <info:foo#bar_baz>
7335 ("\\binfo:\\([^('\n\t\r \"><][^'\n\t\r \"><]*\\)"
7336 0 (>= gnus-button-emacs-level 1) gnus-button-handle-info-url-gnome 1)
7337 ;; Info KDE style <info:(foo)bar baz>
7338 ("<\\(info:\\(([^)]+)[^>\n\r]*\\)\\)>"
7339 1 (>= gnus-button-emacs-level 1) gnus-button-handle-info-url-kde 2)
7340 ("\\((Info-goto-node\\|(info\\)[ \t\n]*\\(\"[^\"]*\"\\))" 0
7341 (>= gnus-button-emacs-level 1) gnus-button-handle-info-url 2)
7342 ("\\b\\(C-h\\|<?[Ff]1>?\\)[ \t\n]+i[ \t\n]+d?[ \t\n]?m[ \t\n]+\\([^ ]+ ?[^ ]+\\)[ \t\n]+RET"
7343 ;; Info links like `C-h i d m CC Mode RET'
7344 0 (>= gnus-button-emacs-level 1) gnus-button-handle-info-keystrokes 2)
7345 ;; This is custom
01c52d31
MB		 7346 ("M-x[ \t\n]\\(customize-[^ ]+\\)[ \t\n]RET[ \t\n]\\([^ ]+\\)[ \t\n]RET" 0
7347 (>= gnus-button-emacs-level 1) gnus-button-handle-custom 1 2)
23f87bed
MB		 7348 ;; Emacs help commands
7349 ("M-x[ \t\n]+apropos[ \t\n]+RET[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET"
7350 ;; regexp doesn't match arguments containing ` '.
7351 0 (>= gnus-button-emacs-level 1) gnus-button-handle-apropos 1)
7352 ("M-x[ \t\n]+apropos-command[ \t\n]+RET[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET"
7353 0 (>= gnus-button-emacs-level 1) gnus-button-handle-apropos-command 1)
7354 ("M-x[ \t\n]+apropos-variable[ \t\n]+RET[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET"
7355 0 (>= gnus-button-emacs-level 1) gnus-button-handle-apropos-variable 1)
7356 ("M-x[ \t\n]+apropos-documentation[ \t\n]+RET[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET"
7357 0 (>= gnus-button-emacs-level 1) gnus-button-handle-apropos-documentation 1)
7358 ;; The following entries may lead to many false positives so don't enable
531e5812
MB		 7359 ;; them by default (use a high button level).
7360 ("/\\([a-z][-a-z0-9]+\\.el\\)\\>[^.?]"
7361 ;; Exclude [.?] for URLs in gmane.emacs.cvs
23f87bed
MB		 7362 1 (>= gnus-button-emacs-level 8) gnus-button-handle-library 1)
7363 ("`\\([a-z][-a-z0-9]+\\.el\\)'"
7364 1 (>= gnus-button-emacs-level 8) gnus-button-handle-library 1)
01c52d31 7365 ("`\\([a-z][a-z0-9]+-[a-z0-9]+-[-a-z0-9]*[a-z]\\|\\(gnus\\|message\\)-[-a-z]+\\)'"
23f87bed
MB		 7366 0 (>= gnus-button-emacs-level 8) gnus-button-handle-symbol 1)
7367 ("`\\([a-z][a-z0-9]+-[a-z]+\\)'"
7368 0 (>= gnus-button-emacs-level 9) gnus-button-handle-symbol 1)
7369 ("(setq[ \t\n]+\\([a-z][a-z0-9]+-[-a-z0-9]+\\)[ \t\n]+.+)"
7370 1 (>= gnus-button-emacs-level 7) gnus-button-handle-describe-variable 1)
7371 ("\\bM-x[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET"
7372 1 (>= gnus-button-emacs-level 7) gnus-button-handle-describe-function 1)
7373 ("\\b\\(C-h\\|<?[Ff]1>?\\)[ \t\n]+f[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET"
7374 0 (>= gnus-button-emacs-level 1) gnus-button-handle-describe-function 2)
7375 ("\\b\\(C-h\\|<?[Ff]1>?\\)[ \t\n]+v[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET"
7376 0 (>= gnus-button-emacs-level 1) gnus-button-handle-describe-variable 2)
87ba2830 7377 ("`\\(\\(C-h\\|<?[Ff]1>?\\)[ \t\n]+k[ \t\n]+\\([^']+\\)\\)'"
23f87bed
MB		 7378 ;; Unlike the other regexps we really have to require quoting
7379 ;; here to determine where it ends.
7380 1 (>= gnus-button-emacs-level 1) gnus-button-handle-describe-key 3)
7381 ;; This is how URLs _should_ be embedded in text (RFC 1738, RFC 2396)...
01c52d31 7382 ("<URL: *\\([^\n<>]*\\)>"
23f87bed
MB		 7383 1 (>= gnus-button-browse-level 0) gnus-button-embedded-url 1)
7384 ;; RFC 2396 (2.4.3., delims) ...
01c52d31 7385 ("\"URL: *\\([^\n\"]*\\)\""
23f87bed 7386 1 (>= gnus-button-browse-level 0) gnus-button-embedded-url 1)
eec82323 7387 ;; Raw URLs.
23f87bed
MB		 7388 (gnus-button-url-regexp
7389 0 (>= gnus-button-browse-level 0) browse-url 0)
7390 ;; man pages
531e5812 7391 ("\\b\\([a-z][a-z]+([1-9])\\)\\W"
23f87bed
MB		 7392 0 (and (>= gnus-button-man-level 1) (< gnus-button-man-level 3))
7393 gnus-button-handle-man 1)
7394 ;; more man pages: resolv.conf(5), iso_8859-1(7), xterm(1x)
531e5812 7395 ("\\b\\([a-z][-_.a-z0-9]+([1-9])\\)\\W"
23f87bed
MB		 7396 0 (and (>= gnus-button-man-level 3) (< gnus-button-man-level 5))
7397 gnus-button-handle-man 1)
7398 ;; even more: Apache::PerlRun(3pm), PDL::IO::FastRaw(3pm),
7399 ;; SoWWWAnchor(3iv), XSelectInput(3X11), X(1), X(7)
531e5812 7400 ("\\b\\(\\(?:[a-z][-+_.:a-z0-9]+([1-9][X1a-z]*)\\)\\|\\b\\(?:X([1-9])\\)\\)\\W"
23f87bed 7401 0 (>= gnus-button-man-level 5) gnus-button-handle-man 1)
01c52d31
MB		 7402 ;; Recognizing patches to .el files. This is somewhat obscure,
7403 ;; but considering the percentage of Gnus users who hack Emacs
7404 ;; Lisp files...
7405 ("^--- \\([^ .]+\\.el\\).*\n.*\n@@ -?\\([0-9]+\\)" 1
7406 (>= gnus-button-message-level 4) gnus-button-patch 1 2)
7407 ("^\\*\\*\\* \\([^ .]+\\.el\\).*\n.*\n\\*+\n\\*\\*\\* \\([0-9]+\\)" 1
7408 (>= gnus-button-message-level 4) gnus-button-patch 1 2)
23f87bed
MB		 7409 ;; MID or mail: To avoid too many false positives we don't try to catch
7410 ;; all kind of allowed MIDs or mail addresses. Domain part must contain
7411 ;; at least one dot. TLD must contain two or three chars or be a know TLD
7412 ;; (info|name|...). Put this entry near the _end_ of `gnus-button-alist'
7413 ;; so that non-ambiguous entries (see above) match first.
7414 (gnus-button-mid-or-mail-regexp
7415 0 (>= gnus-button-message-level 5) gnus-button-handle-mid-or-mail 1))
6748645f 7416 "*Alist of regexps matching buttons in article bodies.
eec82323
LMI		 7417
7418Each entry has the form (REGEXP BUTTON FORM CALLBACK PAR...), where
23f87bed
MB		 7419REGEXP: is the string (case insensitive) matching text around the button (can
7420also be Lisp expression evaluating to a string),
eec82323 7421BUTTON: is the number of the regexp grouping actually matching the button,
4e7d0221 7422FORM: is a Lisp expression which must eval to true for the button to
eec82323
LMI		 7423be added,
7424CALLBACK: is the function to call when the user push this button, and each
7425PAR: is a number of a regexp grouping whose text will be passed to CALLBACK.
7426
7427CALLBACK can also be a variable, in that case the value of that
7428variable it the real callback function."
7429 :group 'gnus-article-buttons
23f87bed 7430 :type '(repeat (list (choice regexp variable sexp)
eec82323
LMI		 7431 (integer :tag "Button")
7432 (sexp :tag "Form")
7433 (function :tag "Callback")
7434 (repeat :tag "Par"
7435 :inline t
7436 (integer :tag "Regexp group")))))
60ece9b0 7437(put 'gnus-button-alist 'risky-local-variable t)
eec82323
LMI		 7438
7439(defcustom gnus-header-button-alist
23f87bed
MB		 7440 '(("^\\(References\\|Message-I[Dd]\\|^In-Reply-To\\):" "<[^<>]+>"
7441 0 (>= gnus-button-message-level 0) gnus-button-message-id 0)
7442 ("^\\(From\\|Reply-To\\):" ": *\\(.+\\)$"
7443 1 (>= gnus-button-message-level 0) gnus-button-reply 1)
eec82323 7444 ("^\\(Cc\\|To\\):" "[^ \t\n<>,()\"]+@[^ \t\n<>,()\"]+"
fa9a04e1 7445 0 (>= gnus-button-message-level 0) gnus-msg-mail 0)
23f87bed
MB		 7446 ("^X-[Uu][Rr][Ll]:" gnus-button-url-regexp
7447 0 (>= gnus-button-browse-level 0) browse-url 0)
7448 ("^Subject:" gnus-button-url-regexp
7449 0 (>= gnus-button-browse-level 0) browse-url 0)
7450 ("^[^:]+:" gnus-button-url-regexp
7451 0 (>= gnus-button-browse-level 0) browse-url 0)
01c52d31
MB		 7452 ("^OpenPGP:.*url=" gnus-button-url-regexp
7453 0 (>= gnus-button-browse-level 0) gnus-button-openpgp 0)
531e5812 7454 ("^[^:]+:" "\\bmailto:\\([-a-z.@_+0-9%=?&/]+\\)"
23f87bed
MB		 7455 0 (>= gnus-button-message-level 0) gnus-url-mailto 1)
7456 ("^[^:]+:" "\\(<\\(url: \\)?\\(nntp\\|news\\):\\([^>\n ]*\\)>\\)"
7457 1 (>= gnus-button-message-level 0) gnus-button-message-id 4))
6748645f 7458 "*Alist of headers and regexps to match buttons in article heads.
eec82323
LMI		 7459
7460This alist is very similar to `gnus-button-alist', except that each
7461alist has an additional HEADER element first in each entry:
7462
7463\(HEADER REGEXP BUTTON FORM CALLBACK PAR)
7464
7465HEADER is a regexp to match a header. For a fuller explanation, see
7466`gnus-button-alist'."
7467 :group 'gnus-article-buttons
7468 :group 'gnus-article-headers
7469 :type '(repeat (list (regexp :tag "Header")
23f87bed 7470 (choice regexp variable)
eec82323
LMI		 7471 (integer :tag "Button")
7472 (sexp :tag "Form")
7473 (function :tag "Callback")
7474 (repeat :tag "Par"
7475 :inline t
7476 (integer :tag "Regexp group")))))
60ece9b0 7477(put 'gnus-header-button-alist 'risky-local-variable t)
eec82323 7478
eec82323
LMI		 7479;;; Commands:
7480
7481(defun gnus-article-push-button (event)
7482 "Check text under the mouse pointer for a callback function.
7483If the text under the mouse pointer has a `gnus-callback' property,
7484call it with the value of the `gnus-data' text property."
7485 (interactive "e")
7486 (set-buffer (window-buffer (posn-window (event-start event))))
7487 (let* ((pos (posn-point (event-start event)))
23f87bed 7488 (data (get-text-property pos 'gnus-data))
eec82323 7489 (fun (get-text-property pos 'gnus-callback)))
6748645f 7490 (goto-char pos)
eec82323
LMI		 7491 (when fun
7492 (funcall fun data))))
7493
7494(defun gnus-article-press-button ()
7495 "Check text at point for a callback function.
7496If the text at point has a `gnus-callback' property,
7497call it with the value of the `gnus-data' text property."
7498 (interactive)
23f87bed
MB		 7499 (let ((data (get-text-property (point) 'gnus-data))
7500 (fun (get-text-property (point) 'gnus-callback)))
eec82323
LMI		 7501 (when fun
7502 (funcall fun data))))
7503
eec82323
LMI		 7504(defun gnus-article-highlight (&optional force)
7505 "Highlight current article.
7506This function calls `gnus-article-highlight-headers',
7507`gnus-article-highlight-citation',
7508`gnus-article-highlight-signature', and `gnus-article-add-buttons' to
7509do the highlighting. See the documentation for those functions."
7510 (interactive (list 'force))
7511 (gnus-article-highlight-headers)
7512 (gnus-article-highlight-citation force)
7513 (gnus-article-highlight-signature)
7514 (gnus-article-add-buttons force)
7515 (gnus-article-add-buttons-to-head))
7516
7517(defun gnus-article-highlight-some (&optional force)
7518 "Highlight current article.
7519This function calls `gnus-article-highlight-headers',
7520`gnus-article-highlight-signature', and `gnus-article-add-buttons' to
7521do the highlighting. See the documentation for those functions."
7522 (interactive (list 'force))
7523 (gnus-article-highlight-headers)
7524 (gnus-article-highlight-signature)
7525 (gnus-article-add-buttons))
7526
7527(defun gnus-article-highlight-headers ()
7528 "Highlight article headers as specified by `gnus-header-face-alist'."
7529 (interactive)
01c52d31
MB		 7530 (gnus-with-article-headers
7531 (let (regexp header-face field-face from hpoints fpoints)
7532 (dolist (entry gnus-header-face-alist)
7533 (goto-char (point-min))
7534 (setq regexp (concat "^\\("
7535 (if (string-equal "" (nth 0 entry))
7536 "[^\t ]"
7537 (nth 0 entry))
7538 "\\)")
7539 header-face (nth 1 entry)
7540 field-face (nth 2 entry))
7541 (while (and (re-search-forward regexp nil t)
7542 (not (eobp)))
7543 (beginning-of-line)
7544 (setq from (point))
7545 (unless (search-forward ":" nil t)
7546 (forward-char 1))
7547 (when (and header-face
7548 (not (memq (point) hpoints)))
7549 (push (point) hpoints)
7550 (gnus-put-text-property from (point) 'face header-face))
7551 (when (and field-face
7552 (not (memq (setq from (point)) fpoints)))
7553 (push from fpoints)
7554 (if (re-search-forward "^[^ \t]" nil t)
7555 (forward-char -2)
7556 (goto-char (point-max)))
7557 (gnus-put-text-property from (point) 'face field-face)))))))
eec82323
LMI		 7558
7559(defun gnus-article-highlight-signature ()
7560 "Highlight the signature in an article.
7561It does this by highlighting everything after
0f49874b 7562`gnus-signature-separator' using the face `gnus-signature'."
eec82323 7563 (interactive)
01c52d31
MB		 7564 (gnus-with-article-buffer
7565 (let ((inhibit-point-motion-hooks t))
eec82323
LMI		 7566 (save-restriction
7567 (when (and gnus-signature-face
7568 (gnus-article-narrow-to-signature))
01c52d31 7569 (gnus-overlay-put (gnus-make-overlay (point-min) (point-max) nil t)
eec82323
LMI		 7570 'face gnus-signature-face)
7571 (widen)
7572 (gnus-article-search-signature)
7573 (let ((start (match-beginning 0))
7574 (end (set-marker (make-marker) (1+ (match-end 0)))))
7575 (gnus-article-add-button start (1- end) 'gnus-signature-toggle
7576 end)))))))
7577
7578(defun gnus-button-in-region-p (b e prop)
7579 "Say whether PROP exists in the region."
7580 (text-property-not-all b e prop nil))
7581
7582(defun gnus-article-add-buttons (&optional force)
7583 "Find external references in the article and make buttons of them.
7584\"External references\" are things like Message-IDs and URLs, as
7585specified by `gnus-button-alist'."
7586 (interactive (list 'force))
01c52d31
MB		 7587 (gnus-with-article-buffer
7588 (let ((inhibit-point-motion-hooks t)
eec82323
LMI		 7589 (case-fold-search t)
7590 (alist gnus-button-alist)
7591 beg entry regexp)
7592 ;; Remove all old markers.
16409b0b 7593 (let (marker entry new-list)
eec82323 7594 (while (setq marker (pop gnus-button-marker-list))
16409b0b
GM		 7595 (if (or (< marker (point-min)) (>= marker (point-max)))
7596 (push marker new-list)
7597 (goto-char marker)
7598 (when (setq entry (gnus-button-entry))
7599 (put-text-property (match-beginning (nth 1 entry))
7600 (match-end (nth 1 entry))
7601 'gnus-callback nil))
7602 (set-marker marker nil)))
7603 (setq gnus-button-marker-list new-list))
eec82323 7604 ;; We skip the headers.
16409b0b 7605 (article-goto-body)
eec82323
LMI		 7606 (setq beg (point))
7607 (while (setq entry (pop alist))
23f87bed 7608 (setq regexp (eval (car entry)))
eec82323
LMI		 7609 (goto-char beg)
7610 (while (re-search-forward regexp nil t)
01c52d31
MB		 7611 (let ((start (match-beginning (nth 1 entry)))
7612 (end (match-end (nth 1 entry)))
7613 (from (match-beginning 0)))
eec82323
LMI		 7614 (when (and (or (eq t (nth 2 entry))
7615 (eval (nth 2 entry)))
7616 (not (gnus-button-in-region-p
7617 start end 'gnus-callback)))
7618 ;; That optional form returned non-nil, so we add the
7619 ;; button.
01c52d31
MB		 7620 (setq from (set-marker (make-marker) from))
7621 (push from gnus-button-marker-list)
7622 (unless (and (eq (car entry) 'gnus-button-url-regexp)
7623 (gnus-article-extend-url-button from start end))
7624 (gnus-article-add-button start end
7625 'gnus-button-push from)))))))))
7626
7627(defun gnus-article-extend-url-button (beg start end)
7628 "Extend url button if url is folded into two or more lines.
7629Return non-nil if button is extended. BEG is a marker that points to
7630the beginning position of a text containing url. START and END are
7631the endpoints of a url button before it is extended. The concatenated
7632url is put as the `gnus-button-url' overlay property on the button."
7633 (let ((opoint (point))
7634 (points (list start end))
7635 url delim regexp)
7636 (prog1
7637 (when (and (progn
7638 (goto-char end)
7639 (not (looking-at "[\t ]*[\">]")))
7640 (progn
7641 (goto-char start)
7642 (string-match
7643 "\\(?:\"\\|\\(<\\)\\)[\t ]*\\(?:url[\t ]*:[\t ]*\\)?\\'"
7644 (buffer-substring (point-at-bol) start)))
7645 (progn
7646 (setq url (list (buffer-substring start end))
7647 delim (if (match-beginning 1) ">" "\""))
7648 (beginning-of-line)
7649 (setq regexp (concat
7650 (when (and (looking-at
7651 message-cite-prefix-regexp)
7652 (< (match-end 0) start))
7653 (regexp-quote (match-string 0)))
7654 "\
7655\[\t ]*\\(?:\\([^\t\n \">]+\\)[\t ]*$\\|\\([^\t\n \">]*\\)[\t ]*"
7656 delim "\\)"))
7657 (while (progn
7658 (forward-line 1)
7659 (and (looking-at regexp)
7660 (prog1
7661 (match-beginning 1)
7662 (push (or (match-string 2)
7663 (match-string 1))
7664 url)
7665 (push (setq end (or (match-end 2)
7666 (match-end 1)))
7667 points)
7668 (push (or (match-beginning 2)
7669 (match-beginning 1))
7670 points)))))
7671 (match-beginning 2)))
7672 (let (gnus-article-mouse-face widget-mouse-face)
7673 (while points
7674 (gnus-article-add-button (pop points) (pop points)
7675 'gnus-button-push beg)))
7676 (let ((overlay (gnus-make-overlay start end)))
7677 (gnus-overlay-put overlay 'evaporate t)
7678 (gnus-overlay-put overlay 'gnus-button-url
7679 (list (mapconcat 'identity (nreverse url) "")))
7680 (when gnus-article-mouse-face
7681 (gnus-overlay-put overlay 'mouse-face gnus-article-mouse-face)))
7682 t)
7683 (goto-char opoint))))
eec82323
LMI		 7684
7685;; Add buttons to the head of an article.
7686(defun gnus-article-add-buttons-to-head ()
7687 "Add buttons to the head of the article."
7688 (interactive)
01c52d31
MB		 7689 (gnus-with-article-headers
7690 (let (beg end)
7691 (dolist (entry gnus-header-button-alist)
7692 ;; Each alist entry.
7693 (goto-char (point-min))
7694 (while (re-search-forward (car entry) nil t)
7695 ;; Each header matching the entry.
7696 (setq beg (match-beginning 0))
7697 (setq end (or (and (re-search-forward "^[^ \t]" nil t)
7698 (match-beginning 0))
7699 (point-max)))
7700 (goto-char beg)
7701 (while (re-search-forward (eval (nth 1 entry)) end t)
7702 ;; Each match within a header.
7703 (let* ((entry (cdr entry))
7704 (start (match-beginning (nth 1 entry)))
7705 (end (match-end (nth 1 entry)))
7706 (form (nth 2 entry)))
7707 (goto-char (match-end 0))
7708 (when (eval form)
7709 (gnus-article-add-button
7710 start end (nth 3 entry)
7711 (buffer-substring (match-beginning (nth 4 entry))
7712 (match-end (nth 4 entry)))))))
7713 (goto-char end))))))
eec82323
LMI		 7714
7715;;; External functions:
7716
7717(defun gnus-article-add-button (from to fun &optional data)
7718 "Create a button between FROM and TO with callback FUN and data DATA."
7719 (when gnus-article-button-face
01c52d31 7720 (gnus-overlay-put (gnus-make-overlay from to nil t)
eec82323
LMI		 7721 'face gnus-article-button-face))
7722 (gnus-add-text-properties
7723 from to
7724 (nconc (and gnus-article-mouse-face
7725 (list gnus-mouse-face-prop gnus-article-mouse-face))
7726 (list 'gnus-callback fun)
16409b0b
GM		 7727 (and data (list 'gnus-data data))))
7728 (widget-convert-button 'link from to :action 'gnus-widget-press-button
7729 :button-keymap gnus-widget-button-keymap))
eec82323
LMI		 7730
7731;;; Internal functions:
7732
a8151ef7 7733(defun gnus-article-set-globals ()
01c52d31 7734 (with-current-buffer gnus-summary-buffer
a8151ef7
LMI		 7735 (gnus-set-global-variables)))
7736
eec82323 7737(defun gnus-signature-toggle (end)
01c52d31
MB		 7738 (gnus-with-article-buffer
7739 (let ((inhibit-point-motion-hooks t))
520aa572 7740 (if (text-property-any end (point-max) 'article-type 'signature)
23f87bed
MB		 7741 (progn
7742 (gnus-delete-wash-type 'signature)
7743 (gnus-remove-text-properties-when
7744 'article-type 'signature end (point-max)
7745 (cons 'article-type (cons 'signature
7746 gnus-hidden-properties))))
7747 (gnus-add-wash-type 'signature)
520aa572
SZ		 7748 (gnus-add-text-properties-when
7749 'article-type nil end (point-max)
7750 (cons 'article-type (cons 'signature
23f87bed
MB		 7751 gnus-hidden-properties)))))
7752 (let ((gnus-article-mime-handle-alist-1 gnus-article-mime-handle-alist))
7753 (gnus-set-mode-line 'article))))
eec82323
LMI		 7754
7755(defun gnus-button-entry ()
7756 ;; Return the first entry in `gnus-button-alist' matching this place.
7757 (let ((alist gnus-button-alist)
7758 (entry nil))
7759 (while alist
7760 (setq entry (pop alist))
23f87bed 7761 (if (looking-at (eval (car entry)))
eec82323
LMI		 7762 (setq alist nil)
7763 (setq entry nil)))
7764 entry))
7765
7766(defun gnus-button-push (marker)
7767 ;; Push button starting at MARKER.
7768 (save-excursion
eec82323
LMI		 7769 (goto-char marker)
7770 (let* ((entry (gnus-button-entry))
7771 (inhibit-point-motion-hooks t)
7772 (fun (nth 3 entry))
01c52d31
MB		 7773 (args (or (and (eq (car entry) 'gnus-button-url-regexp)
7774 (get-char-property marker 'gnus-button-url))
7775 (mapcar (lambda (group)
7776 (let ((string (match-string group)))
7777 (set-text-properties
7778 0 (length string) nil string)
7779 string))
7780 (nthcdr 4 entry)))))
eec82323
LMI		 7781 (cond
7782 ((fboundp fun)
7783 (apply fun args))
7784 ((and (boundp fun)
7785 (fboundp (symbol-value fun)))
7786 (apply (symbol-value fun) args))
7787 (t
7788 (gnus-message 1 "You must define `%S' to use this button"
7789 (cons fun args)))))))
7790
23f87bed 7791(defun gnus-parse-news-url (url)
82a8ad04 7792 (let (scheme server port group message-id articles)
23f87bed
MB		 7793 (with-temp-buffer
7794 (insert url)
7795 (goto-char (point-min))
7796 (when (looking-at "\\([A-Za-z]+\\):")
7797 (setq scheme (match-string 1))
7798 (goto-char (match-end 0)))
82a8ad04 7799 (when (looking-at "//\\([^:/]+\\)\\(:?\\)\\([0-9]+\\)?/")
23f87bed 7800 (setq server (match-string 1))
82a8ad04
MB		 7801 (setq port (if (stringp (match-string 3))
7802 (string-to-number (match-string 3))
7803 (match-string 3)))
23f87bed
MB		 7804 (goto-char (match-end 0)))
7805
7806 (cond
7807 ((looking-at "\\(.*@.*\\)")
7808 (setq message-id (match-string 1)))
7809 ((looking-at "\\([^/]+\\)/\\([-0-9]+\\)")
7810 (setq group (match-string 1)
7811 articles (split-string (match-string 2) "-")))
7812 ((looking-at "\\([^/]+\\)/?")
7813 (setq group (match-string 1)))
7814 (t
7815 (error "Unknown news URL syntax"))))
82a8ad04 7816 (list scheme server port group message-id articles)))
23f87bed
MB		 7817
7818(defun gnus-button-handle-news (url)
7819 "Fetch a news URL."
82a8ad04 7820 (destructuring-bind (scheme server port group message-id articles)
23f87bed
MB		 7821 (gnus-parse-news-url url)
7822 (cond
7823 (message-id
80de1778 7824 (with-current-buffer gnus-summary-buffer
23f87bed 7825 (if server
ff4d3926
MB		 7826 (let ((gnus-refer-article-method
7827 (nconc (list (list 'nntp server))
7828 gnus-refer-article-method))
82a8ad04 7829 (nntp-port-number (or port "nntp")))
ff4d3926
MB		 7830 (gnus-message 7 "Fetching %s with %s"
7831 message-id gnus-refer-article-method)
23f87bed
MB		 7832 (gnus-summary-refer-article message-id))
7833 (gnus-summary-refer-article message-id))))
7834 (group
7835 (gnus-button-fetch-group url)))))
7836
01c52d31
MB		 7837(defun gnus-button-patch (library line)
7838 "Visit an Emacs Lisp library LIBRARY on line LINE."
7839 (interactive)
7840 (let ((file (locate-library (file-name-nondirectory library))))
7841 (unless file
7842 (error "Couldn't find library %s" library))
7843 (find-file file)
7844 (goto-line (string-to-number line))))
7845
23f87bed
MB		 7846(defun gnus-button-handle-man (url)
7847 "Fetch a man page."
531e5812
MB		 7848 (gnus-message 9 "`%s' `%s'" gnus-button-man-handler url)
7849 (when (eq gnus-button-man-handler 'woman)
7850 (setq url (gnus-replace-in-string url "([1-9][X1a-z]*).*\\'" "")))
7851 (gnus-message 9 "`%s' `%s'" gnus-button-man-handler url)
23f87bed
MB		 7852 (funcall gnus-button-man-handler url))
7853
7854(defun gnus-button-handle-info-url (url)
7855 "Fetch an info URL."
7856 (setq url (mm-subst-char-in-string ?+ ?\ url))
7857 (cond
7858 ((string-match "^\\([^:/]+\\)?/\\(.*\\)" url)
7859 (gnus-info-find-node
7860 (concat "(" (or (gnus-url-unhex-string (match-string 1 url))
7861 "Gnus")
7862 ")" (gnus-url-unhex-string (match-string 2 url)))))
7863 ((string-match "([^)\"]+)[^\"]+" url)
7864 (setq url
7865 (gnus-replace-in-string
7866 (gnus-replace-in-string url "[\n\t ]+" " ") "\"" ""))
7867 (gnus-info-find-node url))
7868 (t (error "Can't parse %s" url))))
7869
7870(defun gnus-button-handle-info-url-gnome (url)
7871 "Fetch GNOME style info URL."
7872 (setq url (mm-subst-char-in-string ?_ ?\ url))
7873 (if (string-match "\\([^#]+\\)#?\\(.*\\)" url)
7874 (gnus-info-find-node
7875 (concat "("
bf247b6e 7876 (gnus-url-unhex-string
23f87bed
MB		 7877 (match-string 1 url))
7878 ")"
bf247b6e 7879 (or (gnus-url-unhex-string
23f87bed
MB		 7880 (match-string 2 url))
7881 "Top")))
7882 (error "Can't parse %s" url)))
7883
7884(defun gnus-button-handle-info-url-kde (url)
7885 "Fetch KDE style info URL."
7886 (gnus-info-find-node (gnus-url-unhex-string url)))
7887
9640c3bc
GM		 7888;; (info) will autoload info.el
7889(declare-function Info-menu "info" (menu-item &optional fork))
7890
23f87bed
MB		 7891(defun gnus-button-handle-info-keystrokes (url)
7892 "Call `info' when pushing the corresponding URL button."
7893 ;; For links like `C-h i d m gnus RET', `C-h i d m CC Mode RET'.
7894 (info)
7895 (Info-directory)
7896 (Info-menu url))
1888e568
GM		 7897
7898;; Called after pgg-snarf-keys-region, which autoloads pgg.el.
7899(declare-function pgg-display-output-buffer "pgg" (start end status))
23f87bed 7900
01c52d31
MB		 7901(defun gnus-button-openpgp (url)
7902 "Retrieve and add an OpenPGP key given URL from an OpenPGP header."
7903 (with-temp-buffer
7904 (mm-url-insert-file-contents-external url)
7905 (pgg-snarf-keys-region (point-min) (point-max))
7906 (pgg-display-output-buffer nil nil nil)))
7907
eec82323
LMI		 7908(defun gnus-button-message-id (message-id)
7909 "Fetch MESSAGE-ID."
01c52d31 7910 (with-current-buffer gnus-summary-buffer
eec82323
LMI		 7911 (gnus-summary-refer-article message-id)))
7912
01c52d31 7913(defun gnus-button-fetch-group (address &rest ignore)
eec82323 7914 "Fetch GROUP specified by ADDRESS."
01c52d31
MB		 7915 (when (string-match "\\`\\(nntp\\|news\\):\\(//\\)?\\(.*\\)\\'"
7916 address)
7917 ;; Allow to use `gnus-button-fetch-group' in `browse-url-browser-function'
7918 ;; for nntp:// and news://
7919 (setq address (match-string 3 address)))
eec82323
LMI		 7920 (if (not (string-match "[:/]" address))
7921 ;; This is just a simple group url.
7922 (gnus-group-read-ephemeral-group address gnus-select-method)
23f87bed
MB		 7923 (if (not
7924 (string-match
7925 "^\\([^:/]+\\)\\(:\\([^/]+\\)\\)?/\\([^/]+\\)\\(/\\([0-9]+\\)\\)?"
7926 address))
eec82323
LMI		 7927 (error "Can't parse %s" address)
7928 (gnus-group-read-ephemeral-group
7929 (match-string 4 address)
7930 `(nntp ,(match-string 1 address)
7931 (nntp-address ,(match-string 1 address))
7932 (nntp-port-number ,(if (match-end 3)
7933 (match-string 3 address)
23f87bed
MB		 7934 "nntp")))
7935 nil nil nil
e9bd5782 7936 (and (match-end 6) (list (string-to-number (match-string 6 address))))))))
eec82323 7937
eec82323
LMI		 7938(defun gnus-url-parse-query-string (query &optional downcase)
7939 (let (retval pairs cur key val)
16409b0b 7940 (setq pairs (split-string query "&"))
eec82323
LMI		 7941 (while pairs
7942 (setq cur (car pairs)
23f87bed 7943 pairs (cdr pairs))
eec82323 7944 (if (not (string-match "=" cur))
23f87bed
MB		 7945 nil ; Grace
7946 (setq key (gnus-url-unhex-string (substring cur 0 (match-beginning 0)))
7947 val (gnus-url-unhex-string (substring cur (match-end 0) nil) t))
7948 (if downcase
7949 (setq key (downcase key)))
7950 (setq cur (assoc key retval))
7951 (if cur
7952 (setcdr cur (cons val (cdr cur)))
7953 (setq retval (cons (list key val) retval)))))
eec82323
LMI		 7954 retval))
7955
eec82323
LMI		 7956(defun gnus-url-mailto (url)
7957 ;; Send mail to someone
7958 (when (string-match "mailto:/*\\(.*\\)" url)
7959 (setq url (substring url (match-beginning 1) nil)))
6748645f 7960 (let (to args subject func)
23f87bed
MB		 7961 (setq args (gnus-url-parse-query-string
7962 (if (string-match "^\\?" url)
7963 (substring url 1)
7964 (if (string-match "^\\([^?]+\\)\\?\\(.*\\)" url)
7965 (concat "to=" (match-string 1 url) "&"
7966 (match-string 2 url))
7967 (concat "to=" url)))
7968 t)
7969 subject (cdr-safe (assoc "subject" args)))
7970 (gnus-msg-mail)
eec82323
LMI		 7971 (while args
7972 (setq func (intern-soft (concat "message-goto-" (downcase (caar args)))))
7973 (if (fboundp func)
23f87bed
MB		 7974 (funcall func)
7975 (message-position-on-field (caar args)))
7976 (insert (gnus-replace-in-string
7977 (mapconcat 'identity (reverse (cdar args)) ", ")
7978 "\r\n" "\n" t))
eec82323
LMI		 7979 (setq args (cdr args)))
7980 (if subject
23f87bed 7981 (message-goto-body)
eec82323
LMI		 7982 (message-goto-subject))))
7983
eec82323 7984(defun gnus-button-embedded-url (address)
e0bad764 7985 "Activate ADDRESS with `browse-url'."
1b978bfc 7986 (browse-url (gnus-strip-whitespace address)))
eec82323
LMI		 7987
7988;;; Next/prev buttons in the article buffer.
7989
7990(defvar gnus-next-page-line-format "%{%(Next page...%)%}\n")
7991(defvar gnus-prev-page-line-format "%{%(Previous page...%)%}\n")
7992
23f87bed
MB		 7993(defvar gnus-prev-page-map
7994 (let ((map (make-sparse-keymap)))
23f87bed
MB		 7995 (define-key map gnus-mouse-2 'gnus-button-prev-page)
7996 (define-key map "\r" 'gnus-button-prev-page)
7997 map))
7998
7999(defvar gnus-next-page-map
8000 (let ((map (make-sparse-keymap)))
8001 (unless (>= emacs-major-version 21)
8002 ;; XEmacs doesn't care.
8003 (set-keymap-parent map gnus-article-mode-map))
8004 (define-key map gnus-mouse-2 'gnus-button-next-page)
8005 (define-key map "\r" 'gnus-button-next-page)
8006 map))
eec82323
LMI		 8007
8008(defun gnus-insert-prev-page-button ()
01c52d31 8009 (let ((b (point)) e
23f87bed 8010 (inhibit-read-only t))
eec82323
LMI		 8011 (gnus-eval-format
8012 gnus-prev-page-line-format nil
01c52d31
MB		 8013 `(keymap ,gnus-prev-page-map
8014 gnus-prev t
8015 gnus-callback gnus-article-button-prev-page
8016 article-type annotation))
8017 (setq e (if (bolp)
8018 ;; Exclude a newline.
8019 (1- (point))
8020 (point)))
8021 (when gnus-article-button-face
8022 (gnus-overlay-put (gnus-make-overlay b e nil t)
8023 'face gnus-article-button-face))
23f87bed 8024 (widget-convert-button
01c52d31 8025 'link b e
23f87bed
MB		 8026 :action 'gnus-button-prev-page
8027 :button-keymap gnus-prev-page-map)))
8028
8029(defun gnus-button-next-page (&optional args more-args)
eec82323
LMI		 8030 "Go to the next page."
8031 (interactive)
8032 (let ((win (selected-window)))
23f87bed 8033 (select-window (gnus-get-buffer-window gnus-article-buffer t))
eec82323
LMI		 8034 (gnus-article-next-page)
8035 (select-window win)))
8036
23f87bed 8037(defun gnus-button-prev-page (&optional args more-args)
eec82323
LMI		 8038 "Go to the prev page."
8039 (interactive)
8040 (let ((win (selected-window)))
23f87bed 8041 (select-window (gnus-get-buffer-window gnus-article-buffer t))
eec82323
LMI		 8042 (gnus-article-prev-page)
8043 (select-window win)))
8044
8045(defun gnus-insert-next-page-button ()
01c52d31 8046 (let ((b (point)) e
23f87bed 8047 (inhibit-read-only t))
eec82323 8048 (gnus-eval-format gnus-next-page-line-format nil
01c52d31
MB		 8049 `(keymap ,gnus-next-page-map
8050 gnus-next t
8051 gnus-callback gnus-article-button-next-page
8052 article-type annotation))
8053 (setq e (if (bolp)
8054 ;; Exclude a newline.
8055 (1- (point))
8056 (point)))
8057 (when gnus-article-button-face
8058 (gnus-overlay-put (gnus-make-overlay b e nil t)
8059 'face gnus-article-button-face))
23f87bed 8060 (widget-convert-button
01c52d31 8061 'link b e
23f87bed
MB		 8062 :action 'gnus-button-next-page
8063 :button-keymap gnus-next-page-map)))
eec82323
LMI		 8064
8065(defun gnus-article-button-next-page (arg)
8066 "Go to the next page."
8067 (interactive "P")
8068 (let ((win (selected-window)))
23f87bed 8069 (select-window (gnus-get-buffer-window gnus-article-buffer t))
eec82323
LMI		 8070 (gnus-article-next-page)
8071 (select-window win)))
8072
8073(defun gnus-article-button-prev-page (arg)
8074 "Go to the prev page."
8075 (interactive "P")
8076 (let ((win (selected-window)))
23f87bed 8077 (select-window (gnus-get-buffer-window gnus-article-buffer t))
eec82323
LMI		 8078 (gnus-article-prev-page)
8079 (select-window win)))
8080
16409b0b
GM		 8081(defvar gnus-decode-header-methods
8082 '(mail-decode-encoded-word-region)
8083 "List of methods used to decode headers.
8084
8085This variable is a list of FUNCTION or (REGEXP . FUNCTION). If item
4e7d0221 8086is FUNCTION, FUNCTION will be applied to all newsgroups. If item is a
23f87bed 8087\(REGEXP . FUNCTION), FUNCTION will be only apply to the newsgroups
16409b0b
GM		 8088whose names match REGEXP.
8089
8090For example:
8f688cb0 8091\((\"chinese\" . gnus-decode-encoded-word-region-by-guess)
16409b0b
GM		 8092 mail-decode-encoded-word-region
8093 (\"chinese\" . rfc1843-decode-region))
8094")
8095
8096(defvar gnus-decode-header-methods-cache nil)
8097
8098(defun gnus-multi-decode-header (start end)
8099 "Apply the functions from `gnus-encoded-word-methods' that match."
8100 (unless (and gnus-decode-header-methods-cache
8101 (eq gnus-newsgroup-name
8102 (car gnus-decode-header-methods-cache)))
8103 (setq gnus-decode-header-methods-cache (list gnus-newsgroup-name))
01c52d31
MB		 8104 (dolist (x gnus-decode-header-methods)
8105 (if (symbolp x)
8106 (nconc gnus-decode-header-methods-cache (list x))
8107 (if (and gnus-newsgroup-name
8108 (string-match (car x) gnus-newsgroup-name))
8109 (nconc gnus-decode-header-methods-cache
8110 (list (cdr x)))))))
16409b0b
GM		 8111 (let ((xlist gnus-decode-header-methods-cache))
8112 (pop xlist)
8113 (save-restriction
8114 (narrow-to-region start end)
8115 (while xlist
8116 (funcall (pop xlist) (point-min) (point-max))))))
8117
8118;;;
8119;;; Treatment top-level handling.
8120;;;
8121
8122(defun gnus-treat-article (condition &optional part-number total-parts type)
8123 (let ((length (- (point-max) (point-min)))
8124 (alist gnus-treatment-function-alist)
8125 (article-goto-body-goes-to-point-min-p t)
8126 (treated-type
8127 (or (not type)
8128 (catch 'found
8129 (let ((list gnus-article-treat-types))
8130 (while list
8131 (when (string-match (pop list) type)
8132 (throw 'found t)))))))
8133 (highlightp (gnus-visual-p 'article-highlight 'highlight))
8134 val elem)
8135 (gnus-run-hooks 'gnus-part-display-hook)
23f87bed 8136 (dolist (elem alist)
16409b0b
GM		 8137 (setq val
8138 (save-excursion
23f87bed
MB		 8139 (when (gnus-buffer-live-p gnus-summary-buffer)
8140 (set-buffer gnus-summary-buffer))
16409b0b
GM		 8141 (symbol-value (car elem))))
8142 (when (and (or (consp val)
8143 treated-type)
8144 (gnus-treat-predicate val)
8145 (or (not (get (car elem) 'highlight))
8146 highlightp))
8147 (save-restriction
8148 (funcall (cadr elem)))))))
8149
8150;; Dynamic variables.
9efa445f
DN		 8151(defvar part-number)
8152(defvar total-parts)
8153(defvar type)
8154(defvar condition)
8155(defvar length)
e0bad764 8156
16409b0b
GM		 8157(defun gnus-treat-predicate (val)
8158 (cond
8159 ((null val)
8160 nil)
23f87bed
MB		 8161 (condition
8162 (eq condition val))
16409b0b
GM		 8163 ((and (listp val)
8164 (stringp (car val)))
8165 (apply 'gnus-or (mapcar `(lambda (s)
8166 (string-match s ,(or gnus-newsgroup-name "")))
8167 val)))
8168 ((listp val)
8169 (let ((pred (pop val)))
8170 (cond
8171 ((eq pred 'or)
8172 (apply 'gnus-or (mapcar 'gnus-treat-predicate val)))
8173 ((eq pred 'and)
8174 (apply 'gnus-and (mapcar 'gnus-treat-predicate val)))
8175 ((eq pred 'not)
8176 (not (gnus-treat-predicate (car val))))
8177 ((eq pred 'typep)
8178 (equal (car val) type))
8179 (t
8180 (error "%S is not a valid predicate" pred)))))
16409b0b
GM		 8181 ((eq val t)
8182 t)
8183 ((eq val 'head)
8184 nil)
01c52d31
MB		 8185 ((eq val 'first)
8186 (eq part-number 1))
16409b0b
GM		 8187 ((eq val 'last)
8188 (eq part-number total-parts))
8189 ((numberp val)
8190 (< length val))
8191 (t
8192 (error "%S is not a valid value" val))))
8193
23f87bed
MB		 8194(defun gnus-article-encrypt-body (protocol &optional n)
8195 "Encrypt the article body."
8196 (interactive
8197 (list
8198 (or gnus-article-encrypt-protocol
8199 (completing-read "Encrypt protocol: "
8200 gnus-article-encrypt-protocol-alist
8201 nil t))
8202 current-prefix-arg))
bbbe940b
MB		 8203 ;; User might hit `K E' instead of `K e', so prompt once.
8204 (when (and gnus-article-encrypt-protocol
8205 gnus-novice-user)
8206 (unless (gnus-y-or-n-p "Really encrypt article(s)? ")
8207 (error "Encrypt aborted.")))
23f87bed
MB		 8208 (let ((func (cdr (assoc protocol gnus-article-encrypt-protocol-alist))))
8209 (unless func
998a5a95 8210 (error "Can't find the encrypt protocol %s" protocol))
23f87bed
MB		 8211 (if (member gnus-newsgroup-name '("nndraft:delayed"
8212 "nndraft:drafts"
8213 "nndraft:queue"))
8214 (error "Can't encrypt the article in group %s"
8215 gnus-newsgroup-name))
8216 (gnus-summary-iterate n
80de1778 8217 (with-current-buffer gnus-summary-buffer
23f87bed
MB		 8218 (let ((mail-parse-charset gnus-newsgroup-charset)
8219 (mail-parse-ignored-charsets gnus-newsgroup-ignored-charsets)
8220 (summary-buffer gnus-summary-buffer)
8221 references point)
8222 (gnus-set-global-variables)
8223 (when (gnus-group-read-only-p)
8224 (error "The current newsgroup does not support article encrypt"))
8225 (gnus-summary-show-article t)
8226 (setq references
8227 (or (mail-header-references gnus-current-headers) ""))
8228 (set-buffer gnus-article-buffer)
8229 (let* ((inhibit-read-only t)
8230 (headers
8231 (mapcar (lambda (field)
8232 (and (save-restriction
8233 (message-narrow-to-head)
8234 (goto-char (point-min))
8235 (search-forward field nil t))
8236 (prog2
8237 (message-narrow-to-field)
8238 (buffer-string)
8239 (delete-region (point-min) (point-max))
8240 (widen))))
8241 '("Content-Type:" "Content-Transfer-Encoding:"
8242 "Content-Disposition:"))))
8243 (message-narrow-to-head)
8244 (message-remove-header "MIME-Version")
8245 (goto-char (point-max))
8246 (setq point (point))
8247 (insert (apply 'concat headers))
8248 (widen)
8249 (narrow-to-region point (point-max))
8250 (let ((message-options message-options))
8251 (message-options-set 'message-sender user-mail-address)
8252 (message-options-set 'message-recipients user-mail-address)
8253 (message-options-set 'message-sign-encrypt 'not)
8254 (funcall func))
8255 (goto-char (point-min))
8256 (insert "MIME-Version: 1.0\n")
8257 (widen)
8258 (gnus-summary-edit-article-done
8259 references nil summary-buffer t))
8260 (when gnus-keep-backlog
8261 (gnus-backlog-remove-article
8262 (car gnus-article-current) (cdr gnus-article-current)))
80de1778
SM		 8263 (when (get-buffer gnus-original-article-buffer)
8264 (with-current-buffer gnus-original-article-buffer
23f87bed
MB		 8265 (setq gnus-original-article nil)))
8266 (when gnus-use-cache
8267 (gnus-cache-update-article
8268 (car gnus-article-current) (cdr gnus-article-current))))))))
8269
8270(defvar gnus-mime-security-button-line-format "%{%([[%t:%i]%D]%)%}\n"
8271 "The following specs can be used:
8272%t The security MIME type
8273%i Additional info
8274%d Details
8275%D Details if button is pressed")
8276
8277(defvar gnus-mime-security-button-end-line-format "%{%([[End of %t]%D]%)%}\n"
8278 "The following specs can be used:
8279%t The security MIME type
8280%i Additional info
8281%d Details
8282%D Details if button is pressed")
8283
8284(defvar gnus-mime-security-button-line-format-alist
8285 '((?t gnus-tmp-type ?s)
8286 (?i gnus-tmp-info ?s)
8287 (?d gnus-tmp-details ?s)
8288 (?D gnus-tmp-pressed-details ?s)))
8289
01c52d31
MB		 8290(defvar gnus-mime-security-button-commands
8291 '((gnus-article-press-button "\r" "Show Detail")
8292 (undefined "v")
8293 (undefined "t")
8294 (undefined "C")
8295 (gnus-mime-security-save-part "o" "Save...")
8296 (undefined "\C-o")
8297 (undefined "r")
8298 (undefined "d")
8299 (undefined "c")
8300 (undefined "i")
8301 (undefined "E")
8302 (undefined "e")
8303 (undefined "p")
8304 (gnus-mime-security-pipe-part "|" "Pipe To Command...")
8305 (undefined ".")))
8306
23f87bed
MB		 8307(defvar gnus-mime-security-button-map
8308 (let ((map (make-sparse-keymap)))
23f87bed 8309 (define-key map gnus-mouse-2 'gnus-article-push-button)
01c52d31
MB		 8310 (define-key map gnus-down-mouse-3 'gnus-mime-security-button-menu)
8311 (dolist (c gnus-mime-security-button-commands)
8312 (define-key map (cadr c) (car c)))
23f87bed
MB		 8313 map))
8314
01c52d31
MB		 8315(easy-menu-define
8316 gnus-mime-security-button-menu gnus-mime-security-button-map
8317 "Security button menu."
8318 `("Security Part"
8319 ,@(delq nil
8320 (mapcar (lambda (c)
8321 (unless (eq (car c) 'undefined)
8322 (vector (caddr c) (car c) :active t)))
8323 gnus-mime-security-button-commands))))
8324
8325(defun gnus-mime-security-button-menu (event prefix)
8326 "Construct a context-sensitive menu of security commands."
8327 (interactive "e\nP")
8328 (save-window-excursion
8329 (let ((pos (event-start event)))
8330 (select-window (posn-window pos))
8331 (goto-char (posn-point pos))
8332 (gnus-article-check-buffer)
8333 (popup-menu gnus-mime-security-button-menu nil prefix))))
8334
23f87bed
MB		 8335(defvar gnus-mime-security-details-buffer nil)
8336
8337(defvar gnus-mime-security-button-pressed nil)
8338
8339(defvar gnus-mime-security-show-details-inline t
8340 "If non-nil, show details in the article buffer.")
8341
8342(defun gnus-mime-security-verify-or-decrypt (handle)
8343 (mm-remove-parts (cdr handle))
8344 (let ((region (mm-handle-multipart-ctl-parameter handle 'gnus-region))
8345 point (inhibit-read-only t))
8346 (if region
8347 (goto-char (car region)))
01c52d31
MB		 8348 (setq point (point))
8349 (with-current-buffer (mm-handle-multipart-original-buffer handle)
8350 (let* ((mm-verify-option 'known)
8351 (mm-decrypt-option 'known)
8352 (nparts (mm-possibly-verify-or-decrypt (cdr handle) handle)))
8353 (unless (eq nparts (cdr handle))
8354 (mm-destroy-parts (cdr handle))
8355 (setcdr handle nparts))))
8356 (gnus-mime-display-security handle)
23f87bed
MB		 8357 (when region
8358 (delete-region (point) (cdr region))
8359 (set-marker (car region) nil)
8360 (set-marker (cdr region) nil))
8361 (goto-char point)))
8362
8363(defun gnus-mime-security-show-details (handle)
8364 (let ((details (mm-handle-multipart-ctl-parameter handle 'gnus-details)))
8365 (if (not details)
8366 (gnus-message 5 "No details.")
8367 (if gnus-mime-security-show-details-inline
8368 (let ((gnus-mime-security-button-pressed
8369 (not (get-text-property (point) 'gnus-mime-details)))
8370 (gnus-mime-security-button-line-format
8371 (get-text-property (point) 'gnus-line-format))
8372 (inhibit-read-only t))
8373 (forward-char -1)
8374 (while (eq (get-text-property (point) 'gnus-line-format)
8375 gnus-mime-security-button-line-format)
8376 (forward-char -1))
8377 (forward-char)
8378 (save-restriction
8379 (narrow-to-region (point) (point))
8380 (gnus-insert-mime-security-button handle))
8381 (delete-region (point)
8382 (or (text-property-not-all
8383 (point) (point-max)
8384 'gnus-line-format
8385 gnus-mime-security-button-line-format)
8386 (point-max))))
8387 ;; Not inlined.
8388 (if (gnus-buffer-live-p gnus-mime-security-details-buffer)
8389 (with-current-buffer gnus-mime-security-details-buffer
8390 (erase-buffer)
8391 t)
8392 (setq gnus-mime-security-details-buffer
8393 (gnus-get-buffer-create "*MIME Security Details*")))
8394 (with-current-buffer gnus-mime-security-details-buffer
8395 (insert details)
8396 (goto-char (point-min)))
8397 (pop-to-buffer gnus-mime-security-details-buffer)))))
8398
8399(defun gnus-mime-security-press-button (handle)
8400 (save-excursion
8401 (if (mm-handle-multipart-ctl-parameter handle 'gnus-info)
8402 (gnus-mime-security-show-details handle)
8403 (gnus-mime-security-verify-or-decrypt handle))))
8404
8405(defun gnus-insert-mime-security-button (handle &optional displayed)
8406 (let* ((protocol (mm-handle-multipart-ctl-parameter handle 'protocol))
8407 (gnus-tmp-type
8408 (concat
8409 (or (nth 2 (assoc protocol mm-verify-function-alist))
8410 (nth 2 (assoc protocol mm-decrypt-function-alist))
8411 "Unknown")
8412 (if (equal (car handle) "multipart/signed")
8413 " Signed" " Encrypted")
8414 " Part"))
8415 (gnus-tmp-info
8416 (or (mm-handle-multipart-ctl-parameter handle 'gnus-info)
8417 "Undecided"))
8418 (gnus-tmp-details
8419 (mm-handle-multipart-ctl-parameter handle 'gnus-details))
8420 gnus-tmp-pressed-details
8421 b e)
8422 (setq gnus-tmp-details
8423 (if gnus-tmp-details
8424 (concat "\n" gnus-tmp-details)
8425 ""))
8426 (setq gnus-tmp-pressed-details
8427 (if gnus-mime-security-button-pressed gnus-tmp-details ""))
8428 (unless (bolp)
8429 (insert "\n"))
8430 (setq b (point))
8431 (gnus-eval-format
8432 gnus-mime-security-button-line-format
8433 gnus-mime-security-button-line-format-alist
01c52d31 8434 `(keymap ,gnus-mime-security-button-map
23f87bed
MB		 8435 gnus-callback gnus-mime-security-press-button
8436 gnus-line-format ,gnus-mime-security-button-line-format
8437 gnus-mime-details ,gnus-mime-security-button-pressed
8438 article-type annotation
8439 gnus-data ,handle))
8440 (setq e (if (bolp)
8441 ;; Exclude a newline.
8442 (1- (point))
8443 (point)))
01c52d31
MB		 8444 (when gnus-article-button-face
8445 (gnus-overlay-put (gnus-make-overlay b e nil t)
8446 'face gnus-article-button-face))
23f87bed
MB		 8447 (widget-convert-button
8448 'link b e
8449 :mime-handle handle
8450 :action 'gnus-widget-press-button
8451 :button-keymap gnus-mime-security-button-map
8452 :help-echo
8453 (lambda (widget/window &optional overlay pos)
8454 ;; Needed to properly clear the message due to a bug in
8455 ;; wid-edit (XEmacs only).
8456 (when (boundp 'help-echo-owns-message)
8457 (setq help-echo-owns-message t))
8458 (format
01c52d31
MB		 8459 "%S: show detail; %S: more options"
8460 (aref gnus-mouse-2 0)
8461 (aref gnus-down-mouse-3 0))))))
23f87bed
MB		 8462
8463(defun gnus-mime-display-security (handle)
8464 (save-restriction
8465 (narrow-to-region (point) (point))
8466 (unless (gnus-unbuttonized-mime-type-p (car handle))
8467 (gnus-insert-mime-security-button handle))
01c52d31 8468 (gnus-mime-display-part (cadr handle))
23f87bed
MB		 8469 (unless (bolp)
8470 (insert "\n"))
8471 (unless (gnus-unbuttonized-mime-type-p (car handle))
8472 (let ((gnus-mime-security-button-line-format
8473 gnus-mime-security-button-end-line-format))
8474 (gnus-insert-mime-security-button handle)))
8475 (mm-set-handle-multipart-parameter
8476 handle 'gnus-region
8477 (cons (set-marker (make-marker) (point-min))
01c52d31
MB		 8478 (set-marker (make-marker) (point-max))))
8479 (goto-char (point-max))))
8480
8481(defun gnus-mime-security-run-function (function)
8482 "Run FUNCTION with the security part under point."
8483 (gnus-article-check-buffer)
8484 (let ((data (get-text-property (point) 'gnus-data))
8485 buffer handle)
8486 (when (and (stringp (car-safe data))
8487 (setq buffer (mm-handle-multipart-original-buffer data))
8488 (setq handle (cadr data)))
8489 (if (bufferp (mm-handle-buffer handle))
8490 (progn
8491 (setq handle (cons buffer (copy-sequence (cdr handle))))
8492 (mm-handle-set-undisplayer handle nil))
8493 (setq handle (mm-make-handle
8494 buffer
8495 (mm-handle-multipart-ctl-parameter handle 'protocol)
8496 nil nil nil nil nil nil)))
8497 (funcall function handle))))
8498
8499(defun gnus-mime-security-save-part ()
8500 "Save the security part under point."
8501 (interactive)
8502 (gnus-mime-security-run-function 'mm-save-part))
8503
8504(defun gnus-mime-security-pipe-part ()
8505 "Pipe the security part under point to a process."
8506 (interactive)
8507 (gnus-mime-security-run-function 'mm-pipe-part))
23f87bed 8508
eec82323
LMI		 8509(gnus-ems-redefine)
8510
8511(provide 'gnus-art)
8512
8513(run-hooks 'gnus-art-load-hook)
8514
80de1778 8515;; arch-tag: 2654516f-6279-48f9-a83b-05c1fa450c33
eec82323 8516;;; gnus-art.el ends here
Unnamed repository; edit this file 'description' to name the repository.