HCoop / bpt / emacs.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
shr.el (shr-render-td): Only do colours at the final rendering. Should be slightly...
[bpt/emacs.git] / lisp / gnus / gnus-art.el
CommitLineData
eec82323 1;;; gnus-art.el --- article mode commands for Gnus
e84b4b86 2
73b0cd50 3;; Copyright (C) 1996-2011 Free Software Foundation, Inc.
eec82323 4
6748645f 5;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
eec82323
LMI		 6;; Keywords: news
7
8;; This file is part of GNU Emacs.
9
5e809f55 10;; GNU Emacs is free software: you can redistribute it and/or modify
eec82323 11;; it under the terms of the GNU General Public License as published by
5e809f55
GM		 12;; the Free Software Foundation, either version 3 of the License, or
13;; (at your option) any later version.
eec82323
LMI		 14
15;; GNU Emacs is distributed in the hope that it will be useful,
16;; but WITHOUT ANY WARRANTY; without even the implied warranty of
2ff9f5b4 17;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
eec82323
LMI		 18;; GNU General Public License for more details.
19
20;; You should have received a copy of the GNU General Public License
5e809f55 21;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
eec82323
LMI		 22
23;;; Commentary:
24
25;;; Code:
26
f0b7f5a8 27;; For Emacs <22.2 and XEmacs.
9640c3bc
GM		 28(eval-and-compile
29 (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
23f87bed 30(eval-when-compile
9efa445f
DN		 31 (require 'cl))
32(defvar tool-bar-map)
33(defvar w3m-minor-mode-map)
5ab7173c 34
eec82323 35(require 'gnus)
5843126b 36(require 'gnus-sum)
eec82323
LMI		 37(require 'gnus-spec)
38(require 'gnus-int)
23f87bed 39(require 'gnus-win)
16409b0b
GM		 40(require 'mm-bodies)
41(require 'mail-parse)
42(require 'mm-decode)
43(require 'mm-view)
44(require 'wid-edit)
45(require 'mm-uu)
23f87bed
MB		 46(require 'message)
47
48(autoload 'gnus-msg-mail "gnus-msg" nil t)
49(autoload 'gnus-button-mailto "gnus-msg")
50(autoload 'gnus-button-reply "gnus-msg" nil t)
498063ec 51(autoload 'parse-time-string "parse-time" nil nil)
01c52d31
MB		 52(autoload 'ansi-color-apply-on-region "ansi-color")
53(autoload 'mm-url-insert-file-contents-external "mm-url")
531bedc3 54(autoload 'mm-extern-cache-contents "mm-extern")
eec82323
LMI		 55
56(defgroup gnus-article nil
57 "Article display."
23f87bed 58 :link '(custom-manual "(gnus)Article Buffer")
eec82323
LMI		 59 :group 'gnus)
60
16409b0b
GM		 61(defgroup gnus-article-treat nil
62 "Treating article parts."
63 :link '(custom-manual "(gnus)Article Hiding")
64 :group 'gnus-article)
65
eec82323
LMI		 66(defgroup gnus-article-hiding nil
67 "Hiding article parts."
68 :link '(custom-manual "(gnus)Article Hiding")
69 :group 'gnus-article)
70
71(defgroup gnus-article-highlight nil
72 "Article highlighting."
73 :link '(custom-manual "(gnus)Article Highlighting")
74 :group 'gnus-article
75 :group 'gnus-visual)
76
77(defgroup gnus-article-signature nil
78 "Article signatures."
79 :link '(custom-manual "(gnus)Article Signature")
80 :group 'gnus-article)
81
82(defgroup gnus-article-headers nil
83 "Article headers."
84 :link '(custom-manual "(gnus)Hiding Headers")
85 :group 'gnus-article)
86
87(defgroup gnus-article-washing nil
88 "Special commands on articles."
89 :link '(custom-manual "(gnus)Article Washing")
90 :group 'gnus-article)
91
92(defgroup gnus-article-emphasis nil
93 "Fontisizing articles."
94 :link '(custom-manual "(gnus)Article Fontisizing")
95 :group 'gnus-article)
96
97(defgroup gnus-article-saving nil
98 "Saving articles."
99 :link '(custom-manual "(gnus)Saving Articles")
100 :group 'gnus-article)
101
102(defgroup gnus-article-mime nil
103 "Worshiping the MIME wonder."
104 :link '(custom-manual "(gnus)Using MIME")
105 :group 'gnus-article)
106
107(defgroup gnus-article-buttons nil
108 "Pushable buttons in the article buffer."
109 :link '(custom-manual "(gnus)Article Buttons")
110 :group 'gnus-article)
111
112(defgroup gnus-article-various nil
113 "Other article options."
114 :link '(custom-manual "(gnus)Misc Article")
115 :group 'gnus-article)
116
117(defcustom gnus-ignored-headers
23f87bed
MB		 118 (mapcar
119 (lambda (header)
120 (concat "^" header ":"))
121 '("Path" "Expires" "Date-Received" "References" "Xref" "Lines"
122 "Relay-Version" "Message-ID" "Approved" "Sender" "Received"
123 "X-UIDL" "MIME-Version" "Return-Path" "In-Reply-To"
124 "Content-Type" "Content-Transfer-Encoding" "X-WebTV-Signature"
125 "X-MimeOLE" "X-MSMail-Priority" "X-Priority" "X-Loop"
126 "X-Authentication-Warning" "X-MIME-Autoconverted" "X-Face"
127 "X-Attribution" "X-Originating-IP" "Delivered-To"
128 "NNTP-[-A-Za-z]+" "Distribution" "X-no-archive" "X-Trace"
129 "X-Complaints-To" "X-NNTP-Posting-Host" "X-Orig.*"
130 "Abuse-Reports-To" "Cache-Post-Path" "X-Article-Creation-Date"
131 "X-Poster" "X-Mail2News-Path" "X-Server-Date" "X-Cache"
132 "Originator" "X-Problems-To" "X-Auth-User" "X-Post-Time"
133 "X-Admin" "X-UID" "Resent-[-A-Za-z]+" "X-Mailing-List"
134 "Precedence" "Original-[-A-Za-z]+" "X-filename" "X-Orcpt"
135 "Old-Received" "X-Pgp" "X-Auth" "X-From-Line"
136 "X-Gnus-Article-Number" "X-Majordomo" "X-Url" "X-Sender"
137 "MBOX-Line" "Priority" "X400-[-A-Za-z]+"
138 "Status" "X-Gnus-Mail-Source" "Cancel-Lock"
139 "X-FTN" "X-EXP32-SerialNo" "Encoding" "Importance"
140 "Autoforwarded" "Original-Encoded-Information-Types" "X-Ya-Pop3"
141 "X-Face-Version" "X-Vms-To" "X-ML-NAME" "X-ML-COUNT"
142 "Mailing-List" "X-finfo" "X-md5sum" "X-md5sum-Origin"
143 "X-Sun-Charset" "X-Accept-Language" "X-Envelope-Sender"
144 "List-[A-Za-z]+" "X-Listprocessor-Version"
145 "X-Received" "X-Distribute" "X-Sequence" "X-Juno-Line-Breaks"
146 "X-Notes-Item" "X-MS-TNEF-Correlator" "x-uunet-gateway"
147 "X-Received" "Content-length" "X-precedence"
148 "X-Authenticated-User" "X-Comment" "X-Report" "X-Abuse-Info"
149 "X-HTTP-Proxy" "X-Mydeja-Info" "X-Copyright" "X-No-Markup"
150 "X-Abuse-Info" "X-From_" "X-Accept-Language" "Errors-To"
151 "X-BeenThere" "X-Mailman-Version" "List-Help" "List-Post"
152 "List-Subscribe" "List-Id" "List-Unsubscribe" "List-Archive"
153 "X-Content-length" "X-Posting-Agent" "Original-Received"
154 "X-Request-PGP" "X-Fingerprint" "X-WRIEnvto" "X-WRIEnvfrom"
155 "X-Virus-Scanned" "X-Delivery-Agent" "Posted-Date" "X-Gateway"
156 "X-Local-Origin" "X-Local-Destination" "X-UserInfo1"
157 "X-Received-Date" "X-Hashcash" "Face" "X-DMCA-Notifications"
01c52d31
MB		 158 "X-Abuse-and-DMCA-Info" "X-Postfilter" "X-Gpg-.*" "X-Disclaimer"
159 "Envelope-To" "X-Spam-Score" "System-Type" "X-Injected-Via-Gmane"
160 "X-Gmane-NNTP-Posting-Host" "Jabber-ID" "Archived-At"
161 "Envelope-Sender" "Envelope-Recipients"))
6748645f 162 "*All headers that start with this regexp will be hidden.
eec82323
LMI		 163This variable can also be a list of regexps of headers to be ignored.
164If `gnus-visible-headers' is non-nil, this variable will be ignored."
165 :type '(choice :custom-show nil
166 regexp
167 (repeat regexp))
168 :group 'gnus-article-hiding)
169
170(defcustom gnus-visible-headers
12e3ca0a 171 "^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:"
6748645f 172 "*All headers that do not match this regexp will be hidden.
eec82323
LMI		 173This variable can also be a list of regexp of headers to remain visible.
174If this variable is non-nil, `gnus-ignored-headers' will be ignored."
9b3ebcb6
MB		 175 :type '(choice
176 (repeat :value-to-internal (lambda (widget value)
177 (custom-split-regexp-maybe value))
178 :match (lambda (widget value)
179 (or (stringp value)
180 (widget-editable-list-match widget value)))
181 regexp)
182 (const :tag "Use gnus-ignored-headers" nil)
183 regexp)
eec82323
LMI		 184 :group 'gnus-article-hiding)
185
186(defcustom gnus-sorted-header-list
187 '("^From:" "^Subject:" "^Summary:" "^Keywords:" "^Newsgroups:"
188 "^Followup-To:" "^To:" "^Cc:" "^Date:" "^Organization:")
6748645f 189 "*This variable is a list of regular expressions.
eec82323
LMI		 190If it is non-nil, headers that match the regular expressions will
191be placed first in the article buffer in the sequence specified by
192this list."
193 :type '(repeat regexp)
194 :group 'gnus-article-hiding)
195
196(defcustom gnus-boring-article-headers '(empty followup-to reply-to)
197 "Headers that are only to be displayed if they have interesting data.
23f87bed
MB		 198Possible values in this list are:
199
200 'empty Headers with no content.
201 'newsgroups Newsgroup identical to Gnus group.
202 'to-address To identical to To-address.
203 'to-list To identical to To-list.
204 'cc-list CC identical to To-list.
205 'followup-to Followup-to identical to Newsgroups.
206 'reply-to Reply-to identical to From.
207 'date Date less than four days old.
208 'long-to To and/or Cc longer than 1024 characters.
209 'many-to Multiple To and/or Cc."
eec82323 210 :type '(set (const :tag "Headers with no content." empty)
23f87bed
MB		 211 (const :tag "Newsgroups identical to Gnus group." newsgroups)
212 (const :tag "To identical to To-address." to-address)
213 (const :tag "To identical to To-list." to-list)
214 (const :tag "CC identical to To-list." cc-list)
215 (const :tag "Followup-to identical to Newsgroups." followup-to)
216 (const :tag "Reply-to identical to From." reply-to)
6748645f 217 (const :tag "Date less than four days old." date)
23f87bed 218 (const :tag "To and/or Cc longer than 1024 characters." long-to)
16409b0b 219 (const :tag "Multiple To and/or Cc headers." many-to))
eec82323
LMI		 220 :group 'gnus-article-hiding)
221
23f87bed
MB		 222(defcustom gnus-article-skip-boring nil
223 "Skip over text that is not worth reading.
224By default, if you set this t, then Gnus will display citations and
225signatures, but will never scroll down to show you a page consisting
226only of boring text. Boring text is controlled by
227`gnus-article-boring-faces'."
bf247b6e 228 :version "22.1"
23f87bed
MB		 229 :type 'boolean
230 :group 'gnus-article-hiding)
231
eec82323
LMI		 232(defcustom gnus-signature-separator '("^-- $" "^-- *$")
233 "Regexp matching signature separator.
234This can also be a list of regexps. In that case, it will be checked
235from head to tail looking for a separator. Searches will be done from
236the end of the buffer."
3031d8b0
MB		 237 :type '(choice :format "%{%t%}: %[Value Menu%]\n%v"
238 (regexp)
239 (repeat :tag "List of regexp" regexp))
eec82323
LMI		 240 :group 'gnus-article-signature)
241
242(defcustom gnus-signature-limit nil
16409b0b 243 "Provide a limit to what is considered a signature.
eec82323
LMI		 244If it is a number, no signature may not be longer (in characters) than
245that number. If it is a floating point number, no signature may be
246longer (in lines) than that number. If it is a function, the function
247will be called without any parameters, and if it returns nil, there is
248no signature in the buffer. If it is a string, it will be used as a
01c52d31
MB		 249regexp. If it matches, the text in question is not a signature.
250
251This can also be a list of the above values."
4a2358e9
MB		 252 :type '(choice (const nil)
253 (integer :value 200)
6748645f 254 (number :value 4.0)
b28080e3 255 function
6748645f 256 (regexp :value ".*"))
eec82323
LMI		 257 :group 'gnus-article-signature)
258
259(defcustom gnus-hidden-properties '(invisible t intangible t)
260 "Property list to use for hiding text."
261 :type 'sexp
262 :group 'gnus-article-hiding)
263
23f87bed
MB		 264;; Fixme: This isn't the right thing for mixed graphical and non-graphical
265;; frames in a session.
eec82323 266(defcustom gnus-article-x-face-command
23f87bed
MB		 267 (if (featurep 'xemacs)
268 (if (or (gnus-image-type-available-p 'xface)
269 (gnus-image-type-available-p 'pbm))
270 'gnus-display-x-face-in-from
271 "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | ee -")
272 (if (gnus-image-type-available-p 'pbm)
273 'gnus-display-x-face-in-from
e0bad764
DL		 274 "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | \
275display -"))
6748645f 276 "*String or function to be executed to display an X-Face header.
eec82323 277If it is a string, the command will be executed in a sub-shell
2ff9f5b4 278asynchronously. The compressed face will be piped to this command."
23f87bed
MB		 279 :type `(choice string
280 (function-item gnus-display-x-face-in-from)
16409b0b 281 function)
b5a206e7 282 :version "21.1"
23f87bed 283 :group 'gnus-picon
eec82323
LMI		 284 :group 'gnus-article-washing)
285
286(defcustom gnus-article-x-face-too-ugly nil
287 "Regexp matching posters whose face shouldn't be shown automatically."
4bb6a3a6 288 :type '(choice regexp (const nil))
eec82323
LMI		 289 :group 'gnus-article-washing)
290
e0bad764
DL		 291(defcustom gnus-article-banner-alist nil
292 "Banner alist for stripping.
a1506d29 293For example,
23f87bed 294 ((egroups . \"^[ \\t\\n]*-------------------+\\\\( \\\\(e\\\\|Yahoo! \\\\)Groups Sponsor -+\\\\)?....\\n\\\\(.+\\n\\\\)+\"))"
fc2c2db8 295 :version "21.1"
e0bad764
DL		 296 :type '(repeat (cons symbol regexp))
297 :group 'gnus-article-washing)
298
23f87bed
MB		 299(gnus-define-group-parameter
300 banner
301 :variable-document
302 "Alist of regexps (to match group names) and banner."
303 :variable-group gnus-article-washing
304 :parameter-type
305 '(choice :tag "Banner"
306 :value nil
307 (const :tag "Remove signature" signature)
308 (symbol :tag "Item in `gnus-article-banner-alist'" none)
309 regexp
310 (const :tag "None" nil))
311 :parameter-document
312 "If non-nil, specify how to remove `banners' from articles.
313
314Symbol `signature' means to remove signatures delimited by
315`gnus-signature-separator'. Any other symbol is used to look up a
316regular expression to match the banner in `gnus-article-banner-alist'.
317A string is used as a regular expression to match the banner
318directly.")
319
320(defcustom gnus-article-address-banner-alist nil
321 "Alist of mail addresses and banners.
322Each element has the form (ADDRESS . BANNER), where ADDRESS is a regexp
323to match a mail address in the From: header, BANNER is one of a symbol
324`signature', an item in `gnus-article-banner-alist', a regexp and nil.
325If ADDRESS matches author's mail address, it will remove things like
326advertisements. For example:
327
328\((\"@yoo-hoo\\\\.co\\\\.jp\\\\'\" . \"\\n_+\\nDo You Yoo-hoo!\\\\?\\n.*\\n.*\\n\"))
329"
330 :type '(repeat
331 (cons
332 (regexp :tag "Address")
333 (choice :tag "Banner" :value nil
334 (const :tag "Remove signature" signature)
335 (symbol :tag "Item in `gnus-article-banner-alist'" none)
336 regexp
337 (const :tag "None" nil))))
bf247b6e 338 :version "22.1"
23f87bed
MB		 339 :group 'gnus-article-washing)
340
ae465fa7
MB		 341(defmacro gnus-emphasis-custom-with-format (&rest body)
342 `(let ((format "\
343\\(\\s-\\|^\\|\\=\\|[-\"]\\|\\s(\\)\\(%s\\(\\w+\\(\\s-+\\w+\\)*[.,]?\\)%s\\)\
344\\(\\([-,.;:!?\"]\\|\\s)\\)+\\s-\\|[?!.]\\s-\\|\\s)\\|\\s-\\)"))
345 ,@body))
346
347(defun gnus-emphasis-custom-value-to-external (value)
348 (gnus-emphasis-custom-with-format
349 (if (consp (car value))
350 (list (format format (car (car value)) (cdr (car value)))
351 2
352 (if (nth 1 value) 2 3)
353 (nth 2 value))
354 value)))
355
356(defun gnus-emphasis-custom-value-to-internal (value)
357 (gnus-emphasis-custom-with-format
358 (let ((regexp (concat "\\`"
359 (format (regexp-quote format)
360 "\\([^()]+\\)" "\\([^()]+\\)")
361 "\\'"))
362 pattern)
363 (if (string-match regexp (setq pattern (car value)))
364 (list (cons (match-string 1 pattern) (match-string 2 pattern))
365 (= (nth 2 value) 2)
366 (nth 3 value))
367 value))))
368
eec82323 369(defcustom gnus-emphasis-alist
ae465fa7
MB		 370 (let ((types
371 '(("\\*" "\\*" bold nil 2)
23f87bed 372 ("_" "_" underline)
eec82323 373 ("/" "/" italic)
eec82323
LMI		 374 ("_/" "/_" underline-italic)
375 ("_\\*" "\\*_" underline-bold)
376 ("\\*/" "/\\*" bold-italic)
377 ("_\\*/" "/\\*_" underline-bold-italic))))
ae465fa7
MB		 378 (nconc
379 (gnus-emphasis-custom-with-format
380 (mapcar (lambda (spec)
381 (list (format format (car spec) (cadr spec))
382 (or (nth 3 spec) 2)
383 (or (nth 4 spec) 3)
384 (intern (format "gnus-emphasis-%s" (nth 2 spec)))))
385 types))
95f75c75
SM		 386 '(;; I've never seen anyone use this strikethru convention whereas I've
387 ;; several times seen it triggered by normal text. --Stef
388 ;; Miles suggests that this form is sometimes used but for italics,
389 ;; so maybe we should map it to `italic'.
390 ;; ("\\(\\s-\\|^\\)\\(-\\(\\(\\w\\|-[^-]\\)+\\)-\\)\\(\\s-\\|[?!.,;]\\)"
391 ;; 2 3 gnus-emphasis-strikethru)
ae465fa7
MB		 392 ("\\(\\s-\\|^\\)\\(_\\(\\(\\w\\|_[^_]\\)+\\)_\\)\\(\\s-\\|[?!.,;]\\)"
393 2 3 gnus-emphasis-underline))))
6748645f 394 "*Alist that says how to fontify certain phrases.
eec82323
LMI		 395Each item looks like this:
396
397 (\"_\\\\(\\\\w+\\\\)_\" 0 1 'underline)
398
399The first element is a regular expression to be matched. The second
400is a number that says what regular expression grouping used to find
401the entire emphasized word. The third is a number that says what
402regexp grouping should be displayed and highlighted. The fourth
403is the face used for highlighting."
ae465fa7
MB		 404 :type
405 '(repeat
406 (menu-choice
407 :format "%[Customizing Style%]\n%v"
408 :indent 2
409 (group :tag "Default"
410 :value ("" 0 0 default)
411 :value-create
412 (lambda (widget)
413 (let ((value (widget-get
414 (cadr (widget-get (widget-get widget :parent)
415 :args))
416 :value)))
417 (if (not (eq (nth 2 value) 'default))
418 (widget-put
419 widget
420 :value
421 (gnus-emphasis-custom-value-to-external value))))
422 (widget-group-value-create widget))
ad136a7c
MB		 423 regexp
424 (integer :format "Match group: %v")
01c52d31 425 (integer :format "Emphasize group: %v")
ae465fa7
MB		 426 face)
427 (group :tag "Simple"
428 :value (("_" . "_") nil default)
429 (cons :format "%v"
ad136a7c
MB		 430 (regexp :format "Start regexp: %v")
431 (regexp :format "End regexp: %v"))
ae465fa7
MB		 432 (boolean :format "Show start and end patterns: %[%v%]\n"
433 :on " On " :off " Off ")
434 face)))
435 :get (lambda (symbol)
436 (mapcar 'gnus-emphasis-custom-value-to-internal
437 (default-value symbol)))
438 :set (lambda (symbol value)
439 (set-default symbol (mapcar 'gnus-emphasis-custom-value-to-external
440 value)))
eec82323
LMI		 441 :group 'gnus-article-emphasis)
442
16409b0b
GM		 443(defcustom gnus-emphasize-whitespace-regexp "^[ \t]+\\|[ \t]*\n"
444 "A regexp to describe whitespace which should not be emphasized.
445Typical values are \"^[ \\t]+\\\\|[ \\t]*\\n\" and \"[ \\t]+\\\\|[ \\t]*\\n\".
446The former avoids underlining of leading and trailing whitespace,
447and the latter avoids underlining any whitespace at all."
fc2c2db8 448 :version "21.1"
16409b0b
GM		 449 :group 'gnus-article-emphasis
450 :type 'regexp)
451
23f87bed 452(defface gnus-emphasis-bold '((t (:bold t)))
eec82323
LMI		 453 "Face used for displaying strong emphasized text (*word*)."
454 :group 'gnus-article-emphasis)
455
23f87bed 456(defface gnus-emphasis-italic '((t (:italic t)))
eec82323
LMI		 457 "Face used for displaying italic emphasized text (/word/)."
458 :group 'gnus-article-emphasis)
459
460(defface gnus-emphasis-underline '((t (:underline t)))
461 "Face used for displaying underlined emphasized text (_word_)."
462 :group 'gnus-article-emphasis)
463
23f87bed 464(defface gnus-emphasis-underline-bold '((t (:bold t :underline t)))
eec82323
LMI		 465 "Face used for displaying underlined bold emphasized text (_*word*_)."
466 :group 'gnus-article-emphasis)
467
23f87bed 468(defface gnus-emphasis-underline-italic '((t (:italic t :underline t)))
8de38c21 469 "Face used for displaying underlined italic emphasized text (_/word/_)."
eec82323
LMI		 470 :group 'gnus-article-emphasis)
471
23f87bed 472(defface gnus-emphasis-bold-italic '((t (:bold t :italic t)))
eec82323
LMI		 473 "Face used for displaying bold italic emphasized text (/*word*/)."
474 :group 'gnus-article-emphasis)
475
476(defface gnus-emphasis-underline-bold-italic
23f87bed 477 '((t (:bold t :italic t :underline t)))
eec82323 478 "Face used for displaying underlined bold italic emphasized text.
8f688cb0 479Example: (_/*word*/_)."
eec82323
LMI		 480 :group 'gnus-article-emphasis)
481
23f87bed
MB		 482(defface gnus-emphasis-strikethru (if (featurep 'xemacs)
483 '((t (:strikethru t)))
484 '((t (:strike-through t))))
485 "Face used for displaying strike-through text (-word-)."
486 :group 'gnus-article-emphasis)
487
16409b0b
GM		 488(defface gnus-emphasis-highlight-words
489 '((t (:background "black" :foreground "yellow")))
490 "Face used for displaying highlighted words."
491 :group 'gnus-article-emphasis)
492
01c52d31 493(defcustom gnus-article-time-format "%a, %d %b %Y %T %Z"
eec82323 494 "Format for display of Date headers in article bodies.
6748645f
LMI		 495See `format-time-string' for the possible values.
496
497The variable can also be function, which should return a complete Date
498header. The function is called with one argument, the time, which can
499be fed to `format-time-string'."
01c52d31 500 :type '(choice string function)
eec82323
LMI		 501 :link '(custom-manual "(gnus)Article Date")
502 :group 'gnus-article-washing)
503
eec82323 504(defcustom gnus-save-all-headers t
26c9afc3
MB		 505 "*If non-nil, don't remove any headers before saving.
506This will be overridden by the `:headers' property that the symbol of
507the saver function, which is specified by `gnus-default-article-saver',
508might have."
eec82323
LMI		 509 :group 'gnus-article-saving
510 :type 'boolean)
511
512(defcustom gnus-prompt-before-saving 'always
513 "*This variable says how much prompting is to be done when saving articles.
514If it is nil, no prompting will be done, and the articles will be
515saved to the default files. If this variable is `always', each and
516every article that is saved will be preceded by a prompt, even when
517saving large batches of articles. If this variable is neither nil not
518`always', there the user will be prompted once for a file name for
519each invocation of the saving commands."
520 :group 'gnus-article-saving
521 :type '(choice (item always)
522 (item :tag "never" nil)
6748645f 523 (sexp :tag "once" :format "%t\n" :value t)))
eec82323
LMI		 524
525(defcustom gnus-saved-headers gnus-visible-headers
526 "Headers to keep if `gnus-save-all-headers' is nil.
527If `gnus-save-all-headers' is non-nil, this variable will be ignored.
528If that variable is nil, however, all headers that match this regexp
26c9afc3
MB		 529will be kept while the rest will be deleted before saving. This and
530`gnus-save-all-headers' will be overridden by the `:headers' property
531that the symbol of the saver function, which is specified by
532`gnus-default-article-saver', might have."
eec82323 533 :group 'gnus-article-saving
4bb6a3a6 534 :type 'regexp)
eec82323 535
fef8d38e 536;; Note that "Rmail format" is mbox since Emacs 23, but Babyl before.
eec82323
LMI		 537(defcustom gnus-default-article-saver 'gnus-summary-save-in-rmail
538 "A function to save articles in your favourite format.
26c9afc3
MB		 539The function will be called by way of the `gnus-summary-save-article'
540command, and friends such as `gnus-summary-save-article-rmail'.
eec82323
LMI		 541
542Gnus provides the following functions:
543
544* gnus-summary-save-in-rmail (Rmail format)
545* gnus-summary-save-in-mail (Unix mail format)
546* gnus-summary-save-in-folder (MH folder)
547* gnus-summary-save-in-file (article format)
23f87bed 548* gnus-summary-save-body-in-file (article body)
eec82323 549* gnus-summary-save-in-vm (use VM's folder format)
26c9afc3
MB		 550* gnus-summary-write-to-file (article format -- overwrite)
551* gnus-summary-write-body-to-file (article body -- overwrite)
89167438 552* gnus-summary-save-in-pipe (article format)
26c9afc3
MB		 553
554The symbol of each function may have the following properties:
555
556* :decode
557The value non-nil means save decoded articles. This is meaningful
558only with `gnus-summary-save-in-file', `gnus-summary-save-body-in-file',
89167438
MB		 559`gnus-summary-write-to-file', `gnus-summary-write-body-to-file', and
560`gnus-summary-save-in-pipe'.
26c9afc3
MB		 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)
89167438 583 (function-item gnus-summary-save-in-pipe)
58090a8d 584 (function)))
eec82323 585
26c9afc3
MB		 586(defcustom gnus-article-save-coding-system
587 (or (and (mm-coding-system-p 'utf-8) 'utf-8)
588 (and (mm-coding-system-p 'iso-2022-7bit) 'iso-2022-7bit)
589 (and (mm-coding-system-p 'emacs-mule) 'emacs-mule)
590 (and (mm-coding-system-p 'escape-quoted) 'escape-quoted))
591 "Coding system used to save decoded articles to a file.
592
593The recommended coding systems are `utf-8', `iso-2022-7bit' and so on,
594which can safely encode any characters in text. This is used by the
595commands including:
596
597* gnus-summary-save-article-file
598* gnus-summary-save-article-body-file
599* gnus-summary-write-article-file
600* gnus-summary-write-article-body-file
601
602and the functions to which you may set `gnus-default-article-saver':
603
604* gnus-summary-save-in-file
605* gnus-summary-save-body-in-file
606* gnus-summary-write-to-file
607* gnus-summary-write-body-to-file
608
609Those commands and functions save just text displayed in the article
610buffer to a file if the value of this variable is non-nil. Note that
611buttonized MIME parts will be lost in a saved file in that case.
612Otherwise, raw articles will be saved."
613 :group 'gnus-article-saving
614 :type `(choice
615 :format "%{%t%}:\n %[Value Menu%] %v"
616 (const :tag "Save raw articles" nil)
617 ,@(delq nil
618 (mapcar
619 (lambda (arg) (if (mm-coding-system-p (nth 3 arg)) arg))
620 '((const :tag "UTF-8" utf-8)
621 (const :tag "iso-2022-7bit" iso-2022-7bit)
622 (const :tag "Emacs internal" emacs-mule)
623 (const :tag "escape-quoted" escape-quoted))))
624 (symbol :tag "Coding system")))
625
eec82323
LMI		 626(defcustom gnus-rmail-save-name 'gnus-plain-save-name
627 "A function generating a file name to save articles in Rmail format.
628The function is called with NEWSGROUP, HEADERS, and optional LAST-FILE."
629 :group 'gnus-article-saving
630 :type 'function)
631
632(defcustom gnus-mail-save-name 'gnus-plain-save-name
633 "A function generating a file name to save articles in Unix mail format.
634The function is called with NEWSGROUP, HEADERS, and optional LAST-FILE."
635 :group 'gnus-article-saving
636 :type 'function)
637
638(defcustom gnus-folder-save-name 'gnus-folder-save-name
639 "A function generating a file name to save articles in MH folder.
640The function is called with NEWSGROUP, HEADERS, and optional LAST-FOLDER."
641 :group 'gnus-article-saving
642 :type 'function)
643
644(defcustom gnus-file-save-name 'gnus-numeric-save-name
645 "A function generating a file name to save articles in article format.
646The function is called with NEWSGROUP, HEADERS, and optional
647LAST-FILE."
648 :group 'gnus-article-saving
649 :type 'function)
650
651(defcustom gnus-split-methods
652 '((gnus-article-archive-name)
653 (gnus-article-nndoc-name))
6748645f 654 "*Variable used to suggest where articles are to be saved.
eec82323
LMI		 655For instance, if you would like to save articles related to Gnus in
656the file \"gnus-stuff\", and articles related to VM in \"vm-stuff\",
657you could set this variable to something like:
658
659 '((\"^Subject:.*gnus\\|^Newsgroups:.*gnus\" \"gnus-stuff\")
660 (\"^Subject:.*vm\\|^Xref:.*vm\" \"vm-stuff\"))
661
01c52d31
MB		 662This variable is an alist where the key is the match and the
663value is a list of possible files to save in if the match is
664non-nil.
eec82323
LMI		 665
666If the match is a string, it is used as a regexp match on the
667article. If the match is a symbol, that symbol will be funcalled
668from the buffer of the article to be saved with the newsgroup as the
01c52d31 669parameter. If it is a list, it will be evaled in the same buffer.
eec82323 670
01c52d31
MB		 671If this form or function returns a string, this string will be used as a
672possible file name; and if it returns a non-nil list, that list will be
673used as possible file names."
eec82323 674 :group 'gnus-article-saving
6748645f
LMI		 675 :type '(repeat (choice (list :value (fun) function)
676 (cons :value ("" "") regexp (repeat string))
677 (sexp :value nil))))
eec82323 678
eec82323
LMI		 679(defcustom gnus-page-delimiter "^\^L"
680 "*Regexp describing what to use as article page delimiters.
681The default value is \"^\^L\", which is a form linefeed at the
682beginning of a line."
683 :type 'regexp
684 :group 'gnus-article-various)
685
16409b0b 686(defcustom gnus-article-mode-line-format "Gnus: %g [%w] %S%m"
eec82323 687 "*The format specification for the article mode line.
16409b0b
GM		 688See `gnus-summary-mode-line-format' for a closer description.
689
690The following additional specs are available:
691
692%w The article washing status.
693%m The number of MIME parts in the article."
eec82323
LMI		 694 :type 'string
695 :group 'gnus-article-various)
696
697(defcustom gnus-article-mode-hook nil
698 "*A hook for Gnus article mode."
699 :type 'hook
700 :group 'gnus-article-various)
701
23f87bed
MB		 702(when (featurep 'xemacs)
703 ;; Extracted from gnus-xmas-define in order to preserve user settings
704 (when (fboundp 'turn-off-scroll-in-place)
705 (add-hook 'gnus-article-mode-hook 'turn-off-scroll-in-place))
706 ;; Extracted from gnus-xmas-redefine in order to preserve user settings
707 (add-hook 'gnus-article-mode-hook 'gnus-xmas-article-menu-add))
708
eec82323
LMI		 709(defcustom gnus-article-menu-hook nil
710 "*Hook run after the creation of the article mode menu."
711 :type 'hook
712 :group 'gnus-article-various)
713
714(defcustom gnus-article-prepare-hook nil
16409b0b 715 "*A hook called after an article has been prepared in the article buffer."
eec82323
LMI		 716 :type 'hook
717 :group 'gnus-article-various)
718
01c52d31
MB		 719(defcustom gnus-copy-article-ignored-headers nil
720 "List of headers to be removed when copying an article.
721Each element is a regular expression."
330f707b 722 :version "23.1" ;; No Gnus
01c52d31
MB		 723 :type '(repeat regexp)
724 :group 'gnus-article-various)
725
265ac10b 726(make-obsolete-variable 'gnus-article-hide-pgp-hook nil
6b958814 727 "Gnus 5.10 (Emacs 22.1)")
a8151ef7 728
01c52d31
MB		 729(defface gnus-button
730 '((t (:weight bold)))
731 "Face used for highlighting a button in the article buffer."
732 :group 'gnus-article-buttons)
733
734(defcustom gnus-article-button-face 'gnus-button
eec82323
LMI		 735 "Face used for highlighting buttons in the article buffer.
736
737An article button is a piece of text that you can activate by pressing
738`RET' or `mouse-2' above it."
739 :type 'face
740 :group 'gnus-article-buttons)
741
742(defcustom gnus-article-mouse-face 'highlight
743 "Face used for mouse highlighting in the article buffer.
744
745Article buttons will be displayed in this face when the cursor is
746above them."
747 :type 'face
748 :group 'gnus-article-buttons)
749
0f49874b 750(defcustom gnus-signature-face 'gnus-signature
a8151ef7 751 "Face used for highlighting a signature in the article buffer.
0f49874b 752Obsolete; use the face `gnus-signature' for customizations instead."
eec82323
LMI		 753 :type 'face
754 :group 'gnus-article-highlight
755 :group 'gnus-article-signature)
756
0f49874b 757(defface gnus-signature
f59a3415 758 '((t
23f87bed 759 (:italic t)))
a8151ef7
LMI		 760 "Face used for highlighting a signature in the article buffer."
761 :group 'gnus-article-highlight
762 :group 'gnus-article-signature)
0f49874b
MB		 763;; backward-compatibility alias
764(put 'gnus-signature-face 'face-alias 'gnus-signature)
3d493bef 765(put 'gnus-signature-face 'obsolete-face "22.1")
a8151ef7 766
0f49874b 767(defface gnus-header-from
eec82323
LMI		 768 '((((class color)
769 (background dark))
01c52d31 770 (:foreground "PaleGreen1"))
eec82323
LMI		 771 (((class color)
772 (background light))
6748645f 773 (:foreground "red3"))
eec82323 774 (t
23f87bed 775 (:italic t)))
eec82323
LMI		 776 "Face used for displaying from headers."
777 :group 'gnus-article-headers
778 :group 'gnus-article-highlight)
0f49874b
MB		 779;; backward-compatibility alias
780(put 'gnus-header-from-face 'face-alias 'gnus-header-from)
3d493bef 781(put 'gnus-header-from-face 'obsolete-face "22.1")
eec82323 782
0f49874b 783(defface gnus-header-subject
eec82323
LMI		 784 '((((class color)
785 (background dark))
01c52d31 786 (:foreground "SeaGreen1"))
eec82323
LMI		 787 (((class color)
788 (background light))
6748645f 789 (:foreground "red4"))
eec82323 790 (t
23f87bed 791 (:bold t :italic t)))
eec82323
LMI		 792 "Face used for displaying subject headers."
793 :group 'gnus-article-headers
794 :group 'gnus-article-highlight)
0f49874b
MB		 795;; backward-compatibility alias
796(put 'gnus-header-subject-face 'face-alias 'gnus-header-subject)
3d493bef 797(put 'gnus-header-subject-face 'obsolete-face "22.1")
eec82323 798
0f49874b 799(defface gnus-header-newsgroups
eec82323
LMI		 800 '((((class color)
801 (background dark))
23f87bed 802 (:foreground "yellow" :italic t))
eec82323
LMI		 803 (((class color)
804 (background light))
23f87bed 805 (:foreground "MidnightBlue" :italic t))
eec82323 806 (t
23f87bed
MB		 807 (:italic t)))
808 "Face used for displaying newsgroups headers.
809In the default setup this face is only used for crossposted
810articles."
eec82323
LMI		 811 :group 'gnus-article-headers
812 :group 'gnus-article-highlight)
0f49874b
MB		 813;; backward-compatibility alias
814(put 'gnus-header-newsgroups-face 'face-alias 'gnus-header-newsgroups)
3d493bef 815(put 'gnus-header-newsgroups-face 'obsolete-face "22.1")
eec82323 816
0f49874b 817(defface gnus-header-name
eec82323
LMI		 818 '((((class color)
819 (background dark))
01c52d31 820 (:foreground "SpringGreen2"))
eec82323
LMI		 821 (((class color)
822 (background light))
823 (:foreground "maroon"))
824 (t
23f87bed 825 (:bold t)))
eec82323
LMI		 826 "Face used for displaying header names."
827 :group 'gnus-article-headers
828 :group 'gnus-article-highlight)
0f49874b
MB		 829;; backward-compatibility alias
830(put 'gnus-header-name-face 'face-alias 'gnus-header-name)
3d493bef 831(put 'gnus-header-name-face 'obsolete-face "22.1")
eec82323 832
0f49874b 833(defface gnus-header-content
eec82323
LMI		 834 '((((class color)
835 (background dark))
01c52d31 836 (:foreground "SpringGreen1" :italic t))
eec82323
LMI		 837 (((class color)
838 (background light))
23f87bed 839 (:foreground "indianred4" :italic t))
eec82323 840 (t
23f87bed 841 (:italic t))) "Face used for displaying header content."
eec82323
LMI		 842 :group 'gnus-article-headers
843 :group 'gnus-article-highlight)
0f49874b
MB		 844;; backward-compatibility alias
845(put 'gnus-header-content-face 'face-alias 'gnus-header-content)
3d493bef 846(put 'gnus-header-content-face 'obsolete-face "22.1")
eec82323
LMI		 847
848(defcustom gnus-header-face-alist
0f49874b
MB		 849 '(("From" nil gnus-header-from)
850 ("Subject" nil gnus-header-subject)
851 ("Newsgroups:.*," nil gnus-header-newsgroups)
852 ("" gnus-header-name gnus-header-content))
23f87bed 853 "*Controls highlighting of article headers.
eec82323
LMI		 854
855An alist of the form (HEADER NAME CONTENT).
856
23f87bed
MB		 857HEADER is a regular expression which should match the name of a
858header and NAME and CONTENT are either face names or nil.
eec82323
LMI		 859
860The name of each header field will be displayed using the face
23f87bed
MB		 861specified by the first element in the list where HEADER matches
862the header name and NAME is non-nil. Similarly, the content will
863be displayed by the first non-nil matching CONTENT face."
eec82323
LMI		 864 :group 'gnus-article-headers
865 :group 'gnus-article-highlight
866 :type '(repeat (list (regexp :tag "Header")
867 (choice :tag "Name"
868 (item :tag "skip" nil)
869 (face :value default))
870 (choice :tag "Content"
871 (item :tag "skip" nil)
872 (face :value default)))))
873
01c52d31
MB		 874(defcustom gnus-face-properties-alist (if (featurep 'xemacs)
875 '((xface . (:face gnus-x-face)))
876 '((pbm . (:face gnus-x-face))
877 (png . nil)))
878 "Alist of image types and properties applied to Face and X-Face images.
879Here are examples:
880
881;; Specify the altitude of Face images in the From header.
882\(setq gnus-face-properties-alist
883 '((pbm . (:face gnus-x-face :ascent 80))
884 (png . (:ascent 80))))
885
886;; Show Face images as pressed buttons.
887\(setq gnus-face-properties-alist
888 '((pbm . (:face gnus-x-face :relief -2))
889 (png . (:relief -2))))
890
891See the manual for the valid properties for various image types.
892Currently, `pbm' is used for X-Face images and `png' is used for Face
893images in Emacs. Only the `:face' property is effective on the `xface'
894image type in XEmacs if it is built with the libcompface library."
330f707b 895 :version "23.1" ;; No Gnus
01c52d31
MB		 896 :group 'gnus-article-headers
897 :type '(repeat (cons :format "%v" (symbol :tag "Image type") plist)))
898
16409b0b 899(defcustom gnus-article-decode-hook
23f87bed
MB		 900 '(article-decode-charset article-decode-encoded-words
901 article-decode-group-name article-decode-idna-rhs)
16409b0b
GM		 902 "*Hook run to decode charsets in articles."
903 :group 'gnus-article-headers
904 :type 'hook)
905
906(defcustom gnus-display-mime-function 'gnus-display-mime
907 "Function to display MIME articles."
908 :group 'gnus-article-mime
909 :type 'function)
910
911(defvar gnus-decode-header-function 'mail-decode-encoded-word-region
912 "Function used to decode headers.")
913
343d6628
MB		 914(defvar gnus-decode-address-function 'mail-decode-encoded-address-region
915 "Function used to decode addresses.")
916
16409b0b 917(defvar gnus-article-dumbquotes-map
7cad71ad
G		 918 '((?\200 "EUR")
919 (?\202 ",")
920 (?\203 "f")
921 (?\204 ",,")
922 (?\205 "...")
923 (?\213 "<")
924 (?\214 "OE")
925 (?\221 "`")
926 (?\222 "'")
927 (?\223 "``")
928 (?\224 "\"")
929 (?\225 "*")
930 (?\226 "-")
931 (?\227 "--")
932 (?\230 "~")
933 (?\231 "(TM)")
934 (?\233 ">")
935 (?\234 "oe")
936 (?\264 "'"))
16409b0b
GM		 937 "Table for MS-to-Latin1 translation.")
938
939(defcustom gnus-ignored-mime-types nil
940 "List of MIME types that should be ignored by Gnus."
fc2c2db8 941 :version "21.1"
16409b0b
GM		 942 :group 'gnus-article-mime
943 :type '(repeat regexp))
944
945(defcustom gnus-unbuttonized-mime-types '(".*/.*")
23f87bed
MB		 946 "List of MIME types that should not be given buttons when rendered inline.
947See also `gnus-buttonized-mime-types' which may override this variable.
948This variable is only used when `gnus-inhibit-mime-unbuttonizing' is nil."
949 :version "21.1"
950 :group 'gnus-article-mime
951 :type '(repeat regexp))
952
953(defcustom gnus-buttonized-mime-types nil
954 "List of MIME types that should be given buttons when rendered inline.
955If set, this variable overrides `gnus-unbuttonized-mime-types'.
956To see e.g. security buttons you could set this to
3031d8b0
MB		 957`(\"multipart/signed\")'. You could also add \"multipart/alternative\" to
958this list to display radio buttons that allow you to choose one of two
959media types those mails include. See also `mm-discouraged-alternatives'.
23f87bed 960This variable is only used when `gnus-inhibit-mime-unbuttonizing' is nil."
bf247b6e 961 :version "22.1"
16409b0b
GM		 962 :group 'gnus-article-mime
963 :type '(repeat regexp))
964
23f87bed
MB		 965(defcustom gnus-inhibit-mime-unbuttonizing nil
966 "If non-nil, all MIME parts get buttons.
967When nil (the default value), then some MIME parts do not get buttons,
968as described by the variables `gnus-buttonized-mime-types' and
969`gnus-unbuttonized-mime-types'."
bf247b6e 970 :version "22.1"
d0859c9a 971 :group 'gnus-article-mime
23f87bed
MB		 972 :type 'boolean)
973
974(defcustom gnus-body-boundary-delimiter "_"
975 "String used to delimit header and body.
976This variable is used by `gnus-article-treat-body-boundary' which can
977be controlled by `gnus-treat-body-boundary'."
bf247b6e 978 :version "22.1"
23f87bed
MB		 979 :group 'gnus-article-various
980 :type '(choice (item :tag "None" :value nil)
981 string))
982
97f78c9b
MB		 983(defcustom gnus-picon-databases '("/usr/lib/picon" "/usr/local/faces"
984 "/usr/share/picons")
23f87bed
MB		 985 "Defines the location of the faces database.
986For information on obtaining this database of pretty pictures, please
987see http://www.cs.indiana.edu/picons/ftp/index.html"
bf247b6e 988 :version "22.1"
23f87bed
MB		 989 :type '(repeat directory)
990 :link '(url-link :tag "download"
991 "http://www.cs.indiana.edu/picons/ftp/index.html")
992 :link '(custom-manual "(gnus)Picons")
993 :group 'gnus-picon)
994
995(defun gnus-picons-installed-p ()
996 "Say whether picons are installed on your machine."
997 (let ((installed nil))
998 (dolist (database gnus-picon-databases)
999 (when (file-exists-p database)
1000 (setq installed t)))
1001 installed))
1002
16409b0b
GM		 1003(defcustom gnus-article-mime-part-function nil
1004 "Function called with a MIME handle as the argument.
1005This is meant for people who want to do something automatic based
1006on parts -- for instance, adding Vcard info to a database."
1007 :group 'gnus-article-mime
4a2358e9
MB		 1008 :type '(choice (const nil)
1009 function))
16409b0b
GM		 1010
1011(defcustom gnus-mime-multipart-functions nil
fc2c2db8
DL		 1012 "An alist of MIME types to functions to display them."
1013 :version "21.1"
1014 :group 'gnus-article-mime
01c52d31 1015 :type '(repeat (cons :format "%v" (string :tag "MIME type") function)))
16409b0b 1016
12e3ca0a
LI		 1017(defcustom gnus-article-date-headers
1018 (let ((types '(ut local english lapsed combined-lapsed
1019 iso8601 original user-defined))
1020 default)
0c74b838
LI		 1021 ;; Try to respect the legacy `gnus-treat-date-*' variables, if
1022 ;; they're set.
12e3ca0a
LI		 1023 (dolist (type types)
1024 (let ((variable (intern (format "gnus-treat-date-%s" type))))
1025 (when (and (boundp variable)
1026 (symbol-value variable))
1027 (push type default))))
1028 (when (and (or (not (boundp (intern "gnus-article-date-lapsed-new-header")))
1029 (not (symbol-value (intern "gnus-article-date-lapsed-new-header"))))
1030 (memq 'lapsed default))
1031 (setq default (delq 'lapsed default)))
1032 (or default
0c74b838 1033 ;; If they weren't set, we default to `combined-lapsed'.
12e3ca0a
LI		 1034 '(combined-lapsed)))
1035 "A list of Date header formats to display.
1036Valid formats are `ut' (universal time), `local' (local time
1037zone), `english' (readable English), `lapsed' (elapsed time),
1038`combined-lapsed' (both the original date and the elapsed time),
1039`original' (the original date header), `iso8601' (ISO8601
1040format), and `user-defined' (a user-defined format defined by the
1041`gnus-article-time-format' variable).
1042
1043You have as many date headers as you want in the article buffer.
1044Some of these headers are updated automatically. See
1045`gnus-article-update-date-headers' for details."
1046 :version "24.1"
16409b0b 1047 :group 'gnus-article-headers
12e3ca0a
LI		 1048 :type '(repeat
1049 (item :tag "Universal time (UT)" :value 'ut)
1050 (item :tag "Local time zone" :value 'local)
1051 (item :tag "Readable English" :value 'english)
1052 (item :tag "Elapsed time" :value 'lapsed)
1053 (item :tag "Original and elapsed time" :value 'combined-lapsed)
1054 (item :tag "Original date header" :value 'original)
1055 (item :tag "ISO8601 format" :value 'iso8601)
1056 (item :tag "User-defined" :value 'user-defined)))
1057
1058(defcustom gnus-article-update-date-headers 1
1059 "How often to update the date header.
647559c2
LI		 1060If nil, don't update it at all."
1061 :version "24.1"
1062 :group 'gnus-article-headers
1063 :type '(choice
1064 (item :tag "Don't update" :value nil)
1065 integer))
1066
16409b0b
GM		 1067(defcustom gnus-article-mime-match-handle-function 'undisplayed-alternative
1068 "Function called with a MIME handle as the argument.
1069This is meant for people who want to view first matched part.
a1506d29
JB		 1070For `undisplayed-alternative' (default), the first undisplayed
1071part or alternative part is used. For `undisplayed', the first
1072undisplayed part is used. For a function, the first part which
f20b2f5c 1073the function return t is used. For nil, the first part is
16409b0b 1074used."
fc2c2db8 1075 :version "21.1"
16409b0b 1076 :group 'gnus-article-mime
a1506d29 1077 :type '(choice
16409b0b
GM		 1078 (item :tag "first" :value nil)
1079 (item :tag "undisplayed" :value undisplayed)
a1506d29 1080 (item :tag "undisplayed or alternative"
16409b0b
GM		 1081 :value undisplayed-alternative)
1082 (function)))
1083
e0bad764
DL		 1084(defcustom gnus-mime-action-alist
1085 '(("save to file" . gnus-mime-save-part)
23f87bed 1086 ("save and strip" . gnus-mime-save-part-and-strip)
01c52d31 1087 ("replace with file" . gnus-mime-replace-part)
23f87bed 1088 ("delete part" . gnus-mime-delete-part)
e0bad764
DL		 1089 ("display as text" . gnus-mime-inline-part)
1090 ("view the part" . gnus-mime-view-part)
1091 ("pipe to command" . gnus-mime-pipe-part)
1092 ("toggle display" . gnus-article-press-button)
23f87bed 1093 ("toggle display" . gnus-article-view-part-as-charset)
e0bad764 1094 ("view as type" . gnus-mime-view-part-as-type)
23f87bed
MB		 1095 ("view internally" . gnus-mime-view-part-internally)
1096 ("view externally" . gnus-mime-view-part-externally))
e0bad764
DL		 1097 "An alist of actions that run on the MIME attachment."
1098 :group 'gnus-article-mime
1099 :type '(repeat (cons (string :tag "name")
1100 (function))))
1101
01c52d31
MB		 1102(defcustom gnus-auto-select-part 1
1103 "Advance to next MIME part when deleting or stripping parts.
1104
1105When 0, point will be placed on the same part as before. When
1106positive (negative), move point forward (backwards) this many
1107parts. When nil, redisplay article."
330f707b 1108 :version "23.1" ;; No Gnus
01c52d31
MB		 1109 :group 'gnus-article-mime
1110 :type '(choice (const nil :tag "Redisplay article.")
1111 (const 1 :tag "Next part.")
1112 (const 0 :tag "Current part.")
1113 integer))
1114
16409b0b
GM		 1115;;;
1116;;; The treatment variables
1117;;;
1118
1119(defvar gnus-part-display-hook nil
1120 "Hook called on parts that are to receive treatment.")
1121
1122(defvar gnus-article-treat-custom
1123 '(choice (const :tag "Off" nil)
1124 (const :tag "On" t)
1125 (const :tag "Header" head)
01c52d31 1126 (const :tag "First" first)
16409b0b
GM		 1127 (const :tag "Last" last)
1128 (integer :tag "Less")
1129 (repeat :tag "Groups" regexp)
1130 (sexp :tag "Predicate")))
1131
1132(defvar gnus-article-treat-head-custom
1133 '(choice (const :tag "Off" nil)
1134 (const :tag "Header" head)))
1135
01c52d31
MB		 1136(defvar gnus-article-treat-types '("text/plain" "text/x-verbatim"
1137 "text/x-patch")
16409b0b
GM		 1138 "Parts to treat.")
1139
1140(defvar gnus-inhibit-treatment nil
1141 "Whether to inhibit treatment.")
1142
23f87bed 1143(defcustom gnus-treat-highlight-signature '(or t (typep "text/x-vcard"))
16409b0b 1144 "Highlight the signature.
01c52d31
MB		 1145Valid values are nil, t, `head', `first', `last', an integer or a
1146predicate. See Info node `(gnus)Customizing Articles'."
16409b0b 1147 :group 'gnus-article-treat
23f87bed 1148 :link '(custom-manual "(gnus)Customizing Articles")
16409b0b
GM		 1149 :type gnus-article-treat-custom)
1150(put 'gnus-treat-highlight-signature 'highlight t)
1151
1152(defcustom gnus-treat-buttonize 100000
1153 "Add buttons.
01c52d31
MB		 1154Valid values are nil, t, `head', `first', `last', an integer or a
1155predicate. See Info node `(gnus)Customizing Articles'."
16409b0b 1156 :group 'gnus-article-treat
23f87bed 1157 :link '(custom-manual "(gnus)Customizing Articles")
16409b0b
GM		 1158 :type gnus-article-treat-custom)
1159(put 'gnus-treat-buttonize 'highlight t)
1160
1161(defcustom gnus-treat-buttonize-head 'head
1162 "Add buttons to the head.
01c52d31
MB		 1163Valid values are nil, t, `head', `first', `last', an integer or a
1164predicate. See Info node `(gnus)Customizing Articles'."
16409b0b 1165 :group 'gnus-article-treat
23f87bed 1166 :link '(custom-manual "(gnus)Customizing Articles")
16409b0b
GM		 1167 :type gnus-article-treat-head-custom)
1168(put 'gnus-treat-buttonize-head 'highlight t)
1169
12e3ca0a
LI		 1170(defcustom gnus-treat-date 'head
1171 "Display dates according to the `gnus-article-date-headers' variable.
1172Valid values are nil, t, `head', `first', `last', an integer or a
1173predicate. See Info node `(gnus)Customizing Articles'."
1174 :version "24.1"
1175 :group 'gnus-article-treat
1176 :link '(custom-manual "(gnus)Customizing Articles")
1177 :type gnus-article-treat-head-custom)
1178
437ce4be 1179(defcustom gnus-treat-emphasize 50000
16409b0b 1180 "Emphasize text.
01c52d31
MB		 1181Valid values are nil, t, `head', `first', `last', an integer or a
1182predicate. See Info node `(gnus)Customizing Articles'."
16409b0b 1183 :group 'gnus-article-treat
23f87bed 1184 :link '(custom-manual "(gnus)Customizing Articles")
16409b0b
GM		 1185 :type gnus-article-treat-custom)
1186(put 'gnus-treat-emphasize 'highlight t)
1187
1188(defcustom gnus-treat-strip-cr nil
1189 "Remove carriage returns.
01c52d31
MB		 1190Valid values are nil, t, `head', `first', `last', an integer or a
1191predicate. See Info node `(gnus)Customizing Articles'."
bf247b6e 1192 :version "22.1"
16409b0b 1193 :group 'gnus-article-treat
23f87bed
MB		 1194 :link '(custom-manual "(gnus)Customizing Articles")
1195 :type gnus-article-treat-custom)
1196
1197(defcustom gnus-treat-unsplit-urls nil
1198 "Remove newlines from within URLs.
01c52d31
MB		 1199Valid values are nil, t, `head', `first', `last', an integer or a
1200predicate. See Info node `(gnus)Customizing Articles'."
bf247b6e 1201 :version "22.1"
23f87bed
MB		 1202 :group 'gnus-article-treat
1203 :link '(custom-manual "(gnus)Customizing Articles")
1204 :type gnus-article-treat-custom)
1205
1206(defcustom gnus-treat-leading-whitespace nil
1207 "Remove leading whitespace in headers.
01c52d31
MB		 1208Valid values are nil, t, `head', `first', `last', an integer or a
1209predicate. See Info node `(gnus)Customizing Articles'."
bf247b6e 1210 :version "22.1"
23f87bed
MB		 1211 :group 'gnus-article-treat
1212 :link '(custom-manual "(gnus)Customizing Articles")
16409b0b
GM		 1213 :type gnus-article-treat-custom)
1214
1215(defcustom gnus-treat-hide-headers 'head
1216 "Hide headers.
01c52d31
MB		 1217Valid values are nil, t, `head', `first', `last', an integer or a
1218predicate. See Info node `(gnus)Customizing Articles'."
16409b0b 1219 :group 'gnus-article-treat
23f87bed 1220 :link '(custom-manual "(gnus)Customizing Articles")
16409b0b
GM		 1221 :type gnus-article-treat-head-custom)
1222
1223(defcustom gnus-treat-hide-boring-headers nil
1224 "Hide boring headers.
01c52d31
MB		 1225Valid values are nil, t, `head', `first', `last', an integer or a
1226predicate. See Info node `(gnus)Customizing Articles'."
16409b0b 1227 :group 'gnus-article-treat
23f87bed 1228 :link '(custom-manual "(gnus)Customizing Articles")
16409b0b
GM		 1229 :type gnus-article-treat-head-custom)
1230
1231(defcustom gnus-treat-hide-signature nil
1232 "Hide the signature.
01c52d31
MB		 1233Valid values are nil, t, `head', `first', `last', an integer or a
1234predicate. See Info node `(gnus)Customizing Articles'."
16409b0b 1235 :group 'gnus-article-treat
23f87bed 1236 :link '(custom-manual "(gnus)Customizing Articles")
16409b0b
GM		 1237 :type gnus-article-treat-custom)
1238
1239(defcustom gnus-treat-fill-article nil
1240 "Fill the article.
01c52d31
MB		 1241Valid values are nil, t, `head', `first', `last', an integer or a
1242predicate. See Info node `(gnus)Customizing Articles'."
16409b0b 1243 :group 'gnus-article-treat
23f87bed 1244 :link '(custom-manual "(gnus)Customizing Articles")
16409b0b
GM		 1245 :type gnus-article-treat-custom)
1246
1247(defcustom gnus-treat-hide-citation nil
1248 "Hide cited text.
01c52d31
MB		 1249Valid values are nil, t, `head', `first', `last', an integer or a
1250predicate. See Info node `(gnus)Customizing Articles'."
16409b0b 1251 :group 'gnus-article-treat
23f87bed 1252 :link '(custom-manual "(gnus)Customizing Articles")
16409b0b
GM		 1253 :type gnus-article-treat-custom)
1254
e0bad764
DL		 1255(defcustom gnus-treat-hide-citation-maybe nil
1256 "Hide cited text.
01c52d31
MB		 1257Valid values are nil, t, `head', `first', `last', an integer or a
1258predicate. See Info node `(gnus)Customizing Articles'."
e0bad764 1259 :group 'gnus-article-treat
23f87bed 1260 :link '(custom-manual "(gnus)Customizing Articles")
e0bad764
DL		 1261 :type gnus-article-treat-custom)
1262
16409b0b
GM		 1263(defcustom gnus-treat-strip-list-identifiers 'head
1264 "Strip list identifiers from `gnus-list-identifiers`.
01c52d31
MB		 1265Valid values are nil, t, `head', `first', `last', an integer or a
1266predicate. See Info node `(gnus)Customizing Articles'."
fc2c2db8 1267 :version "21.1"
16409b0b 1268 :group 'gnus-article-treat
23f87bed 1269 :link '(custom-manual "(gnus)Customizing Articles")
16409b0b
GM		 1270 :type gnus-article-treat-custom)
1271
265ac10b
SM		 1272(make-obsolete-variable 'gnus-treat-strip-pgp nil
1273 "Gnus 5.10 (Emacs 22.1)")
16409b0b
GM		 1274
1275(defcustom gnus-treat-strip-pem nil
1276 "Strip PEM signatures.
01c52d31
MB		 1277Valid values are nil, t, `head', `first', `last', an integer or a
1278predicate. See Info node `(gnus)Customizing Articles'."
16409b0b 1279 :group 'gnus-article-treat
23f87bed 1280 :link '(custom-manual "(gnus)Customizing Articles")
16409b0b
GM		 1281 :type gnus-article-treat-custom)
1282
1283(defcustom gnus-treat-strip-banner t
1284 "Strip banners from articles.
1285The banner to be stripped is specified in the `banner' group parameter.
01c52d31
MB		 1286Valid values are nil, t, `head', `first', `last', an integer or a
1287predicate. See Info node `(gnus)Customizing Articles'."
16409b0b 1288 :group 'gnus-article-treat
23f87bed 1289 :link '(custom-manual "(gnus)Customizing Articles")
16409b0b
GM		 1290 :type gnus-article-treat-custom)
1291
1292(defcustom gnus-treat-highlight-headers 'head
1293 "Highlight the headers.
01c52d31
MB		 1294Valid values are nil, t, `head', `first', `last', an integer or a
1295predicate. See Info node `(gnus)Customizing Articles'."
16409b0b 1296 :group 'gnus-article-treat
23f87bed 1297 :link '(custom-manual "(gnus)Customizing Articles")
16409b0b
GM		 1298 :type gnus-article-treat-head-custom)
1299(put 'gnus-treat-highlight-headers 'highlight t)
1300
1301(defcustom gnus-treat-highlight-citation t
1302 "Highlight cited text.
01c52d31
MB		 1303Valid values are nil, t, `head', `first', `last', an integer or a
1304predicate. See Info node `(gnus)Customizing Articles'."
16409b0b 1305 :group 'gnus-article-treat
23f87bed 1306 :link '(custom-manual "(gnus)Customizing Articles")
16409b0b
GM		 1307 :type gnus-article-treat-custom)
1308(put 'gnus-treat-highlight-citation 'highlight t)
1309
16409b0b
GM		 1310(defcustom gnus-treat-strip-headers-in-body t
1311 "Strip the X-No-Archive header line from the beginning of the body.
01c52d31
MB		 1312Valid values are nil, t, `head', `first', `last', an integer or a
1313predicate. See Info node `(gnus)Customizing Articles'."
fc2c2db8 1314 :version "21.1"
16409b0b 1315 :group 'gnus-article-treat
23f87bed 1316 :link '(custom-manual "(gnus)Customizing Articles")
16409b0b
GM		 1317 :type gnus-article-treat-custom)
1318
1319(defcustom gnus-treat-strip-trailing-blank-lines nil
1320 "Strip trailing blank lines.
01c52d31
MB		 1321Valid values are nil, t, `head', `first', `last', an integer or a
1322predicate. See Info node `(gnus)Customizing Articles'.
292f71fe
MB		 1323
1324When set to t, it also strips trailing blanks in all MIME parts.
1325Consider to use `last' instead."
16409b0b 1326 :group 'gnus-article-treat
23f87bed 1327 :link '(custom-manual "(gnus)Customizing Articles")
16409b0b
GM		 1328 :type gnus-article-treat-custom)
1329
1330(defcustom gnus-treat-strip-leading-blank-lines nil
1331 "Strip leading blank lines.
01c52d31
MB		 1332Valid values are nil, t, `head', `first', `last', an integer or a
1333predicate. See Info node `(gnus)Customizing Articles'.
292f71fe
MB		 1334
1335When set to t, it also strips trailing blanks in all MIME parts."
16409b0b 1336 :group 'gnus-article-treat
23f87bed 1337 :link '(custom-manual "(gnus)Customizing Articles")
16409b0b
GM		 1338 :type gnus-article-treat-custom)
1339
1340(defcustom gnus-treat-strip-multiple-blank-lines nil
1341 "Strip multiple blank lines.
01c52d31
MB		 1342Valid values are nil, t, `head', `first', `last', an integer or a
1343predicate. See Info node `(gnus)Customizing Articles'."
16409b0b 1344 :group 'gnus-article-treat
23f87bed
MB		 1345 :link '(custom-manual "(gnus)Customizing Articles")
1346 :type gnus-article-treat-custom)
1347
1348(defcustom gnus-treat-unfold-headers 'head
1349 "Unfold folded header lines.
01c52d31
MB		 1350Valid values are nil, t, `head', `first', `last', an integer or a
1351predicate. See Info node `(gnus)Customizing Articles'."
bf247b6e 1352 :version "22.1"
23f87bed
MB		 1353 :group 'gnus-article-treat
1354 :link '(custom-manual "(gnus)Customizing Articles")
1355 :type gnus-article-treat-custom)
1356
01c52d31
MB		 1357(defcustom gnus-article-unfold-long-headers nil
1358 "If non-nil, allow unfolding headers even if the header is long.
1359If it is a regexp, only long headers matching this regexp are unfolded.
1360If it is t, all long headers are unfolded.
1361
1362This variable has no effect if `gnus-treat-unfold-headers' is nil."
330f707b 1363 :version "23.1" ;; No Gnus
01c52d31
MB		 1364 :group 'gnus-article-treat
1365 :type '(choice (const nil)
1366 (const :tag "all" t)
1367 (regexp)))
1368
23f87bed
MB		 1369(defcustom gnus-treat-fold-headers nil
1370 "Fold headers.
01c52d31
MB		 1371Valid values are nil, t, `head', `first', `last', an integer or a
1372predicate. See Info node `(gnus)Customizing Articles'."
bf247b6e 1373 :version "22.1"
23f87bed
MB		 1374 :group 'gnus-article-treat
1375 :link '(custom-manual "(gnus)Customizing Articles")
1376 :type gnus-article-treat-custom)
1377
1378(defcustom gnus-treat-fold-newsgroups 'head
1379 "Fold the Newsgroups and Followup-To headers.
01c52d31
MB		 1380Valid values are nil, t, `head', `first', `last', an integer or a
1381predicate. See Info node `(gnus)Customizing Articles'."
bf247b6e 1382 :version "22.1"
23f87bed
MB		 1383 :group 'gnus-article-treat
1384 :link '(custom-manual "(gnus)Customizing Articles")
16409b0b
GM		 1385 :type gnus-article-treat-custom)
1386
1387(defcustom gnus-treat-overstrike t
1388 "Treat overstrike highlighting.
01c52d31
MB		 1389Valid values are nil, t, `head', `first', `last', an integer or a
1390predicate. See Info node `(gnus)Customizing Articles'."
16409b0b 1391 :group 'gnus-article-treat
23f87bed 1392 :link '(custom-manual "(gnus)Customizing Articles")
16409b0b
GM		 1393 :type gnus-article-treat-custom)
1394(put 'gnus-treat-overstrike 'highlight t)
1395
01c52d31
MB		 1396(defcustom gnus-treat-ansi-sequences (if (locate-library "ansi-color") t)
1397 "Treat ANSI SGR control sequences.
1398Valid values are nil, t, `head', `first', `last', an integer or a
1399predicate. See Info node `(gnus)Customizing Articles'."
1400 :group 'gnus-article-treat
1401 :link '(custom-manual "(gnus)Customizing Articles")
1402 :type gnus-article-treat-custom)
1403
23f87bed 1404(make-obsolete-variable 'gnus-treat-display-xface
6b958814 1405 'gnus-treat-display-x-face "Emacs 22.1")
23f87bed
MB		 1406
1407(defcustom gnus-treat-display-x-face
1408 (and (not noninteractive)
11e95b02
MB		 1409 (gnus-image-type-available-p 'xbm)
1410 (if (featurep 'xemacs)
1411 (featurep 'xface)
86f5c034
SM		 1412 (condition-case nil
1413 (and (string-match "^0x" (shell-command-to-string "uncompface"))
1414 (executable-find "icontopbm"))
1415 ;; shell-command-to-string may signal an error, e.g. if
1416 ;; shell-file-name is not found.
1417 (error nil)))
8b93df01 1418 'head)
16409b0b 1419 "Display X-Face headers.
87ba2830 1420Valid values are nil and `head'.
23f87bed
MB		 1421See Info node `(gnus)Customizing Articles' and Info node
1422`(gnus)X-Face' for details."
1423 :group 'gnus-article-treat
1424 :version "21.1"
1425 :link '(custom-manual "(gnus)Customizing Articles")
1426 :link '(custom-manual "(gnus)X-Face")
1427 :type gnus-article-treat-head-custom
1428 :set (lambda (symbol value)
1429 (set-default
1430 symbol
1431 (cond ((or (boundp symbol) (get symbol 'saved-value))
1432 value)
1433 ((boundp 'gnus-treat-display-xface)
1434 (message "\
1435** gnus-treat-display-xface is an obsolete variable;\
1436 use gnus-treat-display-x-face instead")
1437 (default-value 'gnus-treat-display-xface))
1438 ((get 'gnus-treat-display-xface 'saved-value)
1439 (message "\
1440** gnus-treat-display-xface is an obsolete variable;\
1441 use gnus-treat-display-x-face instead")
1442 (eval (car (get 'gnus-treat-display-xface 'saved-value))))
1443 (t
1444 value)))))
1445(put 'gnus-treat-display-x-face 'highlight t)
1446
1447(defcustom gnus-treat-display-face
1448 (and (not noninteractive)
11e95b02 1449 (gnus-image-type-available-p 'png)
23f87bed
MB		 1450 'head)
1451 "Display Face headers.
01c52d31
MB		 1452Valid values are nil, t, `head', `first', `last', an integer or a
1453predicate. See Info node `(gnus)Customizing Articles' and Info
41ec3f54 1454node `(gnus)Face' for details."
16409b0b 1455 :group 'gnus-article-treat
bf247b6e 1456 :version "22.1"
23f87bed
MB		 1457 :link '(custom-manual "(gnus)Customizing Articles")
1458 :link '(custom-manual "(gnus)X-Face")
16409b0b 1459 :type gnus-article-treat-head-custom)
23f87bed 1460(put 'gnus-treat-display-face 'highlight t)
16409b0b 1461
11e95b02 1462(defcustom gnus-treat-display-smileys (gnus-image-type-available-p 'xpm)
16409b0b 1463 "Display smileys.
01c52d31
MB		 1464Valid values are nil, t, `head', `first', `last', an integer or a
1465predicate. See Info node `(gnus)Customizing Articles' and Info
1466node `(gnus)Smileys' for details."
16409b0b 1467 :group 'gnus-article-treat
b5a206e7 1468 :version "21.1"
23f87bed
MB		 1469 :link '(custom-manual "(gnus)Customizing Articles")
1470 :link '(custom-manual "(gnus)Smileys")
16409b0b
GM		 1471 :type gnus-article-treat-custom)
1472(put 'gnus-treat-display-smileys 'highlight t)
1473
23f87bed
MB		 1474(defcustom gnus-treat-from-picon
1475 (if (and (gnus-image-type-available-p 'xpm)
1476 (gnus-picons-installed-p))
1477 'head nil)
1478 "Display picons in the From header.
01c52d31
MB		 1479Valid values are nil, t, `head', `first', `last', an integer or a
1480predicate. See Info node `(gnus)Customizing Articles' and Info
1481node `(gnus)Picons' for details."
bf247b6e 1482 :version "22.1"
16409b0b 1483 :group 'gnus-article-treat
23f87bed
MB		 1484 :group 'gnus-picon
1485 :link '(custom-manual "(gnus)Customizing Articles")
1486 :link '(custom-manual "(gnus)Picons")
1487 :type gnus-article-treat-head-custom)
1488(put 'gnus-treat-from-picon 'highlight t)
1489
1490(defcustom gnus-treat-mail-picon
1491 (if (and (gnus-image-type-available-p 'xpm)
1492 (gnus-picons-installed-p))
1493 'head nil)
1494 "Display picons in To and Cc headers.
01c52d31
MB		 1495Valid values are nil, t, `head', `first', `last', an integer or a
1496predicate. See Info node `(gnus)Customizing Articles' and Info
1497node `(gnus)Picons' for details."
bf247b6e 1498 :version "22.1"
23f87bed
MB		 1499 :group 'gnus-article-treat
1500 :group 'gnus-picon
1501 :link '(custom-manual "(gnus)Customizing Articles")
1502 :link '(custom-manual "(gnus)Picons")
1503 :type gnus-article-treat-head-custom)
1504(put 'gnus-treat-mail-picon 'highlight t)
1505
1506(defcustom gnus-treat-newsgroups-picon
1507 (if (and (gnus-image-type-available-p 'xpm)
1508 (gnus-picons-installed-p))
1509 'head nil)
1510 "Display picons in the Newsgroups and Followup-To headers.
01c52d31
MB		 1511Valid values are nil, t, `head', `first', `last', an integer or a
1512predicate. See Info node `(gnus)Customizing Articles' and Info
1513node `(gnus)Picons' for details."
bf247b6e 1514 :version "22.1"
23f87bed
MB		 1515 :group 'gnus-article-treat
1516 :group 'gnus-picon
1517 :link '(custom-manual "(gnus)Customizing Articles")
1518 :link '(custom-manual "(gnus)Picons")
1519 :type gnus-article-treat-head-custom)
1520(put 'gnus-treat-newsgroups-picon 'highlight t)
1521
6688abe0 1522(defcustom gnus-treat-from-gravatar nil
61b1af82
G		 1523 "Display gravatars in the From header.
1524Valid values are nil, t, `head', `first', `last', an integer or a
1525predicate. See Info node `(gnus)Customizing Articles' and Info
1526node `(gnus)Gravatars' for details."
1527 :version "24.1"
1528 :group 'gnus-article-treat
1529 :group 'gnus-gravatar
1530 :link '(custom-manual "(gnus)Customizing Articles")
1531 :link '(custom-manual "(gnus)Gravatars")
1532 :type gnus-article-treat-head-custom)
1533(put 'gnus-treat-from-gravatar 'highlight t)
1534
6688abe0 1535(defcustom gnus-treat-mail-gravatar nil
61b1af82
G		 1536 "Display gravatars in To and Cc headers.
1537Valid values are nil, t, `head', `first', `last', an integer or a
1538predicate. See Info node `(gnus)Customizing Articles' and Info
1539node `(gnus)Gravatars' for details."
1540 :version "24.1"
1541 :group 'gnus-article-treat
1542 :group 'gnus-gravatar
1543 :link '(custom-manual "(gnus)Customizing Articles")
1544 :link '(custom-manual "(gnus)Gravatars")
1545 :type gnus-article-treat-head-custom)
1546(put 'gnus-treat-mail-gravatar 'highlight t)
1547
23f87bed 1548(defcustom gnus-treat-body-boundary
437ce4be
MB		 1549 (if (or gnus-treat-newsgroups-picon
1550 gnus-treat-mail-picon
61b1af82
G		 1551 gnus-treat-from-picon
1552 gnus-treat-from-gravatar
1553 gnus-treat-mail-gravatar)
437ce4be
MB		 1554 ;; If there's much decoration, the user might prefer a boundery.
1555 'head
1556 nil)
23f87bed
MB		 1557 "Draw a boundary at the end of the headers.
1558Valid values are nil and `head'.
1559See Info node `(gnus)Customizing Articles' for details."
bf247b6e 1560 :version "22.1"
23f87bed
MB		 1561 :group 'gnus-article-treat
1562 :link '(custom-manual "(gnus)Customizing Articles")
16409b0b 1563 :type gnus-article-treat-head-custom)
16409b0b
GM		 1564
1565(defcustom gnus-treat-capitalize-sentences nil
1566 "Capitalize sentence-starting words.
01c52d31
MB		 1567Valid values are nil, t, `head', `first', `last', an integer or a
1568predicate. See Info node `(gnus)Customizing Articles'."
fc2c2db8 1569 :version "21.1"
16409b0b 1570 :group 'gnus-article-treat
23f87bed
MB		 1571 :link '(custom-manual "(gnus)Customizing Articles")
1572 :type gnus-article-treat-custom)
1573
1574(defcustom gnus-treat-wash-html nil
1575 "Format as HTML.
01c52d31
MB		 1576Valid values are nil, t, `head', `first', `last', an integer or a
1577predicate. See Info node `(gnus)Customizing Articles'."
bf247b6e 1578 :version "22.1"
23f87bed
MB		 1579 :group 'gnus-article-treat
1580 :link '(custom-manual "(gnus)Customizing Articles")
16409b0b
GM		 1581 :type gnus-article-treat-custom)
1582
389b76fa 1583(defcustom gnus-treat-fill-long-lines '(typep "text/plain")
16409b0b 1584 "Fill long lines.
01c52d31
MB		 1585Valid values are nil, t, `head', `first', `last', an integer or a
1586predicate. See Info node `(gnus)Customizing Articles'."
37657cbd 1587 :version "24.1"
16409b0b 1588 :group 'gnus-article-treat
23f87bed 1589 :link '(custom-manual "(gnus)Customizing Articles")
16409b0b
GM		 1590 :type gnus-article-treat-custom)
1591
23f87bed
MB		 1592(defcustom gnus-treat-x-pgp-sig nil
1593 "Verify X-PGP-Sig.
1594To automatically treat X-PGP-Sig, set it to head.
01c52d31
MB		 1595Valid values are nil, t, `head', `first', `last', an integer or a
1596predicate. See Info node `(gnus)Customizing Articles'."
bf247b6e 1597 :version "22.1"
23f87bed
MB		 1598 :group 'gnus-article-treat
1599 :group 'mime-security
1600 :link '(custom-manual "(gnus)Customizing Articles")
1601 :type gnus-article-treat-custom)
1602
1603(defvar gnus-article-encrypt-protocol-alist
1604 '(("PGP" . mml2015-self-encrypt)))
1605
1606;; Set to nil if more than one protocol added to
1607;; gnus-article-encrypt-protocol-alist.
1608(defcustom gnus-article-encrypt-protocol "PGP"
1609 "The protocol used for encrypt articles.
1610It is a string, such as \"PGP\". If nil, ask user."
bf247b6e 1611 :version "22.1"
23f87bed
MB		 1612 :type 'string
1613 :group 'mime-security)
1614
23f87bed
MB		 1615(defcustom gnus-use-idna (and (condition-case nil (require 'idna) (file-error))
1616 (mm-coding-system-p 'utf-8)
1617 (executable-find idna-program))
1618 "Whether IDNA decoding of headers is used when viewing messages.
1619This requires GNU Libidn, and by default only enabled if it is found."
bf247b6e 1620 :version "22.1"
23f87bed
MB		 1621 :group 'gnus-article-headers
1622 :type 'boolean)
1623
1624(defcustom gnus-article-over-scroll nil
1625 "If non-nil, allow scrolling the article buffer even when there no more text."
bf247b6e 1626 :version "22.1"
23f87bed
MB		 1627 :group 'gnus-article
1628 :type 'boolean)
1629
40de2c6d
KY		 1630(defcustom gnus-inhibit-images nil
1631 "Non-nil means inhibit displaying of images inline in the article body."
1632 :version "24.1"
1633 :group 'gnus-article
1634 :type 'boolean)
1635
2526f423
G		 1636(defcustom gnus-blocked-images 'gnus-block-private-groups
1637 "Images that have URLs matching this regexp will be blocked.
1638This can also be a function to be evaluated. If so, it will be
1639called with the group name as the parameter, and should return a
1640regexp."
130e977f
LMI		 1641 :version "24.1"
1642 :group 'gnus-art
1643 :type 'regexp)
1644
eec82323
LMI		 1645;;; Internal variables
1646
23f87bed
MB		 1647(defvar gnus-english-month-names
1648 '("January" "February" "March" "April" "May" "June" "July" "August"
1649 "September" "October" "November" "December"))
1650
16409b0b
GM		 1651(defvar article-goto-body-goes-to-point-min-p nil)
1652(defvar gnus-article-wash-types nil)
1653(defvar gnus-article-emphasis-alist nil)
23f87bed 1654(defvar gnus-article-image-alist nil)
16409b0b
GM		 1655
1656(defvar gnus-article-mime-handle-alist-1 nil)
1657(defvar gnus-treatment-function-alist
23f87bed
MB		 1658 '((gnus-treat-x-pgp-sig gnus-article-verify-x-pgp-sig)
1659 (gnus-treat-strip-banner gnus-article-strip-banner)
16409b0b
GM		 1660 (gnus-treat-strip-headers-in-body gnus-article-strip-headers-in-body)
1661 (gnus-treat-highlight-signature gnus-article-highlight-signature)
1662 (gnus-treat-buttonize gnus-article-add-buttons)
1663 (gnus-treat-fill-article gnus-article-fill-cited-article)
389b76fa 1664 (gnus-treat-fill-long-lines gnus-article-fill-cited-long-lines)
16409b0b 1665 (gnus-treat-strip-cr gnus-article-remove-cr)
23f87bed 1666 (gnus-treat-unsplit-urls gnus-article-unsplit-urls)
23f87bed
MB		 1667 (gnus-treat-display-x-face gnus-article-display-x-face)
1668 (gnus-treat-display-face gnus-article-display-face)
16409b0b
GM		 1669 (gnus-treat-hide-headers gnus-article-maybe-hide-headers)
1670 (gnus-treat-hide-boring-headers gnus-article-hide-boring-headers)
1671 (gnus-treat-hide-signature gnus-article-hide-signature)
16409b0b 1672 (gnus-treat-strip-list-identifiers gnus-article-hide-list-identifiers)
23f87bed 1673 (gnus-treat-leading-whitespace gnus-article-remove-leading-whitespace)
2696d88f
G		 1674 (gnus-treat-from-picon gnus-treat-from-picon)
1675 (gnus-treat-mail-picon gnus-treat-mail-picon)
1676 (gnus-treat-newsgroups-picon gnus-treat-newsgroups-picon)
16409b0b 1677 (gnus-treat-strip-pem gnus-article-hide-pem)
12e3ca0a 1678 (gnus-treat-date gnus-article-treat-date)
61b1af82
G		 1679 (gnus-treat-from-gravatar gnus-treat-from-gravatar)
1680 (gnus-treat-mail-gravatar gnus-treat-mail-gravatar)
16409b0b 1681 (gnus-treat-highlight-headers gnus-article-highlight-headers)
16409b0b 1682 (gnus-treat-highlight-signature gnus-article-highlight-signature)
16409b0b
GM		 1683 (gnus-treat-strip-trailing-blank-lines
1684 gnus-article-remove-trailing-blank-lines)
1685 (gnus-treat-strip-leading-blank-lines
1686 gnus-article-strip-leading-blank-lines)
1687 (gnus-treat-strip-multiple-blank-lines
1688 gnus-article-strip-multiple-blank-lines)
1689 (gnus-treat-overstrike gnus-article-treat-overstrike)
01c52d31 1690 (gnus-treat-ansi-sequences gnus-article-treat-ansi-sequences)
23f87bed 1691 (gnus-treat-unfold-headers gnus-article-treat-unfold-headers)
23f87bed 1692 (gnus-treat-fold-newsgroups gnus-article-treat-fold-newsgroups)
01c52d31 1693 (gnus-treat-fold-headers gnus-article-treat-fold-headers)
16409b0b 1694 (gnus-treat-buttonize-head gnus-article-add-buttons-to-head)
23f87bed 1695 (gnus-treat-display-smileys gnus-treat-smiley)
16409b0b 1696 (gnus-treat-capitalize-sentences gnus-article-capitalize-sentences)
23f87bed
MB		 1697 (gnus-treat-wash-html gnus-article-wash-html)
1698 (gnus-treat-emphasize gnus-article-emphasize)
1699 (gnus-treat-hide-citation gnus-article-hide-citation)
1700 (gnus-treat-hide-citation-maybe gnus-article-hide-citation-maybe)
1701 (gnus-treat-highlight-citation gnus-article-highlight-citation)
8ccbef23 1702 (gnus-treat-body-boundary gnus-article-treat-body-boundary)))
16409b0b
GM		 1703
1704(defvar gnus-article-mime-handle-alist nil)
6748645f
LMI		 1705(defvar article-lapsed-timer nil)
1706(defvar gnus-article-current-summary nil)
1707
eec82323
LMI		 1708(defvar gnus-article-mode-syntax-table
1709 (let ((table (copy-syntax-table text-mode-syntax-table)))
23f87bed
MB		 1710 ;; This causes the citation match run O(2^n).
1711 ;; (modify-syntax-entry ?- "w" table)
1712 (modify-syntax-entry ?> ")<" table)
1713 (modify-syntax-entry ?< "(>" table)
1714 ;; make M-. in article buffers work for `foo' strings
1715 (modify-syntax-entry ?' " " table)
1716 (modify-syntax-entry ?` " " table)
eec82323
LMI		 1717 table)
1718 "Syntax table used in article mode buffers.
1719Initialized from `text-mode-syntax-table.")
1720
1721(defvar gnus-save-article-buffer nil)
1722
eec82323
LMI		 1723(defvar gnus-number-of-articles-to-be-saved nil)
1724
1725(defvar gnus-inhibit-hiding nil)
1726
c1d7d285
MB		 1727(defvar gnus-article-edit-mode nil)
1728
23f87bed
MB		 1729;;; Macros for dealing with the article buffer.
1730
1731(defmacro gnus-with-article-headers (&rest forms)
80de1778 1732 `(with-current-buffer gnus-article-buffer
23f87bed
MB		 1733 (save-restriction
1734 (let ((inhibit-read-only t)
1735 (inhibit-point-motion-hooks t)
1736 (case-fold-search t))
1737 (article-narrow-to-head)
1738 ,@forms))))
1739
1740(put 'gnus-with-article-headers 'lisp-indent-function 0)
1741(put 'gnus-with-article-headers 'edebug-form-spec '(body))
1742
1743(defmacro gnus-with-article-buffer (&rest forms)
80de1778 1744 `(with-current-buffer gnus-article-buffer
23f87bed
MB		 1745 (let ((inhibit-read-only t))
1746 ,@forms)))
1747
1748(put 'gnus-with-article-buffer 'lisp-indent-function 0)
1749(put 'gnus-with-article-buffer 'edebug-form-spec '(body))
1750
1751(defun gnus-article-goto-header (header)
1752 "Go to HEADER, which is a regular expression."
1753 (re-search-forward (concat "^\\(" header "\\):") nil t))
1754
eec82323
LMI		 1755(defsubst gnus-article-hide-text (b e props)
1756 "Set text PROPS on the B to E region, extending `intangible' 1 past B."
520aa572 1757 (gnus-add-text-properties-when 'article-type nil b e props)
eec82323
LMI		 1758 (when (memq 'intangible props)
1759 (put-text-property
1760 (max (1- b) (point-min))
1761 b 'intangible (cddr (memq 'intangible props)))))
520aa572 1762
eec82323
LMI		 1763(defsubst gnus-article-unhide-text (b e)
1764 "Remove hidden text properties from region between B and E."
1765 (remove-text-properties b e gnus-hidden-properties)
1766 (when (memq 'intangible gnus-hidden-properties)
1767 (put-text-property (max (1- b) (point-min))
1768 b 'intangible nil)))
1769
1770(defun gnus-article-hide-text-type (b e type)
1771 "Hide text of TYPE between B and E."
23f87bed 1772 (gnus-add-wash-type type)
eec82323
LMI		 1773 (gnus-article-hide-text
1774 b e (cons 'article-type (cons type gnus-hidden-properties))))
1775
1776(defun gnus-article-unhide-text-type (b e type)
6748645f 1777 "Unhide text of TYPE between B and E."
23f87bed 1778 (gnus-delete-wash-type type)
eec82323
LMI		 1779 (remove-text-properties
1780 b e (cons 'article-type (cons type gnus-hidden-properties)))
1781 (when (memq 'intangible gnus-hidden-properties)
1782 (put-text-property (max (1- b) (point-min))
1783 b 'intangible nil)))
1784
1785(defun gnus-article-hide-text-of-type (type)
1786 "Hide text of TYPE in the current buffer."
1787 (save-excursion
1788 (let ((b (point-min))
1789 (e (point-max)))
1790 (while (setq b (text-property-any b e 'article-type type))
1791 (add-text-properties b (incf b) gnus-hidden-properties)))))
1792
1793(defun gnus-article-delete-text-of-type (type)
1794 "Delete text of TYPE in the current buffer."
1795 (save-excursion
a8151ef7 1796 (let ((b (point-min)))
7dafe00b
MB		 1797 (if (eq type 'multipart)
1798 ;; Remove MIME buttons associated with multipart/alternative parts.
1799 (progn
1800 (goto-char b)
1801 (while (if (get-text-property (point) 'gnus-part)
1802 (setq b (point))
1803 (when (setq b (next-single-property-change (point)
1804 'gnus-part))
1805 (goto-char b)
1806 t))
1807 (end-of-line)
1808 (skip-chars-forward "\n")
1809 (when (eq (get-text-property b 'article-type) 'multipart)
1810 (delete-region b (point)))))
1811 (while (setq b (text-property-any b (point-max) 'article-type type))
1812 (delete-region
1813 b (or (text-property-not-all b (point-max) 'article-type type)
1814 (point-max))))))))
eec82323
LMI		 1815
1816(defun gnus-article-delete-invisible-text ()
1817 "Delete all invisible text in the current buffer."
1818 (save-excursion
a8151ef7
LMI		 1819 (let ((b (point-min)))
1820 (while (setq b (text-property-any b (point-max) 'invisible t))
1821 (delete-region
1822 b (or (text-property-not-all b (point-max) 'invisible t)
1823 (point-max)))))))
eec82323
LMI		 1824
1825(defun gnus-article-text-type-exists-p (type)
1826 "Say whether any text of type TYPE exists in the buffer."
1827 (text-property-any (point-min) (point-max) 'article-type type))
1828
1829(defsubst gnus-article-header-rank ()
1830 "Give the rank of the string HEADER as given by `gnus-sorted-header-list'."
1831 (let ((list gnus-sorted-header-list)
23f87bed 1832 (i 1))
eec82323 1833 (while list
23f87bed
MB		 1834 (if (looking-at (car list))
1835 (setq list nil)
1836 (setq list (cdr list))
1837 (incf i)))
1838 i))
eec82323
LMI		 1839
1840(defun article-hide-headers (&optional arg delete)
16409b0b
GM		 1841 "Hide unwanted headers and possibly sort them as well."
1842 (interactive)
1843 ;; This function might be inhibited.
1844 (unless gnus-inhibit-hiding
37cc095b 1845 (let ((inhibit-read-only t)
23f87bed
MB		 1846 (case-fold-search t)
1847 (max (1+ (length gnus-sorted-header-list)))
1848 (inhibit-point-motion-hooks t)
1849 (cur (current-buffer))
1850 ignored visible beg)
1851 (save-excursion
1852 ;; `gnus-ignored-headers' and `gnus-visible-headers' may be
1853 ;; group parameters, so we should go to the summary buffer.
1854 (when (prog1
1855 (condition-case nil
1856 (progn (set-buffer gnus-summary-buffer) t)
1857 (error nil))
1858 (setq ignored (when (not gnus-visible-headers)
1859 (cond ((stringp gnus-ignored-headers)
1860 gnus-ignored-headers)
1861 ((listp gnus-ignored-headers)
1862 (mapconcat 'identity
1863 gnus-ignored-headers
1864 "\\|"))))
1865 visible (cond ((stringp gnus-visible-headers)
1866 gnus-visible-headers)
1867 ((and gnus-visible-headers
1868 (listp gnus-visible-headers))
1869 (mapconcat 'identity
1870 gnus-visible-headers
1871 "\\|")))))
1872 (set-buffer cur))
1873 (save-restriction
16409b0b
GM		 1874 ;; First we narrow to just the headers.
1875 (article-narrow-to-head)
1876 ;; Hide any "From " lines at the beginning of (mail) articles.
1877 (while (looking-at "From ")
1878 (forward-line 1))
1879 (unless (bobp)
1880 (delete-region (point-min) (point)))
1881 ;; Then treat the rest of the header lines.
1882 ;; Then we use the two regular expressions
1883 ;; `gnus-ignored-headers' and `gnus-visible-headers' to
1884 ;; select which header lines is to remain visible in the
1885 ;; article buffer.
23f87bed 1886 (while (re-search-forward "^[^ \t:]*:" nil t)
16409b0b
GM		 1887 (beginning-of-line)
1888 ;; Mark the rank of the header.
1889 (put-text-property
1890 (point) (1+ (point)) 'message-rank
1891 (if (or (and visible (looking-at visible))
1892 (and ignored
1893 (not (looking-at ignored))))
1894 (gnus-article-header-rank)
1895 (+ 2 max)))
1896 (forward-line 1))
1897 (message-sort-headers-1)
1898 (when (setq beg (text-property-any
1899 (point-min) (point-max) 'message-rank (+ 2 max)))
1900 ;; We delete the unwanted headers.
23f87bed 1901 (gnus-add-wash-type 'headers)
16409b0b
GM		 1902 (add-text-properties (point-min) (+ 5 (point-min))
1903 '(article-type headers dummy-invisible t))
1904 (delete-region beg (point-max))))))))
eec82323
LMI		 1905
1906(defun article-hide-boring-headers (&optional arg)
1907 "Toggle hiding of headers that aren't very interesting.
1908If given a negative prefix, always show; if given a positive prefix,
1909always hide."
1910 (interactive (gnus-article-hidden-arg))
1911 (when (and (not (gnus-article-check-hidden-text 'boring-headers arg))
1912 (not gnus-show-all-headers))
1913 (save-excursion
1914 (save-restriction
4e7d0221 1915 (let ((inhibit-read-only t)
01c52d31 1916 (inhibit-point-motion-hooks t))
16409b0b 1917 (article-narrow-to-head)
01c52d31 1918 (dolist (elem gnus-boring-article-headers)
eec82323
LMI		 1919 (goto-char (point-min))
1920 (cond
1921 ;; Hide empty headers.
1922 ((eq elem 'empty)
16409b0b 1923 (while (re-search-forward "^[^: \t]+:[ \t]*\n[^ \t]" nil t)
eec82323
LMI		 1924 (forward-line -1)
1925 (gnus-article-hide-text-type
01c52d31 1926 (point-at-bol)
eec82323
LMI		 1927 (progn
1928 (end-of-line)
1929 (if (re-search-forward "^[^ \t]" nil t)
1930 (match-beginning 0)
1931 (point-max)))
1932 'boring-headers)))
1933 ;; Hide boring Newsgroups header.
1934 ((eq elem 'newsgroups)
23f87bed
MB		 1935 (when (gnus-string-equal
1936 (gnus-fetch-field "newsgroups")
1937 (gnus-group-real-name
1938 (if (boundp 'gnus-newsgroup-name)
1939 gnus-newsgroup-name
1940 "")))
eec82323 1941 (gnus-article-hide-header "newsgroups")))
23f87bed
MB		 1942 ((eq elem 'to-address)
1943 (let ((to (message-fetch-field "to"))
1944 (to-address
1945 (gnus-parameter-to-address
1946 (if (boundp 'gnus-newsgroup-name)
1947 gnus-newsgroup-name ""))))
1948 (when (and to to-address
1949 (ignore-errors
1950 (gnus-string-equal
1951 ;; only one address in To
1952 (nth 1 (mail-extract-address-components to))
1953 to-address)))
1954 (gnus-article-hide-header "to"))))
1955 ((eq elem 'to-list)
1956 (let ((to (message-fetch-field "to"))
1957 (to-list
1958 (gnus-parameter-to-list
1959 (if (boundp 'gnus-newsgroup-name)
1960 gnus-newsgroup-name ""))))
1961 (when (and to to-list
1962 (ignore-errors
1963 (gnus-string-equal
1964 ;; only one address in To
1965 (nth 1 (mail-extract-address-components to))
1966 to-list)))
1967 (gnus-article-hide-header "to"))))
1968 ((eq elem 'cc-list)
1969 (let ((cc (message-fetch-field "cc"))
1970 (to-list
1971 (gnus-parameter-to-list
1972 (if (boundp 'gnus-newsgroup-name)
1973 gnus-newsgroup-name ""))))
1974 (when (and cc to-list
1975 (ignore-errors
1976 (gnus-string-equal
1977 ;; only one address in CC
1978 (nth 1 (mail-extract-address-components cc))
1979 to-list)))
1980 (gnus-article-hide-header "cc"))))
eec82323 1981 ((eq elem 'followup-to)
23f87bed
MB		 1982 (when (gnus-string-equal
1983 (message-fetch-field "followup-to")
1984 (message-fetch-field "newsgroups"))
eec82323
LMI		 1985 (gnus-article-hide-header "followup-to")))
1986 ((eq elem 'reply-to)
23f87bed
MB		 1987 (if (gnus-group-find-parameter
1988 gnus-newsgroup-name 'broken-reply-to)
1989 (gnus-article-hide-header "reply-to")
1990 (let ((from (message-fetch-field "from"))
1991 (reply-to (message-fetch-field "reply-to")))
1992 (when
1993 (and
eec82323
LMI		 1994 from reply-to
1995 (ignore-errors
1996 (equal
23f87bed
MB		 1997 (sort (mapcar
1998 (lambda (x) (downcase (cadr x)))
1999 (mail-extract-address-components from t))
2000 'string<)
2001 (sort (mapcar
2002 (lambda (x) (downcase (cadr x)))
2003 (mail-extract-address-components reply-to t))
2004 'string<))))
2005 (gnus-article-hide-header "reply-to")))))
eec82323 2006 ((eq elem 'date)
b193caa3
MB		 2007 (let ((date (with-current-buffer gnus-original-article-buffer
2008 ;; If date in `gnus-article-buffer' is localized
2009 ;; (`gnus-treat-date-user-defined'),
2010 ;; `days-between' might fail.
2011 (message-fetch-field "date"))))
eec82323 2012 (when (and date
16409b0b 2013 (< (days-between (current-time-string) date)
eec82323 2014 4))
6748645f
LMI		 2015 (gnus-article-hide-header "date"))))
2016 ((eq elem 'long-to)
16409b0b
GM		 2017 (let ((to (message-fetch-field "to"))
2018 (cc (message-fetch-field "cc")))
6748645f 2019 (when (> (length to) 1024)
16409b0b
GM		 2020 (gnus-article-hide-header "to"))
2021 (when (> (length cc) 1024)
2022 (gnus-article-hide-header "cc"))))
6748645f 2023 ((eq elem 'many-to)
16409b0b
GM		 2024 (let ((to-count 0)
2025 (cc-count 0))
6748645f
LMI		 2026 (goto-char (point-min))
2027 (while (re-search-forward "^to:" nil t)
2028 (setq to-count (1+ to-count)))
2029 (when (> to-count 1)
2030 (while (> to-count 0)
2031 (goto-char (point-min))
2032 (save-restriction
2033 (re-search-forward "^to:" nil nil to-count)
2034 (forward-line -1)
2035 (narrow-to-region (point) (point-max))
2036 (gnus-article-hide-header "to"))
16409b0b
GM		 2037 (setq to-count (1- to-count))))
2038 (goto-char (point-min))
2039 (while (re-search-forward "^cc:" nil t)
2040 (setq cc-count (1+ cc-count)))
2041 (when (> cc-count 1)
2042 (while (> cc-count 0)
2043 (goto-char (point-min))
2044 (save-restriction
2045 (re-search-forward "^cc:" nil nil cc-count)
2046 (forward-line -1)
2047 (narrow-to-region (point) (point-max))
2048 (gnus-article-hide-header "cc"))
2049 (setq cc-count (1- cc-count)))))))))))))
eec82323
LMI		 2050
2051(defun gnus-article-hide-header (header)
2052 (save-excursion
2053 (goto-char (point-min))
2054 (when (re-search-forward (concat "^" header ":") nil t)
2055 (gnus-article-hide-text-type
01c52d31 2056 (point-at-bol)
eec82323
LMI		 2057 (progn
2058 (end-of-line)
2059 (if (re-search-forward "^[^ \t]" nil t)
2060 (match-beginning 0)
2061 (point-max)))
2062 'boring-headers))))
2063
16409b0b
GM		 2064(defvar gnus-article-normalized-header-length 40
2065 "Length of normalized headers.")
2066
2067(defun article-normalize-headers ()
2068 "Make all header lines 40 characters long."
2069 (interactive)
4e7d0221 2070 (let ((inhibit-read-only t)
16409b0b
GM		 2071 column)
2072 (save-excursion
2073 (save-restriction
2074 (article-narrow-to-head)
2075 (while (not (eobp))
2076 (cond
01c52d31 2077 ((< (setq column (- (point-at-eol) (point)))
16409b0b
GM		 2078 gnus-article-normalized-header-length)
2079 (end-of-line)
2080 (insert (make-string
2081 (- gnus-article-normalized-header-length column)
2082 ? )))
2083 ((> column gnus-article-normalized-header-length)
2084 (gnus-put-text-property
2085 (progn
2086 (forward-char gnus-article-normalized-header-length)
2087 (point))
01c52d31 2088 (point-at-eol)
16409b0b
GM		 2089 'invisible t))
2090 (t
2091 ;; Do nothing.
2092 ))
2093 (forward-line 1))))))
2094
6748645f 2095(defun article-treat-dumbquotes ()
23f87bed 2096 "Translate M****s*** sm*rtq**t*s and other symbols into proper text.
16409b0b 2097Note that this function guesses whether a character is a sm*rtq**t* or
74dd1b0d
SZ		 2098not, so it should only be used interactively.
2099
23f87bed
MB		 2100Sm*rtq**t*s are M****s***'s unilateral extension to the
2101iso-8859-1 character map in an attempt to provide more quoting
2102characters. If you see something like \\222 or \\264 where
2103you're expecting some kind of apostrophe or quotation mark, then
2104try this wash."
6748645f 2105 (interactive)
16409b0b 2106 (article-translate-strings gnus-article-dumbquotes-map))
6748645f 2107
16c1b3bc
KY		 2108(defvar org-entities)
2109
be3c11b3
LMI		 2110(defun article-treat-non-ascii ()
2111 "Translate many Unicode characters into their ASCII equivalents."
2112 (interactive)
2113 (require 'org-entities)
9c1d3f98 2114 (let ((table (make-char-table (if (featurep 'xemacs) 'generic))))
be3c11b3
LMI		 2115 (dolist (elem org-entities)
2116 (when (and (listp elem)
2117 (= (length (nth 6 elem)) 1))
fdf14191
KY		 2118 (if (featurep 'xemacs)
2119 (put-char-table (aref (nth 6 elem) 0) (nth 4 elem) table)
2120 (set-char-table-range table (aref (nth 6 elem) 0) (nth 4 elem)))))
be3c11b3
LMI		 2121 (save-excursion
2122 (when (article-goto-body)
2123 (let ((inhibit-read-only t)
2f0e0dc8 2124 replace props)
be3c11b3 2125 (while (not (eobp))
9c1d3f98
KY		 2126 (if (not (setq replace (if (featurep 'xemacs)
2127 (get-char-table (following-char) table)
2128 (aref table (following-char)))))
be3c11b3 2129 (forward-char 1)
2f0e0dc8
KY		 2130 (if (prog1
2131 (setq props (text-properties-at (point)))
2132 (delete-char 1))
2133 (add-text-properties (point) (progn (insert replace) (point))
2134 props)
2135 (insert replace)))))))))
be3c11b3 2136
6748645f
LMI		 2137(defun article-translate-characters (from to)
2138 "Translate all characters in the body of the article according to FROM and TO.
2139FROM is a string of characters to translate from; to is a string of
2140characters to translate to."
2141 (save-excursion
16409b0b 2142 (when (article-goto-body)
4e7d0221 2143 (let ((inhibit-read-only t)
6748645f
LMI		 2144 (x (make-string 225 ?x))
2145 (i -1))
2146 (while (< (incf i) (length x))
2147 (aset x i i))
2148 (setq i 0)
2149 (while (< i (length from))
2150 (aset x (aref from i) (aref to i))
2151 (incf i))
2152 (translate-region (point) (point-max) x)))))
2153
16409b0b
GM		 2154(defun article-translate-strings (map)
2155 "Translate all string in the body of the article according to MAP.
2156MAP is an alist where the elements are on the form (\"from\" \"to\")."
2157 (save-excursion
2158 (when (article-goto-body)
01c52d31
MB		 2159 (let ((inhibit-read-only t))
2160 (dolist (elem map)
7cad71ad
G		 2161 (let ((from (car elem))
2162 (to (cadr elem)))
2163 (save-excursion
2164 (if (stringp from)
2165 (while (search-forward from nil t)
2166 (replace-match to))
2167 (while (not (eobp))
2168 (if (eq (following-char) from)
2169 (progn
2170 (delete-char 1)
2171 (insert to))
2172 (forward-char 1)))))))))))
16409b0b 2173
eec82323
LMI		 2174(defun article-treat-overstrike ()
2175 "Translate overstrikes into bold text."
2176 (interactive)
2177 (save-excursion
16409b0b 2178 (when (article-goto-body)
4e7d0221 2179 (let ((inhibit-read-only t))
eec82323 2180 (while (search-forward "\b" nil t)
16409b0b 2181 (let ((next (char-after))
eec82323
LMI		 2182 (previous (char-after (- (point) 2))))
2183 ;; We do the boldification/underlining by hiding the
2184 ;; overstrikes and putting the proper text property
2185 ;; on the letters.
2186 (cond
2187 ((eq next previous)
2188 (gnus-article-hide-text-type (- (point) 2) (point) 'overstrike)
2189 (put-text-property (point) (1+ (point)) 'face 'bold))
2190 ((eq next ?_)
2191 (gnus-article-hide-text-type
2192 (1- (point)) (1+ (point)) 'overstrike)
2193 (put-text-property
2194 (- (point) 2) (1- (point)) 'face 'underline))
2195 ((eq previous ?_)
2196 (gnus-article-hide-text-type (- (point) 2) (point) 'overstrike)
2197 (put-text-property
2198 (point) (1+ (point)) 'face 'underline)))))))))
2199
01c52d31
MB		 2200(defun article-treat-ansi-sequences ()
2201 "Translate ANSI SGR control sequences into overlays or extents."
2202 (interactive)
2203 (save-excursion
2204 (when (article-goto-body)
2205 (let ((inhibit-read-only t))
2206 (ansi-color-apply-on-region (point) (point-max))))))
2207
23f87bed
MB		 2208(defun gnus-article-treat-unfold-headers ()
2209 "Unfold folded message headers.
2210Only the headers that fit into the current window width will be
2211unfolded."
2212 (interactive)
2213 (gnus-with-article-headers
2214 (let (length)
2215 (while (not (eobp))
2216 (save-restriction
2217 (mail-header-narrow-to-field)
01c52d31
MB		 2218 (let* ((header (buffer-string))
2219 (unfoldable
2220 (or (equal gnus-article-unfold-long-headers t)
2221 (and (stringp gnus-article-unfold-long-headers)
2222 (string-match gnus-article-unfold-long-headers header)))))
23f87bed
MB		 2223 (with-temp-buffer
2224 (insert header)
2225 (goto-char (point-min))
2226 (while (re-search-forward "\n[\t ]" nil t)
2227 (replace-match " " t t)))
01c52d31
MB		 2228 (setq length (- (point-max) (point-min) 1))
2229 (when (or unfoldable
2230 (< length (window-width)))
2231 (while (re-search-forward "\n[\t ]" nil t)
2232 (replace-match " " t t))))
23f87bed
MB		 2233 (goto-char (point-max)))))))
2234
2235(defun gnus-article-treat-fold-headers ()
2236 "Fold message headers."
2237 (interactive)
2238 (gnus-with-article-headers
2239 (while (not (eobp))
2240 (save-restriction
2241 (mail-header-narrow-to-field)
2242 (mail-header-fold-field)
2243 (goto-char (point-max))))))
2244
2245(defun gnus-treat-smiley ()
2246 "Toggle display of textual emoticons (\"smileys\") as small graphical icons."
2247 (interactive)
2248 (gnus-with-article-buffer
2249 (if (memq 'smiley gnus-article-wash-types)
2250 (gnus-delete-images 'smiley)
2251 (article-goto-body)
2252 (let ((images (smiley-region (point) (point-max))))
2253 (when images
2254 (gnus-add-wash-type 'smiley)
2255 (dolist (image images)
2256 (gnus-add-image 'smiley image)))))))
2257
2258(defun gnus-article-remove-images ()
2259 "Remove all images from the article buffer."
2260 (interactive)
2261 (gnus-with-article-buffer
9695908d
KY		 2262 (save-restriction
2263 (widen)
2264 (dolist (elem gnus-article-image-alist)
2265 (gnus-delete-images (car elem))))))
23f87bed 2266
8b6f6573
LMI		 2267(defun gnus-article-show-images ()
2268 "Show any images that are in the HTML-rendered article buffer.
2269This only works if the article in question is HTML."
2270 (interactive)
2271 (gnus-with-article-buffer
9695908d
KY		 2272 (save-restriction
2273 (widen)
2274 (dolist (region (gnus-find-text-property-region (point-min) (point-max)
2275 'image-displayer))
2276 (destructuring-bind (start end function) region
2277 (funcall function (get-text-property start 'image-url)
2278 start end))))))
8b6f6573 2279
23f87bed
MB		 2280(defun gnus-article-treat-fold-newsgroups ()
2281 "Unfold folded message headers.
2282Only the headers that fit into the current window width will be
2283unfolded."
2284 (interactive)
2285 (gnus-with-article-headers
2286 (while (gnus-article-goto-header "newsgroups\\|followup-to")
2287 (save-restriction
2288 (mail-header-narrow-to-field)
2289 (while (re-search-forward ", *" nil t)
2290 (replace-match ", " t t))
2291 (mail-header-fold-field)
2292 (goto-char (point-max))))))
2293
b7b80032 2294(defcustom gnus-article-truncate-lines (default-value 'truncate-lines)
01c52d31
MB		 2295 "Value of `truncate-lines' in Gnus Article buffer.
2296Valid values are nil, t, `head', `first', `last', an integer or a
2297predicate. See Info node `(gnus)Customizing Articles'."
330f707b 2298 :version "23.1" ;; No Gnus
01c52d31
MB		 2299 :group 'gnus-article
2300 ;; :link '(custom-manual "(gnus)Customizing Articles")
2301 :type 'boolean)
2302
2303(defun gnus-article-toggle-truncate-lines (&optional arg)
2304 "Toggle whether to fold or truncate long lines in article the buffer.
2305If ARG is non-nil and not a number, toggle
2306`gnus-article-truncate-lines' too. If ARG is a number, truncate
5229211e 2307long lines if and only if arg is positive."
01c52d31
MB		 2308 (interactive "P")
2309 (cond
2310 ((and (numberp arg) (> arg 0))
2311 (setq gnus-article-truncate-lines t))
2312 ((numberp arg)
2313 (setq gnus-article-truncate-lines nil))
2314 (arg
2315 (setq gnus-article-truncate-lines
2316 (not gnus-article-truncate-lines))))
2317 (gnus-with-article-buffer
2318 (cond
2319 ((and (numberp arg) (> arg 0))
2320 (setq truncate-lines nil))
2321 ((numberp arg)
2322 (setq truncate-lines t)))
2323 ;; In versions of Emacs 22 (CVS) before 2006-05-26,
2324 ;; `toggle-truncate-lines' needs an argument.
2325 (toggle-truncate-lines)))
2326
23f87bed
MB		 2327(defun gnus-article-treat-body-boundary ()
2328 "Place a boundary line at the end of the headers."
2329 (interactive)
2330 (when (and gnus-body-boundary-delimiter
2331 (> (length gnus-body-boundary-delimiter) 0))
2332 (gnus-with-article-headers
2333 (goto-char (point-max))
2334 (let ((start (point)))
2335 (insert "X-Boundary: ")
2336 (gnus-add-text-properties start (point) '(invisible t intangible t))
2337 (insert (let (str)
4478e074 2338 (while (>= (window-width) (length str))
23f87bed 2339 (setq str (concat str gnus-body-boundary-delimiter)))
4478e074 2340 (substring str 0 (window-width)))
23f87bed
MB		 2341 "\n")
2342 (gnus-put-text-property start (point) 'gnus-decoration 'header)))))
2343
16409b0b
GM		 2344(defun article-fill-long-lines ()
2345 "Fill lines that are wider than the window width."
eec82323
LMI		 2346 (interactive)
2347 (save-excursion
4e7d0221 2348 (let ((inhibit-read-only t)
16409b0b
GM		 2349 (width (window-width (get-buffer-window (current-buffer)))))
2350 (save-restriction
2351 (article-goto-body)
80b47379 2352 (let ((adaptive-fill-mode nil)) ;Why? -sm
16409b0b
GM		 2353 (while (not (eobp))
2354 (end-of-line)
2355 (when (>= (current-column) (min fill-column width))
23f87bed 2356 (narrow-to-region (min (1+ (point)) (point-max))
01c52d31 2357 (point-at-bol))
23f87bed
MB		 2358 (let ((goback (point-marker)))
2359 (fill-paragraph nil)
2360 (goto-char (marker-position goback)))
16409b0b
GM		 2361 (widen))
2362 (forward-line 1)))))))
2363
2364(defun article-capitalize-sentences ()
2365 "Capitalize the first word in each sentence."
2366 (interactive)
2367 (save-excursion
4e7d0221 2368 (let ((inhibit-read-only t)
16409b0b
GM		 2369 (paragraph-start "^[\n\^L]"))
2370 (article-goto-body)
2371 (while (not (eobp))
2372 (capitalize-word 1)
2373 (forward-sentence)))))
eec82323
LMI		 2374
2375(defun article-remove-cr ()
16409b0b 2376 "Remove trailing CRs and then translate remaining CRs into LFs."
eec82323
LMI		 2377 (interactive)
2378 (save-excursion
4e7d0221 2379 (let ((inhibit-read-only t))
eec82323 2380 (goto-char (point-min))
16409b0b
GM		 2381 (while (re-search-forward "\r+$" nil t)
2382 (replace-match "" t t))
2383 (goto-char (point-min))
eec82323 2384 (while (search-forward "\r" nil t)
16409b0b 2385 (replace-match "\n" t t)))))
eec82323
LMI		 2386
2387(defun article-remove-trailing-blank-lines ()
2388 "Remove all trailing blank lines from the article."
2389 (interactive)
2390 (save-excursion
4e7d0221 2391 (let ((inhibit-read-only t))
eec82323
LMI		 2392 (goto-char (point-max))
2393 (delete-region
2394 (point)
2395 (progn
2396 (while (and (not (bobp))
16409b0b
GM		 2397 (looking-at "^[ \t]*$")
2398 (not (gnus-annotation-in-region-p
01c52d31 2399 (point) (point-at-eol))))
eec82323
LMI		 2400 (forward-line -1))
2401 (forward-line 1)
2402 (point))))))
2403
9efa445f 2404(defvar gnus-face-properties-alist)
01c52d31 2405
b890d447 2406(defun article-display-face (&optional force)
23f87bed 2407 "Display any Face headers in the header."
b890d447 2408 (interactive (list 'force))
23f87bed
MB		 2409 (let ((wash-face-p buffer-read-only))
2410 (gnus-with-article-headers
2411 ;; When displaying parts, this function can be called several times on
2412 ;; the same article, without any intended toggle semantic (as typing `W
2413 ;; D d' would have). So face deletion must occur only when we come from
2414 ;; an interactive command, that is when the *Article* buffer is
2415 ;; read-only.
2416 (if (and wash-face-p (memq 'face gnus-article-wash-types))
2417 (gnus-delete-images 'face)
b890d447
MB		 2418 (let ((from (message-fetch-field "from"))
2419 face faces)
7d0c69be 2420 (save-current-buffer
23f87bed 2421 (when (and wash-face-p
7d0c69be
MB		 2422 (gnus-buffer-live-p gnus-original-article-buffer)
2423 (not (re-search-forward "^Face:[\t ]*" nil t)))
23f87bed
MB		 2424 (set-buffer gnus-original-article-buffer))
2425 (save-restriction
2426 (mail-narrow-to-head)
b890d447
MB		 2427 (when (or force
2428 ;; Check whether this face is censored.
2429 (not (and gnus-article-x-face-too-ugly
2430 (or from
2431 (setq from (message-fetch-field "from")))
2432 (string-match gnus-article-x-face-too-ugly
2433 from))))
2434 (while (gnus-article-goto-header "Face")
2435 (push (mail-header-field-value) faces)))))
d6697c02 2436 (when faces
7d0c69be 2437 (goto-char (point-min))
b890d447
MB		 2438 (let (png image)
2439 (unless (setq from (gnus-article-goto-header "from"))
7d0c69be
MB		 2440 (insert "From:")
2441 (setq from (point))
b890d447 2442 (insert " [no `from' set]\n"))
7d0c69be
MB		 2443 (while faces
2444 (when (setq png (gnus-convert-face-to-png (pop faces)))
01c52d31
MB		 2445 (setq image
2446 (apply 'gnus-create-image png 'png t
2447 (cdr (assq 'png gnus-face-properties-alist))))
d6697c02
MB		 2448 (goto-char from)
2449 (gnus-add-wash-type 'face)
2450 (gnus-add-image 'face image)
2451 (gnus-put-image image nil 'face))))))))))
23f87bed 2452
eec82323
LMI		 2453(defun article-display-x-face (&optional force)
2454 "Look for an X-Face header and display it if present."
2455 (interactive (list 'force))
23f87bed
MB		 2456 (let ((wash-face-p buffer-read-only)) ;; When type `W f'
2457 (gnus-with-article-headers
2458 ;; Delete the old process, if any.
2459 (when (process-status "article-x-face")
2460 (delete-process "article-x-face"))
2461 ;; See the comment in `article-display-face'.
2462 (if (and wash-face-p (memq 'xface gnus-article-wash-types))
2463 ;; We have already displayed X-Faces, so we remove them
2464 ;; instead.
2465 (gnus-delete-images 'xface)
2466 ;; Display X-Faces.
b890d447
MB		 2467 (let ((from (message-fetch-field "from"))
2468 x-faces face)
7d0c69be 2469 (save-current-buffer
23f87bed 2470 (when (and wash-face-p
7d0c69be
MB		 2471 (gnus-buffer-live-p gnus-original-article-buffer)
2472 (not (re-search-forward "^X-Face:[\t ]*" nil t)))
23f87bed
MB		 2473 ;; If type `W f', use gnus-original-article-buffer,
2474 ;; otherwise use the current buffer because displaying
2475 ;; RFC822 parts calls this function too.
2476 (set-buffer gnus-original-article-buffer))
2477 (save-restriction
2478 (mail-narrow-to-head)
b890d447
MB		 2479 (and gnus-article-x-face-command
2480 (or force
2481 ;; Check whether this face is censored.
2482 (not (and gnus-article-x-face-too-ugly
2483 (or from
2484 (setq from (message-fetch-field "from")))
2485 (string-match gnus-article-x-face-too-ugly
2486 from))))
2487 (while (gnus-article-goto-header "X-Face")
2488 (push (mail-header-field-value) x-faces)))))
2489 (when x-faces
2490 ;; We display the face.
2491 (cond ((functionp gnus-article-x-face-command)
2492 ;; The command is a lisp function, so we call it.
2493 (mapc gnus-article-x-face-command x-faces))
2494 ((stringp gnus-article-x-face-command)
2495 ;; The command is a string, so we interpret the command
2496 ;; as a, well, command, and fork it off.
2497 (let ((process-connection-type nil))
2498 (gnus-set-process-query-on-exit-flag
2499 (start-process
2500 "article-x-face" nil shell-file-name
2501 shell-command-switch gnus-article-x-face-command)
2502 nil)
2503 ;; Sending multiple EOFs to xv doesn't work,
2504 ;; so we only do a single external face.
2505 (with-temp-buffer
2506 (insert (car x-faces))
2507 (process-send-region "article-x-face"
2508 (point-min) (point-max)))
2509 (process-send-eof "article-x-face")))
2510 (t
2511 (error "`%s' set to `%s' is not a function"
2512 gnus-article-x-face-command
2513 'gnus-article-x-face-command)))))))))
a8151ef7 2514
16409b0b
GM		 2515(defun article-decode-mime-words ()
2516 "Decode all MIME-encoded words in the article."
2517 (interactive)
01c52d31 2518 (gnus-with-article-buffer
16409b0b 2519 (let ((inhibit-point-motion-hooks t)
16409b0b 2520 (mail-parse-charset gnus-newsgroup-charset)
a1506d29 2521 (mail-parse-ignored-charsets
01c52d31
MB		 2522 (with-current-buffer gnus-summary-buffer
2523 gnus-newsgroup-ignored-charsets)))
16409b0b
GM		 2524 (mail-decode-encoded-word-region (point-min) (point-max)))))
2525
2526(defun article-decode-charset (&optional prompt)
2527 "Decode charset-encoded text in the article.
2528If PROMPT (the prefix), prompt for a coding system to use."
2529 (interactive "P")
2530 (let ((inhibit-point-motion-hooks t) (case-fold-search t)
23f87bed 2531 (inhibit-read-only t)
16409b0b 2532 (mail-parse-charset gnus-newsgroup-charset)
a1506d29 2533 (mail-parse-ignored-charsets
16409b0b
GM		 2534 (save-excursion (condition-case nil
2535 (set-buffer gnus-summary-buffer)
2536 (error))
2537 gnus-newsgroup-ignored-charsets))
2538 ct cte ctl charset format)
c96ec15a
MB		 2539 (save-excursion
2540 (save-restriction
2541 (article-narrow-to-head)
2542 (setq ct (message-fetch-field "Content-Type" t)
2543 cte (message-fetch-field "Content-Transfer-Encoding" t)
2544 ctl (and ct (mail-header-parse-content-type ct))
2545 charset (cond
2546 (prompt
2547 (mm-read-coding-system "Charset to decode: "))
2548 (ctl
2549 (mail-content-type-get ctl 'charset)))
2550 format (and ctl (mail-content-type-get ctl 'format)))
2551 (when cte
2552 (setq cte (mail-header-strip cte)))
2553 (if (and ctl (not (string-match "/" (car ctl))))
2554 (setq ctl nil))
2555 (goto-char (point-max)))
2556 (forward-line 1)
2557 (save-restriction
2558 (narrow-to-region (point) (point-max))
2559 (when (and (eq mail-parse-charset 'gnus-decoded)
2560 (eq (mm-body-7-or-8) '8bit))
2561 ;; The text code could have been decoded.
2562 (setq charset mail-parse-charset))
2563 (when (and (or (not ctl)
2564 (equal (car ctl) "text/plain"))
2565 (not format)) ;; article with format will decode later.
2566 (mm-decode-body
2567 charset (and cte (intern (downcase
2568 (gnus-strip-whitespace cte))))
2569 (car ctl)))))))
16409b0b
GM		 2570
2571(defun article-decode-encoded-words ()
2572 "Remove encoded-word encoding from headers."
2573 (let ((inhibit-point-motion-hooks t)
2574 (mail-parse-charset gnus-newsgroup-charset)
a1506d29 2575 (mail-parse-ignored-charsets
16409b0b
GM		 2576 (save-excursion (condition-case nil
2577 (set-buffer gnus-summary-buffer)
2578 (error))
2579 gnus-newsgroup-ignored-charsets))
343d6628 2580 (inhibit-read-only t)
8fbdffe5
MB		 2581 end start)
2582 (goto-char (point-min))
2583 (when (search-forward "\n\n" nil 'move)
2584 (forward-line -1))
2585 (setq end (point))
2586 (while (not (bobp))
2587 (while (progn
2588 (forward-line -1)
2589 (and (not (bobp))
2590 (memq (char-after) '(?\t ? )))))
2591 (setq start (point))
2592 (if (looking-at "\
343d6628
MB		 2593\\(?:Resent-\\)?\\(?:From\\|Cc\\|To\\|Bcc\\|\\(?:In-\\)?Reply-To\\|Sender\
2594\\|Mail-Followup-To\\|Mail-Copies-To\\|Approved\\):")
8fbdffe5
MB		 2595 (funcall gnus-decode-address-function start end)
2596 (funcall gnus-decode-header-function start end))
2597 (goto-char (setq end start)))))
eec82323 2598
23f87bed 2599(defun article-decode-group-name ()
01c52d31 2600 "Decode group names in Newsgroups, Followup-To and Xref headers."
23f87bed
MB		 2601 (let ((inhibit-point-motion-hooks t)
2602 (inhibit-read-only t)
01c52d31
MB		 2603 (method (gnus-find-method-for-group gnus-newsgroup-name))
2604 regexp)
23f87bed
MB		 2605 (when (and (or gnus-group-name-charset-method-alist
2606 gnus-group-name-charset-group-alist)
2607 (gnus-buffer-live-p gnus-original-article-buffer))
2608 (save-restriction
2609 (article-narrow-to-head)
01c52d31
MB		 2610 (dolist (header '("Newsgroups" "Followup-To" "Xref"))
2611 (with-current-buffer gnus-original-article-buffer
2612 (goto-char (point-min)))
2613 (setq regexp (concat "^" header
2614 ":\\([^\n]*\\(?:\n[\t ]+[^\n]+\\)*\\)\n"))
2615 (while (re-search-forward regexp nil t)
2616 (replace-match (save-match-data
2617 (gnus-decode-newsgroups
2618 ;; XXX how to use data in article buffer?
2619 (with-current-buffer gnus-original-article-buffer
2620 (re-search-forward regexp nil t)
2621 (match-string 1))
2622 gnus-newsgroup-name method))
2623 t t nil 1))
2624 (goto-char (point-min)))))))
23f87bed
MB		 2625
2626(autoload 'idna-to-unicode "idna")
2627
2628(defun article-decode-idna-rhs ()
53cfefc8
MB		 2629 "Decode IDNA strings in RHS in various headers in current buffer.
2630The following headers are decoded: From:, To:, Cc:, Reply-To:,
2631Mail-Reply-To: and Mail-Followup-To:."
23f87bed
MB		 2632 (when gnus-use-idna
2633 (save-restriction
2634 (let ((inhibit-point-motion-hooks t)
2635 (inhibit-read-only t))
2636 (article-narrow-to-head)
2637 (goto-char (point-min))
53cfefc8 2638 (while (re-search-forward "@[^ \t\n\r,>]*\\(xn--[-A-Za-z0-9.]*\\)[ \t\n\r,>]" nil t)
23f87bed
MB		 2639 (let (ace unicode)
2640 (when (save-match-data
2641 (and (setq ace (match-string 1))
2642 (save-excursion
2643 (and (re-search-backward "^[^ \t]" nil t)
53cfefc8 2644 (looking-at "From\\|To\\|Cc\\|Reply-To\\|Mail-Reply-To\\|Mail-Followup-To")))
23f87bed
MB		 2645 (setq unicode (idna-to-unicode ace))))
2646 (unless (string= ace unicode)
2647 (replace-match unicode nil nil nil 1)))))))))
2648
2649(defun article-de-quoted-unreadable (&optional force read-charset)
16409b0b 2650 "Translate a quoted-printable-encoded article.
eec82323 2651If FORCE, decode the article whether it is marked as quoted-printable
23f87bed
MB		 2652or not.
2653If READ-CHARSET, ask for a coding system."
2654 (interactive (list 'force current-prefix-arg))
eec82323 2655 (save-excursion
4e7d0221 2656 (let ((inhibit-read-only t) type charset)
8b93df01
DL		 2657 (if (gnus-buffer-live-p gnus-original-article-buffer)
2658 (with-current-buffer gnus-original-article-buffer
2659 (setq type
2660 (gnus-fetch-field "content-transfer-encoding"))
2661 (let* ((ct (gnus-fetch-field "content-type"))
c96ec15a 2662 (ctl (and ct (mail-header-parse-content-type ct))))
8b93df01
DL		 2663 (setq charset (and ctl
2664 (mail-content-type-get ctl 'charset)))
2665 (if (stringp charset)
2666 (setq charset (intern (downcase charset)))))))
23f87bed
MB		 2667 (if read-charset
2668 (setq charset (mm-read-coding-system "Charset: " charset)))
a1506d29 2669 (unless charset
8b93df01 2670 (setq charset gnus-newsgroup-charset))
eec82323 2671 (when (or force
eb806ef3
DL		 2672 (and type (let ((case-fold-search t))
2673 (string-match "quoted-printable" type))))
16409b0b 2674 (article-goto-body)
eb806ef3
DL		 2675 (quoted-printable-decode-region
2676 (point) (point-max) (mm-charset-to-coding-system charset))))))
16409b0b 2677
23f87bed 2678(defun article-de-base64-unreadable (&optional force read-charset)
16409b0b 2679 "Translate a base64 article.
23f87bed
MB		 2680If FORCE, decode the article whether it is marked as base64 not.
2681If READ-CHARSET, ask for a coding system."
2682 (interactive (list 'force current-prefix-arg))
16409b0b 2683 (save-excursion
4e7d0221 2684 (let ((inhibit-read-only t) type charset)
8b93df01
DL		 2685 (if (gnus-buffer-live-p gnus-original-article-buffer)
2686 (with-current-buffer gnus-original-article-buffer
2687 (setq type
2688 (gnus-fetch-field "content-transfer-encoding"))
2689 (let* ((ct (gnus-fetch-field "content-type"))
c96ec15a 2690 (ctl (and ct (mail-header-parse-content-type ct))))
8b93df01
DL		 2691 (setq charset (and ctl
2692 (mail-content-type-get ctl 'charset)))
2693 (if (stringp charset)
2694 (setq charset (intern (downcase charset)))))))
23f87bed
MB		 2695 (if read-charset
2696 (setq charset (mm-read-coding-system "Charset: " charset)))
a1506d29 2697 (unless charset
8b93df01 2698 (setq charset gnus-newsgroup-charset))
16409b0b 2699 (when (or force
eb806ef3
DL		 2700 (and type (let ((case-fold-search t))
2701 (string-match "base64" type))))
16409b0b
GM		 2702 (article-goto-body)
2703 (save-restriction
2704 (narrow-to-region (point) (point-max))
2705 (base64-decode-region (point-min) (point-max))
eb806ef3
DL		 2706 (mm-decode-coding-region
2707 (point-min) (point-max) (mm-charset-to-coding-system charset)))))))
16409b0b
GM		 2708
2709(eval-when-compile
2710 (require 'rfc1843))
2711
2712(defun article-decode-HZ ()
2713 "Translate a HZ-encoded article."
2714 (interactive)
2715 (require 'rfc1843)
2716 (save-excursion
4e7d0221 2717 (let ((inhibit-read-only t))
16409b0b
GM		 2718 (rfc1843-decode-region (point-min) (point-max)))))
2719
23f87bed
MB		 2720(defun article-unsplit-urls ()
2721 "Remove the newlines that some other mailers insert into URLs."
16409b0b 2722 (interactive)
23f87bed
MB		 2723 (save-excursion
2724 (let ((inhibit-read-only t))
2725 (goto-char (point-min))
2726 (while (re-search-forward
97f78c9b 2727 "\\(\\(https?\\|ftp\\)://\\S-+\\) *\n\\(\\S-+\\)" nil t)
23f87bed
MB		 2728 (replace-match "\\1\\3" t)))
2729 (when (interactive-p)
2730 (gnus-treat-article nil))))
2731
2526f423
G		 2732(defun article-wash-html ()
2733 "Format an HTML article."
2734 (interactive)
2735 (let ((handles nil)
2736 (buffer-read-only nil))
2737 (when (gnus-buffer-live-p gnus-original-article-buffer)
2738 (setq handles (mm-dissect-buffer t t)))
2739 (article-goto-body)
2740 (delete-region (point) (point-max))
2741 (mm-inline-text-html handles)))
73043f7d 2742
01c52d31
MB		 2743(defvar gnus-article-browse-html-temp-list nil
2744 "List of temporary files created by `gnus-article-browse-html-parts'.
2745Internal variable.")
2746
2747(defcustom gnus-article-browse-delete-temp 'ask
2748 "What to do with temporary files from `gnus-article-browse-html-parts'.
2749If nil, don't delete temporary files. If it is t, delete them on
2750exit from the summary buffer. If it is the symbol `file', query
2751on each file, if it is `ask' ask once when exiting from the
2752summary buffer."
2753 :group 'gnus-article
330f707b 2754 :version "23.1" ;; No Gnus
01c52d31
MB		 2755 :type '(choice (const :tag "Don't delete" nil)
2756 (const :tag "Don't ask" t)
2757 (const :tag "Ask" ask)
2758 (const :tag "Ask for each file" file)))
2759
2760;; Cf. mm-postponed-undisplay-list / mm-destroy-postponed-undisplay-list.
2761
2762(defun gnus-article-browse-delete-temp-files (&optional how)
2763 "Delete temp-files created by `gnus-article-browse-html-parts'."
2764 (when (and gnus-article-browse-html-temp-list
3aeb9402
KY		 2765 (progn
2766 (or how (setq how gnus-article-browse-delete-temp))
2767 (if (eq how 'ask)
2768 (let ((files (length gnus-article-browse-html-temp-list)))
2769 (gnus-y-or-n-p (format
2770 "Delete all %s temporary HTML file%s? "
2771 files
2772 (if (> files 1) "s" ""))))
2773 how)))
01c52d31 2774 (dolist (file gnus-article-browse-html-temp-list)
3aeb9402
KY		 2775 (cond ((file-directory-p file)
2776 (when (or (not (eq how 'file))
2777 (gnus-y-or-n-p
2778 (format
2779 "Delete temporary HTML file(s) in directory `%s'? "
2780 (file-name-as-directory file))))
2781 (gnus-delete-directory file)))
2782 ((file-exists-p file)
2783 (when (or (not (eq how 'file))
2784 (gnus-y-or-n-p
2785 (format "Delete temporary HTML file `%s'? " file)))
2786 (delete-file file)))))
01c52d31
MB		 2787 ;; Also remove file from the list when not deleted or if file doesn't
2788 ;; exist anymore.
2789 (setq gnus-article-browse-html-temp-list nil))
2790 gnus-article-browse-html-temp-list)
2791
d40d713a
KY		 2792(defun gnus-article-browse-html-save-cid-content (cid handles directory)
2793 "Find CID content in HANDLES and save it in a file in DIRECTORY.
2794Return file name."
20c0b2ce 2795 (save-match-data
d40d713a
KY		 2796 (let (file type)
2797 (catch 'found
2798 (dolist (handle handles)
2799 (cond
2800 ((not (listp handle)))
2801 ((equal (mm-handle-media-supertype handle) "multipart")
2802 (when (setq file (gnus-article-browse-html-save-cid-content
2803 cid handle directory))
2804 (throw 'found file)))
2805 ((equal (concat "<" cid ">") (mm-handle-id handle))
2806 (setq file
2807 (expand-file-name
2808 (or (mail-content-type-get
2809 (mm-handle-disposition handle) 'filename)
2810 (mail-content-type-get
2811 (setq type (mm-handle-type handle)) 'name)
2812 (concat
2813 (make-temp-name "cid")
2814 (car (rassoc (car type) mailcap-mime-extensions))))
2815 directory))
2816 (mm-save-part-to-file handle file)
2817 (throw 'found file))))))))
20c0b2ce 2818
87035689 2819(defun gnus-article-browse-html-parts (list &optional header)
01c52d31 2820 "View all \"text/html\" parts from LIST.
87035689
MB		 2821Recurse into multiparts. The optional HEADER that should be a decoded
2822message header will be added to the bodies of the \"text/html\" parts."
01c52d31 2823 ;; Internal function used by `gnus-article-browse-html-article'.
d40d713a 2824 (let (type file charset content cid-dir tmp-file showed)
01c52d31
MB		 2825 ;; Find and show the html-parts.
2826 (dolist (handle list)
2827 ;; If HTML, show it:
bbbe940b
MB		 2828 (cond ((not (listp handle)))
2829 ((or (equal (car (setq type (mm-handle-type handle))) "text/html")
2830 (and (equal (car type) "message/external-body")
87035689
MB		 2831 (or header
2832 (setq file (or (mail-content-type-get type 'name)
2833 (mail-content-type-get
2834 (mm-handle-disposition handle)
2835 'filename))))
bbbe940b
MB		 2836 (or (mm-handle-cache handle)
2837 (condition-case code
2838 (progn (mm-extern-cache-contents handle) t)
2839 (error
2840 (gnus-message 3 "%s" (error-message-string code))
2841 (when (>= gnus-verbose 3) (sit-for 2))
2842 nil)))
2843 (progn
2844 (setq handle (mm-handle-cache handle)
2845 type (mm-handle-type handle))
2846 (equal (car type) "text/html"))))
d40d713a
KY		 2847 (setq charset (mail-content-type-get type 'charset)
2848 content (mm-get-part handle))
2849 (with-temp-buffer
2850 (if (eq charset 'gnus-decoded)
2851 (mm-enable-multibyte)
2852 (mm-disable-multibyte))
2853 (insert content)
2854 ;; resolve cid contents
2855 (let ((case-fold-search t)
2856 cid-file)
2857 (goto-char (point-min))
2858 (while (re-search-forward "\
2859<img[\t\n ]+\\(?:[^\t\n >]+[\t\n ]+\\)*src=\"\\(cid:\\([^\"]+\\)\\)\""
2860 nil t)
2861 (unless cid-dir
765d4319 2862 (setq cid-dir (mm-make-temp-file "cid" t))
d40d713a
KY		 2863 (add-to-list 'gnus-article-browse-html-temp-list cid-dir))
2864 (setq file nil
2865 content nil)
2866 (when (setq cid-file
2867 (gnus-article-browse-html-save-cid-content
2868 (match-string 2)
2869 (with-current-buffer gnus-article-buffer
2870 gnus-article-mime-handles)
2871 cid-dir))
2872 (replace-match (concat "file://" cid-file)
2873 nil nil nil 1))))
2874 (unless content (setq content (buffer-string))))
2875 (when (or charset header (not file))
bbbe940b
MB		 2876 (setq tmp-file (mm-make-temp-file
2877 ;; Do we need to care for 8.3 filenames?
2878 "mm-" nil ".html")))
87035689
MB		 2879 ;; Add a meta html tag to specify charset and a header.
2880 (cond
2881 (header
d40d713a 2882 (let (title eheader body hcharset coding force-charset)
87035689
MB		 2883 (with-temp-buffer
2884 (mm-enable-multibyte)
2885 (setq case-fold-search t)
2886 (insert header "\n")
2887 (setq title (message-fetch-field "subject"))
2888 (goto-char (point-min))
2889 (while (re-search-forward "\\(<\\)\\|\\(>\\)\\|&" nil t)
2890 (replace-match (cond ((match-beginning 1) "&lt;")
2891 ((match-beginning 2) "&gt;")
2892 (t "&amp;"))))
2893 (goto-char (point-min))
2894 (insert "<pre>\n")
2895 (goto-char (point-max))
2896 (insert "</pre>\n<hr>\n")
2897 ;; We have to examine charset one by one since
2898 ;; charset specified in parts might be different.
2899 (if (eq charset 'gnus-decoded)
2900 (setq charset 'utf-8
2901 eheader (mm-encode-coding-string (buffer-string)
2902 charset)
2903 title (when title
2904 (mm-encode-coding-string title charset))
d40d713a 2905 body (mm-encode-coding-string content charset)
82fc7980 2906 force-charset t)
87035689
MB		 2907 (setq hcharset (mm-find-mime-charset-region (point-min)
2908 (point-max)))
2909 (cond ((= (length hcharset) 1)
2910 (setq hcharset (car hcharset)
2911 coding (mm-charset-to-coding-system
2912 hcharset)))
2913 ((> (length hcharset) 1)
2914 (setq hcharset 'utf-8
2915 coding hcharset)))
2916 (if coding
2917 (if charset
2918 (progn
2919 (setq body
2920 (mm-charset-to-coding-system charset))
2921 (if (eq coding body)
2922 (setq eheader (mm-encode-coding-string
2923 (buffer-string) coding)
2924 title (when title
2925 (mm-encode-coding-string
2926 title coding))
d40d713a 2927 body content)
87035689
MB		 2928 (setq charset 'utf-8
2929 eheader (mm-encode-coding-string
2930 (buffer-string) charset)
2931 title (when title
2932 (mm-encode-coding-string
2933 title charset))
2934 body (mm-encode-coding-string
2935 (mm-decode-coding-string
d40d713a 2936 content body)
82fc7980
KY		 2937 charset)
2938 force-charset t)))
87035689
MB		 2939 (setq charset hcharset
2940 eheader (mm-encode-coding-string
2941 (buffer-string) coding)
2942 title (when title
2943 (mm-encode-coding-string
2944 title coding))
d40d713a 2945 body content))
87035689 2946 (setq eheader (mm-string-as-unibyte (buffer-string))
d40d713a 2947 body content)))
87035689
MB		 2948 (erase-buffer)
2949 (mm-disable-multibyte)
2950 (insert body)
2951 (when charset
82fc7980 2952 (mm-add-meta-html-tag handle charset force-charset))
87035689
MB		 2953 (when title
2954 (goto-char (point-min))
2955 (unless (search-forward "<title>" nil t)
2956 (re-search-forward "<head>\\s-*" nil t)
2957 (insert "<title>" title "</title>\n")))
2958 (goto-char (point-min))
2959 (or (re-search-forward
2960 "<body\\(?:\\s-+[^>]+\\|\\s-*\\)>\\s-*" nil t)
2961 (re-search-forward
2962 "</head\\(?:\\s-+[^>]+\\|\\s-*\\)>\\s-*" nil t))
2963 (insert eheader)
2964 (mm-write-region (point-min) (point-max)
2965 tmp-file nil nil nil 'binary t))))
2966 (charset
2967 (mm-with-unibyte-buffer
2968 (insert (if (eq charset 'gnus-decoded)
d40d713a
KY		 2969 (mm-encode-coding-string content
2970 (setq charset 'utf-8))
2971 content))
87035689
MB		 2972 (if (or (mm-add-meta-html-tag handle charset)
2973 (not file))
2974 (mm-write-region (point-min) (point-max)
2975 tmp-file nil nil nil 'binary t)
2976 (setq tmp-file nil))))
2977 (tmp-file
2978 (mm-save-part-to-file handle tmp-file)))
bbbe940b
MB		 2979 (when tmp-file
2980 (add-to-list 'gnus-article-browse-html-temp-list tmp-file))
2981 (add-hook 'gnus-summary-prepare-exit-hook
2982 'gnus-article-browse-delete-temp-files)
2983 (add-hook 'gnus-exit-gnus-hook
2984 (lambda ()
2985 (gnus-article-browse-delete-temp-files t)))
2986 ;; FIXME: Warn if there's an <img> tag?
2987 (browse-url-of-file (or tmp-file (expand-file-name file)))
2988 (setq showed t))
2989 ;; If multipart, recurse
87035689
MB		 2990 ((equal (mm-handle-media-supertype handle) "multipart")
2991 (when (gnus-article-browse-html-parts handle header)
2992 (setq showed t)))
2993 ((equal (mm-handle-media-type handle) "message/rfc822")
2994 (mm-with-multibyte-buffer
2995 (mm-insert-part handle)
2996 (setq handle (mm-dissect-buffer t t))
2997 (when (and (bufferp (car handle))
2998 (stringp (car (mm-handle-type handle))))
2999 (setq handle (list handle)))
3000 (when header
3001 (article-decode-encoded-words)
3002 (let ((gnus-visible-headers
3003 (or (get 'gnus-visible-headers 'standard-value)
3004 gnus-visible-headers)))
3005 (article-hide-headers))
3006 (goto-char (point-min))
3007 (search-forward "\n\n" nil 'move)
3008 (skip-chars-backward "\t\n ")
3009 (setq header (buffer-substring (point-min) (point)))))
3010 (when (prog1
3011 (gnus-article-browse-html-parts handle header)
3012 (mm-destroy-parts handle))
3013 (setq showed t)))))
01c52d31
MB		 3014 showed))
3015
87035689 3016(defun gnus-article-browse-html-article (&optional arg)
01c52d31 3017 "View \"text/html\" parts of the current article with a WWW browser.
d40d713a
KY		 3018Inline images embedded in a message using the cid scheme, as they are
3019generally considered to be safe, will be processed properly.
87035689
MB		 3020The message header is added to the beginning of every html part unless
3021the prefix argument ARG is given.
01c52d31 3022
d40d713a
KY		 3023Warning: Spammers use links to images (using the http scheme) in HTML
3024articles to verify whether you have read the message. As
9b3ebcb6
MB		 3025`gnus-article-browse-html-article' passes the HTML content to the
3026browser without eliminating these \"web bugs\" you should only
3027use it for mails from trusted senders.
b890d447 3028
9b3ebcb6 3029If you always want to display HTML parts in the browser, set
d40d713a
KY		 3030`mm-text-html-renderer' to nil.
3031
3032This command creates temporary files to pass HTML contents including
3033images if any to the browser, and deletes them when exiting the group
3034\(if you want)."
01c52d31 3035 ;; Cf. `mm-w3m-safe-url-regexp'
87035689
MB		 3036 (interactive "P")
3037 (if arg
3038 (gnus-summary-show-article)
3039 (let ((gnus-visible-headers (or (get 'gnus-visible-headers 'standard-value)
9b3ebcb6
MB		 3040 gnus-visible-headers))
3041 ;; As we insert a <hr>, there's no need for the body boundary.
3042 (gnus-treat-body-boundary nil))
87035689
MB		 3043 (gnus-summary-show-article)))
3044 (with-current-buffer gnus-article-buffer
3045 (let ((header (unless arg
3046 (save-restriction
3047 (widen)
3048 (buffer-substring-no-properties
3049 (goto-char (point-min))
3050 (if (search-forward "\n\n" nil t)
3051 (match-beginning 0)
3052 (goto-char (point-max))
3053 (skip-chars-backward "\t\n ")
3054 (point))))))
3055 parts)
3056 (set-buffer gnus-original-article-buffer)
3057 (setq parts (mm-dissect-buffer t t))
01c52d31
MB		 3058 ;; If singlepart, enforce a list.
3059 (when (and (bufferp (car parts))
3060 (stringp (car (mm-handle-type parts))))
3061 (setq parts (list parts)))
3062 ;; Process the list
87035689 3063 (unless (gnus-article-browse-html-parts parts header)
01c52d31 3064 (gnus-error 3 "Mail doesn't contain a \"text/html\" part!"))
87035689
MB		 3065 (mm-destroy-parts parts)
3066 (unless arg
3067 (gnus-summary-show-article)))))
01c52d31 3068
16409b0b
GM		 3069(defun article-hide-list-identifiers ()
3070 "Remove list identifies from the Subject header.
3071The `gnus-list-identifiers' variable specifies what to do."
3072 (interactive)
23f87bed
MB		 3073 (let ((inhibit-point-motion-hooks t)
3074 (regexp (if (consp gnus-list-identifiers)
3075 (mapconcat 'identity gnus-list-identifiers " *\\|")
3076 gnus-list-identifiers))
3077 (inhibit-read-only t))
3078 (when regexp
3079 (save-excursion
3080 (save-restriction
3081 (article-narrow-to-head)
3082 (goto-char (point-min))
3083 (while (re-search-forward
3084 (concat "^Subject: +\\(R[Ee]: +\\)*\\(" regexp " *\\)")
3085 nil t)
3086 (delete-region (match-beginning 2) (match-end 0))
3087 (beginning-of-line))
3088 (when (re-search-forward
3089 "^Subject: +\\(\\(R[Ee]: +\\)+\\)R[Ee]: +" nil t)
3090 (delete-region (match-beginning 1) (match-end 1))))))))
eec82323
LMI		 3091
3092(defun article-hide-pem (&optional arg)
3093 "Toggle hiding of any PEM headers and signatures in the current article.
3094If given a negative prefix, always show; if given a positive prefix,
3095always hide."
3096 (interactive (gnus-article-hidden-arg))
3097 (unless (gnus-article-check-hidden-text 'pem arg)
3098 (save-excursion
23f87bed 3099 (let ((inhibit-read-only t) end)
eec82323 3100 (goto-char (point-min))
16409b0b
GM		 3101 ;; Hide the horrendously ugly "header".
3102 (when (and (search-forward
3103 "\n-----BEGIN PRIVACY-ENHANCED MESSAGE-----\n"
3104 nil t)
3105 (setq end (1+ (match-beginning 0))))
23f87bed 3106 (gnus-add-wash-type 'pem)
16409b0b
GM		 3107 (gnus-article-hide-text-type
3108 end
3109 (if (search-forward "\n\n" nil t)
3110 (match-end 0)
3111 (point-max))
3112 'pem)
3113 ;; Hide the trailer as well
3114 (when (search-forward "\n-----END PRIVACY-ENHANCED MESSAGE-----\n"
3115 nil t)
3116 (gnus-article-hide-text-type
3117 (match-beginning 0) (match-end 0) 'pem)))))))
3118
3119(defun article-strip-banner ()
23f87bed
MB		 3120 "Strip the banners specified by the `banner' group parameter and by
3121`gnus-article-address-banner-alist'."
16409b0b 3122 (interactive)
23f87bed
MB		 3123 (save-excursion
3124 (save-restriction
3125 (let ((inhibit-point-motion-hooks t))
3126 (when (gnus-parameter-banner gnus-newsgroup-name)
3127 (article-really-strip-banner
3128 (gnus-parameter-banner gnus-newsgroup-name)))
3129 (when gnus-article-address-banner-alist
cf5a5c38
MB		 3130 ;; Note that the From header is decoded here, so it is
3131 ;; required that the *-extract-address-components function
3132 ;; supports non-ASCII text.
d71c0855
MB		 3133 (let ((from (save-restriction
3134 (widen)
3135 (article-narrow-to-head)
3136 (mail-fetch-field "from"))))
3137 (when (and from
3138 (setq from
3139 (cadr (funcall gnus-extract-address-components
3140 from))))
3141 (catch 'found
3142 (dolist (pair gnus-article-address-banner-alist)
3143 (when (string-match (car pair) from)
3144 (throw 'found
3145 (article-really-strip-banner (cdr pair)))))))))))))
23f87bed
MB		 3146
3147(defun article-really-strip-banner (banner)
3148 "Strip the banner specified by the argument."
16409b0b
GM		 3149 (save-excursion
3150 (save-restriction
3151 (let ((inhibit-point-motion-hooks t)
16409b0b 3152 (gnus-signature-limit nil)
23f87bed
MB		 3153 (inhibit-read-only t))
3154 (article-goto-body)
3155 (cond
3156 ((eq banner 'signature)
3157 (when (gnus-article-narrow-to-signature)
3158 (widen)
3159 (forward-line -1)
3160 (delete-region (point) (point-max))))
3161 ((symbolp banner)
3162 (if (setq banner (cdr (assq banner gnus-article-banner-alist)))
3163 (while (re-search-forward banner nil t)
3164 (delete-region (match-beginning 0) (match-end 0)))))
3165 ((stringp banner)
3166 (while (re-search-forward banner nil t)
3167 (delete-region (match-beginning 0) (match-end 0)))))))))
16409b0b
GM		 3168
3169(defun article-babel ()
3170 "Translate article using an online translation service."
3171 (interactive)
3172 (require 'babel)
01c52d31 3173 (gnus-with-article-buffer
16409b0b 3174 (when (article-goto-body)
01c52d31 3175 (let* ((start (point))
16409b0b
GM		 3176 (end (point-max))
3177 (orig (buffer-substring start end))
23f87bed 3178 (trans (babel-as-string orig)))
16409b0b
GM		 3179 (save-restriction
3180 (narrow-to-region start end)
3181 (delete-region start end)
23f87bed 3182 (insert trans))))))
eec82323
LMI		 3183
3184(defun article-hide-signature (&optional arg)
3185 "Hide the signature in the current article.
3186If given a negative prefix, always show; if given a positive prefix,
3187always hide."
3188 (interactive (gnus-article-hidden-arg))
3189 (unless (gnus-article-check-hidden-text 'signature arg)
3190 (save-excursion
3191 (save-restriction
4e7d0221 3192 (let ((inhibit-read-only t))
eec82323
LMI		 3193 (when (gnus-article-narrow-to-signature)
3194 (gnus-article-hide-text-type
23f87bed
MB		 3195 (point-min) (point-max) 'signature))))))
3196 (gnus-set-mode-line 'article))
eec82323 3197
16409b0b
GM		 3198(defun article-strip-headers-in-body ()
3199 "Strip offensive headers from bodies."
3200 (interactive)
3201 (save-excursion
3202 (article-goto-body)
3203 (let ((case-fold-search t))
3204 (when (looking-at "x-no-archive:")
3205 (gnus-delete-line)))))
3206
eec82323
LMI		 3207(defun article-strip-leading-blank-lines ()
3208 "Remove all blank lines from the beginning of the article."
3209 (interactive)
3210 (save-excursion
3211 (let ((inhibit-point-motion-hooks t)
23f87bed 3212 (inhibit-read-only t))
16409b0b 3213 (when (article-goto-body)
eec82323
LMI		 3214 (while (and (not (eobp))
3215 (looking-at "[ \t]*$"))
3216 (gnus-delete-line))))))
3217
16409b0b
GM		 3218(defun article-narrow-to-head ()
3219 "Narrow the buffer to the head of the message.
3220Point is left at the beginning of the narrowed-to region."
3221 (narrow-to-region
3222 (goto-char (point-min))
3223 (if (search-forward "\n\n" nil 1)
3224 (1- (point))
3225 (point-max)))
3226 (goto-char (point-min)))
3227
3228(defun article-goto-body ()
3229 "Place point at the start of the body."
3230 (goto-char (point-min))
3231 (cond
3232 ;; This variable is only bound when dealing with separate
3233 ;; MIME body parts.
3234 (article-goto-body-goes-to-point-min-p
3235 t)
3236 ((search-forward "\n\n" nil t)
3237 t)
3238 (t
3239 (goto-char (point-max))
3240 nil)))
3241
eec82323
LMI		 3242(defun article-strip-multiple-blank-lines ()
3243 "Replace consecutive blank lines with one empty line."
3244 (interactive)
3245 (save-excursion
3246 (let ((inhibit-point-motion-hooks t)
23f87bed 3247 (inhibit-read-only t))
eec82323 3248 ;; First make all blank lines empty.
16409b0b 3249 (article-goto-body)
eec82323 3250 (while (re-search-forward "^[ \t]+$" nil t)
16409b0b
GM		 3251 (unless (gnus-annotation-in-region-p
3252 (match-beginning 0) (match-end 0))
3253 (replace-match "" nil t)))
eec82323 3254 ;; Then replace multiple empty lines with a single empty line.
16409b0b 3255 (article-goto-body)
23f87bed 3256 (while (re-search-forward "\n\n\\(\n+\\)" nil t)
16409b0b
GM		 3257 (unless (gnus-annotation-in-region-p
3258 (match-beginning 0) (match-end 0))
23f87bed 3259 (delete-region (match-beginning 1) (match-end 1)))))))
eec82323
LMI		 3260
3261(defun article-strip-leading-space ()
3262 "Remove all white space from the beginning of the lines in the article."
3263 (interactive)
3264 (save-excursion
3265 (let ((inhibit-point-motion-hooks t)
23f87bed 3266 (inhibit-read-only t))
16409b0b 3267 (article-goto-body)
eec82323
LMI		 3268 (while (re-search-forward "^[ \t]+" nil t)
3269 (replace-match "" t t)))))
3270
16409b0b
GM		 3271(defun article-strip-trailing-space ()
3272 "Remove all white space from the end of the lines in the article."
3273 (interactive)
3274 (save-excursion
3275 (let ((inhibit-point-motion-hooks t)
23f87bed 3276 (inhibit-read-only t))
16409b0b
GM		 3277 (article-goto-body)
3278 (while (re-search-forward "[ \t]+$" nil t)
3279 (replace-match "" t t)))))
3280
eec82323
LMI		 3281(defun article-strip-blank-lines ()
3282 "Strip leading, trailing and multiple blank lines."
3283 (interactive)
3284 (article-strip-leading-blank-lines)
3285 (article-remove-trailing-blank-lines)
3286 (article-strip-multiple-blank-lines))
3287
6748645f
LMI		 3288(defun article-strip-all-blank-lines ()
3289 "Strip all blank lines."
3290 (interactive)
3291 (save-excursion
3292 (let ((inhibit-point-motion-hooks t)
23f87bed 3293 (inhibit-read-only t))
16409b0b 3294 (article-goto-body)
6748645f
LMI		 3295 (while (re-search-forward "^[ \t]*\n" nil t)
3296 (replace-match "" t t)))))
3297
eec82323
LMI		 3298(defun gnus-article-narrow-to-signature ()
3299 "Narrow to the signature; return t if a signature is found, else nil."
6748645f 3300 (let ((inhibit-point-motion-hooks t))
6748645f
LMI		 3301 (when (gnus-article-search-signature)
3302 (forward-line 1)
3303 ;; Check whether we have some limits to what we consider
3304 ;; to be a signature.
3305 (let ((limits (if (listp gnus-signature-limit) gnus-signature-limit
3306 (list gnus-signature-limit)))
3307 limit limited)
3308 (while (setq limit (pop limits))
3309 (if (or (and (integerp limit)
3310 (< (- (point-max) (point)) limit))
3311 (and (floatp limit)
3312 (< (count-lines (point) (point-max)) limit))
23f87bed 3313 (and (functionp limit)
6748645f
LMI		 3314 (funcall limit))
3315 (and (stringp limit)
3316 (not (re-search-forward limit nil t))))
3317 () ; This limit did not succeed.
3318 (setq limited t
3319 limits nil)))
3320 (unless limited
3321 (narrow-to-region (point) (point-max))
3322 t)))))
eec82323
LMI		 3323
3324(defun gnus-article-search-signature ()
3325 "Search the current buffer for the signature separator.
3326Put point at the beginning of the signature separator."
3327 (let ((cur (point)))
3328 (goto-char (point-max))
3329 (if (if (stringp gnus-signature-separator)
3330 (re-search-backward gnus-signature-separator nil t)
3331 (let ((seps gnus-signature-separator))
3332 (while (and seps
3333 (not (re-search-backward (car seps) nil t)))
3334 (pop seps))
3335 seps))
3336 t
3337 (goto-char cur)
3338 nil)))
3339
eec82323
LMI		 3340(defun gnus-article-hidden-arg ()
3341 "Return the current prefix arg as a number, or 0 if no prefix."
3342 (list (if current-prefix-arg
3343 (prefix-numeric-value current-prefix-arg)
3344 0)))
3345
3346(defun gnus-article-check-hidden-text (type arg)
3347 "Return nil if hiding is necessary.
f0529b5b 3348Arg can be nil or a number. nil and positive means hide, negative
eec82323
LMI		 3349means show, 0 means toggle."
3350 (save-excursion
3351 (save-restriction
eec82323
LMI		 3352 (let ((hide (gnus-article-hidden-text-p type)))
3353 (cond
3354 ((or (null arg)
3355 (> arg 0))
3356 nil)
3357 ((< arg 0)
4481aa98
SZ		 3358 (gnus-article-show-hidden-text type)
3359 t)
eec82323
LMI		 3360 (t
3361 (if (eq hide 'hidden)
4481aa98
SZ		 3362 (progn
3363 (gnus-article-show-hidden-text type)
3364 t)
eec82323
LMI		 3365 nil)))))))
3366
3367(defun gnus-article-hidden-text-p (type)
3368 "Say whether the current buffer contains hidden text of type TYPE."
6748645f 3369 (let ((pos (text-property-any (point-min) (point-max) 'article-type type)))
eec82323 3370 (while (and pos
16409b0b
GM		 3371 (not (get-text-property pos 'invisible))
3372 (not (get-text-property pos 'dummy-invisible)))
eec82323
LMI		 3373 (setq pos
3374 (text-property-any (1+ pos) (point-max) 'article-type type)))
3375 (if pos
3376 'hidden
16409b0b 3377 nil)))
eec82323 3378
520aa572 3379(defun gnus-article-show-hidden-text (type &optional dummy)
eec82323 3380 "Show all hidden text of type TYPE.
520aa572 3381Originally it is hide instead of DUMMY."
4e7d0221 3382 (let ((inhibit-read-only t)
520aa572 3383 (inhibit-point-motion-hooks t))
a1506d29 3384 (gnus-remove-text-properties-when
520aa572 3385 'article-type type
a1506d29 3386 (point-min) (point-max)
520aa572 3387 (cons 'article-type (cons type
23f87bed
MB		 3388 gnus-hidden-properties)))
3389 (gnus-delete-wash-type type)))
eec82323
LMI		 3390
3391(defconst article-time-units
3392 `((year . ,(* 365.25 24 60 60))
3393 (week . ,(* 7 24 60 60))
3394 (day . ,(* 24 60 60))
3395 (hour . ,(* 60 60))
3396 (minute . 60)
3397 (second . 1))
3398 "Mapping from time units to seconds.")
3399
23f87bed
MB		 3400(defun gnus-article-forward-header ()
3401 "Move point to the start of the next header.
3402If the current header is a continuation header, this can be several
3403lines forward."
3404 (let ((ended nil))
3405 (while (not ended)
3406 (forward-line 1)
3407 (if (looking-at "[ \t]+[^ \t]")
3408 (forward-line 1)
3409 (setq ended t)))))
3410
12e3ca0a
LI		 3411(defun article-treat-date ()
3412 (article-date-ut gnus-article-date-headers t))
3413
3414(defun article-date-ut (&optional type highlight date-position)
3415 "Convert DATE date to TYPE in the current article.
3416The default type is `ut'. See `gnus-article-date-headers' for
3417possible values."
eec82323 3418 (interactive (list 'ut t))
12e3ca0a 3419 (let* ((case-fold-search t)
31640842 3420 (inhibit-read-only t)
eec82323 3421 (inhibit-point-motion-hooks t)
12e3ca0a 3422 (first t)
31640842 3423 pos date bface eface)
16409b0b
GM		 3424 (save-excursion
3425 (save-restriction
31640842 3426 (goto-char (point-min))
32a400d4
LI		 3427 (when (re-search-forward "^Date:" nil t)
3428 (setq bface (get-text-property (point-at-bol) 'face)
3429 eface (get-text-property (1- (point-at-eol)) 'face)))
3430 (goto-char (point-min))
3431 ;; Delete any old Date headers.
3432 (if date-position
3433 (progn
3434 (goto-char date-position)
3435 (setq date (get-text-property (point) 'original-date))
3436 (delete-region (point)
3437 (progn
3438 (gnus-article-forward-header)
3439 (point)))
3440 (article-transform-date date type bface eface))
3441 (while (re-search-forward "^Date:" nil t)
3442 (setq date (get-text-property (match-beginning 0) 'original-date))
3443 (delete-region (point-at-bol) (progn
3444 (gnus-article-forward-header)
0c74b838 3445 (point))))
8c9da040
LI		 3446 (when date
3447 (article-transform-date date type bface eface)))))))
32a400d4
LI		 3448
3449(defun article-transform-date (date type bface eface)
3450 (dolist (this-type (cond
3451 ((null type)
3452 (list 'ut))
3453 ((atom type)
3454 (list type))
3455 (t
3456 type)))
3457 (insert (article-make-date-line date (or this-type 'ut)) "\n")
3458 (forward-line -1)
3459 (beginning-of-line)
3460 (put-text-property (point) (1+ (point))
3461 'original-date date)
3462 (put-text-property (point) (1+ (point))
3463 'gnus-date-type this-type)
3464 ;; Do highlighting.
3465 (when (looking-at "\\([^:]+\\): *\\(.*\\)$")
3466 (put-text-property (match-beginning 1) (1+ (match-end 1))
3467 'face bface)
3468 (put-text-property (match-beginning 2) (match-end 2)
5b9b62f1
LI		 3469 'face eface))
3470 (forward-line 1)))
eec82323
LMI		 3471
3472(defun article-make-date-line (date type)
3473 "Return a DATE line of TYPE."
5fe18311
KY		 3474 (unless (memq type '(local ut original user-defined iso8601 lapsed english
3475 combined-lapsed))
23f87bed
MB		 3476 (error "Unknown conversion type: %s" type))
3477 (condition-case ()
3478 (let ((time (date-to-time date)))
16409b0b 3479 (cond
23f87bed
MB		 3480 ;; Convert to the local timezone.
3481 ((eq type 'local)
01c52d31 3482 (concat "Date: " (message-make-date time)))
23f87bed
MB		 3483 ;; Convert to Universal Time.
3484 ((eq type 'ut)
3485 (concat "Date: "
01c52d31
MB		 3486 (substring
3487 (message-make-date
3488 (let* ((e (parse-time-string date))
3489 (tm (apply 'encode-time e))
3490 (ms (car tm))
3491 (ls (- (cadr tm) (car (current-time-zone time)))))
3492 (cond ((< ls 0) (list (1- ms) (+ ls 65536)))
3493 ((> ls 65535) (list (1+ ms) (- ls 65536)))
3494 (t (list ms ls)))))
3495 0 -5)
3496 "UT"))
23f87bed
MB		 3497 ;; Get the original date from the article.
3498 ((eq type 'original)
3499 (concat "Date: " (if (string-match "\n+$" date)
3500 (substring date 0 (match-beginning 0))
3501 date)))
3502 ;; Let the user define the format.
c4753373 3503 ((eq type 'user-defined)
23f87bed
MB		 3504 (let ((format (or (condition-case nil
3505 (with-current-buffer gnus-summary-buffer
3506 gnus-article-time-format)
3507 (error nil))
3508 gnus-article-time-format)))
3509 (if (functionp format)
3510 (funcall format time)
3511 (concat "Date: " (format-time-string format time)))))
3512 ;; ISO 8601.
3513 ((eq type 'iso8601)
3514 (let ((tz (car (current-time-zone time))))
3515 (concat
3516 "Date: "
3517 (format-time-string "%Y%m%dT%H%M%S" time)
3518 (format "%s%02d%02d"
3519 (if (> tz 0) "+" "-") (/ (abs tz) 3600)
3520 (/ (% (abs tz) 3600) 60)))))
12e3ca0a 3521 ;; Do a lapsed format.
23f87bed 3522 ((eq type 'lapsed)
12e3ca0a 3523 (concat "Date: " (article-lapsed-string time)))
647559c2
LI		 3524 ;; A combined date/lapsed format.
3525 ((eq type 'combined-lapsed)
19cc6697
G		 3526 (let ((date-string (article-make-date-line date 'original))
3527 (segments 3)
3528 lapsed-string)
3529 (while (and
3530 (setq lapsed-string
3531 (concat " (" (article-lapsed-string time segments) ")"))
3532 (> (+ (length date-string)
3533 (length lapsed-string))
d6f13ac8 3534 (+ fill-column 6))
19cc6697
G		 3535 (> segments 0))
3536 (setq segments (1- segments)))
3537 (if (> segments 0)
3538 (concat date-string lapsed-string)
3539 date-string)))
23f87bed
MB		 3540 ;; Display the date in proper English
3541 ((eq type 'english)
3542 (let ((dtime (decode-time time)))
3543 (concat
3544 "Date: the "
3545 (number-to-string (nth 3 dtime))
3546 (let ((digit (% (nth 3 dtime) 10)))
3547 (cond
3548 ((memq (nth 3 dtime) '(11 12 13)) "th")
3549 ((= digit 1) "st")
3550 ((= digit 2) "nd")
3551 ((= digit 3) "rd")
3552 (t "th")))
3553 " of "
3554 (nth (1- (nth 4 dtime)) gnus-english-month-names)
3555 " "
3556 (number-to-string (nth 5 dtime))
3557 " at "
3558 (format "%02d" (nth 2 dtime))
3559 ":"
3560 (format "%02d" (nth 1 dtime)))))))
647559c2 3561 (foo
a601fb74 3562 (format "Date: %s (from Gnus)" date))))
eec82323 3563
647559c2
LI		 3564(defun article-lapsed-string (time &optional max-segments)
3565 ;; If the date is seriously mangled, the timezone functions are
3566 ;; liable to bug out, so we ignore all errors.
3567 (let* ((now (current-time))
3568 (real-time (subtract-time now time))
3569 (real-sec (and real-time
3570 (+ (* (float (car real-time)) 65536)
3571 (cadr real-time))))
3572 (sec (and real-time (abs real-sec)))
3573 (segments 0)
3574 num prev)
3575 (unless max-segments
3576 (setq max-segments (length article-time-units)))
3577 (cond
3578 ((null real-time)
3579 "Unknown")
3580 ((zerop sec)
3581 "Now")
3582 (t
3583 (concat
3584 ;; This is a bit convoluted, but basically we go
3585 ;; through the time units for years, weeks, etc,
3586 ;; and divide things to see whether that results
3587 ;; in positive answers.
3588 (mapconcat
3589 (lambda (unit)
3590 (if (or (zerop (setq num (ffloor (/ sec (cdr unit)))))
3591 (>= segments max-segments))
3592 ;; The (remaining) seconds are too few to
3593 ;; be divided into this time unit.
3594 ""
3595 ;; It's big enough, so we output it.
3596 (setq sec (- sec (* num (cdr unit))))
3597 (prog1
3598 (concat (if prev ", " "") (int-to-string
3599 (floor num))
3600 " " (symbol-name (car unit))
3601 (if (> num 1) "s" ""))
3602 (setq prev t
3603 segments (1+ segments)))))
3604 article-time-units "")
3605 ;; If dates are odd, then it might appear like the
3606 ;; article was sent in the future.
3607 (if (> real-sec 0)
3608 " ago"
3609 " in the future"))))))
3610
eec82323
LMI		 3611(defun article-date-local (&optional highlight)
3612 "Convert the current article date to the local timezone."
3613 (interactive (list t))
3614 (article-date-ut 'local highlight))
3615
23f87bed
MB		 3616(defun article-date-english (&optional highlight)
3617 "Convert the current article date to something that is proper English."
3618 (interactive (list t))
3619 (article-date-ut 'english highlight))
3620
eec82323
LMI		 3621(defun article-date-original (&optional highlight)
3622 "Convert the current article date to what it was originally.
3623This is only useful if you have used some other date conversion
3624function and want to see what the date was before converting."
3625 (interactive (list t))
3626 (article-date-ut 'original highlight))
3627
3628(defun article-date-lapsed (&optional highlight)
3629 "Convert the current article date to time lapsed since it was sent."
3630 (interactive (list t))
3631 (article-date-ut 'lapsed highlight))
3632
647559c2
LI		 3633(defun article-date-combined-lapsed (&optional highlight)
3634 "Convert the current article date to time lapsed since it was sent."
3635 (interactive (list t))
3636 (article-date-ut 'combined-lapsed highlight))
3637
6748645f
LMI		 3638(defun article-update-date-lapsed ()
3639 "Function to be run from a timer to update the lapsed time line."
e0a8aa09 3640 (save-match-data
0832490d
LI		 3641 (let ((buffer (current-buffer)))
3642 (ignore-errors
3643 (walk-windows
3644 (lambda (w)
3645 (set-buffer (window-buffer w))
3646 (when (eq major-mode 'gnus-article-mode)
3647 (let ((old-line (count-lines (point-min) (point)))
abb97fbb 3648 (old-column (- (point) (line-beginning-position))))
0832490d
LI		 3649 (goto-char (point-min))
3650 (while (re-search-forward "^Date:" nil t)
3651 (let ((type (get-text-property (match-beginning 0) 'gnus-date-type)))
3652 (when (memq type '(lapsed combined-lapsed user-format))
3653 (save-excursion
3654 (article-date-ut type t (match-beginning 0)))
3655 (forward-line 1))))
3656 (goto-char (point-min))
3657 (when (> old-column 0)
3658 (setq old-line (1- old-line)))
3659 (forward-line old-line)
3660 (end-of-line)
3661 (when (> (current-column) old-column)
3662 (beginning-of-line)
3663 (forward-char old-column)))))
3664 nil 'visible))
3665 (set-buffer buffer))))
6748645f
LMI		 3666
3667(defun gnus-start-date-timer (&optional n)
12e3ca0a 3668 "Start a timer to update the Date headers in the article buffers.
6748645f
LMI		 3669The numerical prefix says how frequently (in seconds) the function
3670is to run."
3671 (interactive "p")
3672 (unless n
3673 (setq n 1))
3674 (gnus-stop-date-timer)
3675 (setq article-lapsed-timer
01c52d31 3676 (run-at-time 1 n 'article-update-date-lapsed)))
6748645f
LMI		 3677
3678(defun gnus-stop-date-timer ()
12e3ca0a 3679 "Stop the Date timer."
6748645f
LMI		 3680 (interactive)
3681 (when article-lapsed-timer
3682 (nnheader-cancel-timer article-lapsed-timer)
3683 (setq article-lapsed-timer nil)))
3684
eec82323
LMI		 3685(defun article-date-user (&optional highlight)
3686 "Convert the current article date to the user-defined format.
3687This format is defined by the `gnus-article-time-format' variable."
3688 (interactive (list t))
3689 (article-date-ut 'user highlight))
3690
6748645f
LMI		 3691(defun article-date-iso8601 (&optional highlight)
3692 "Convert the current article date to ISO8601."
3693 (interactive (list t))
3694 (article-date-ut 'iso8601 highlight))
3695
31640842
MB		 3696(defmacro gnus-article-save-original-date (&rest forms)
3697 "Save the original date as a text property and evaluate FORMS."
3698 `(let* ((case-fold-search t)
3699 (start (progn
3700 (goto-char (point-min))
3701 (when (and (re-search-forward "^date:[\t\n ]+" nil t)
3702 (not (bolp)))
3703 (match-end 0))))
3704 (date (when (and start
01c52d31 3705 (re-search-forward "[\t ]*\n\\(?:[^\t ]\\|\\'\\)"
31640842
MB		 3706 nil t))
3707 (buffer-substring-no-properties start
3708 (match-beginning 0)))))
3709 (goto-char (point-max))
3710 (skip-chars-backward "\n")
3711 (put-text-property (point-min) (point) 'original-date date)
3712 ,@forms
3713 (goto-char (point-max))
3714 (skip-chars-backward "\n")
3715 (put-text-property (point-min) (point) 'original-date date)))
3716
23f87bed
MB		 3717;; (defun article-show-all ()
3718;; "Show all hidden text in the article buffer."
3719;; (interactive)
3720;; (save-excursion
3721;; (let ((inhibit-read-only t))
3722;; (gnus-article-unhide-text (point-min) (point-max)))))
3723
3724(defun article-remove-leading-whitespace ()
3725 "Remove excessive whitespace from all headers."
eec82323
LMI		 3726 (interactive)
3727 (save-excursion
23f87bed
MB		 3728 (save-restriction
3729 (let ((inhibit-read-only t))
3730 (article-narrow-to-head)
3731 (goto-char (point-min))
3732 (while (re-search-forward "^[^ :]+: \\([ \t]+\\)" nil t)
3733 (delete-region (match-beginning 1) (match-end 1)))))))
eec82323
LMI		 3734
3735(defun article-emphasize (&optional arg)
3736 "Emphasize text according to `gnus-emphasis-alist'."
3737 (interactive (gnus-article-hidden-arg))
3738 (unless (gnus-article-check-hidden-text 'emphasis arg)
3739 (save-excursion
a1506d29 3740 (let ((alist (or
16409b0b 3741 (condition-case nil
a1506d29
JB		 3742 (with-current-buffer gnus-summary-buffer
3743 gnus-article-emphasis-alist)
16409b0b
GM		 3744 (error))
3745 gnus-emphasis-alist))
4e7d0221 3746 (inhibit-read-only t)
eec82323
LMI		 3747 (props (append '(article-type emphasis)
3748 gnus-hidden-properties))
3749 regexp elem beg invisible visible face)
16409b0b 3750 (article-goto-body)
eec82323
LMI		 3751 (setq beg (point))
3752 (while (setq elem (pop alist))
3753 (goto-char beg)
3754 (setq regexp (car elem)
3755 invisible (nth 1 elem)
3756 visible (nth 2 elem)
3757 face (nth 3 elem))
3758 (while (re-search-forward regexp nil t)
23f87bed
MB		 3759 (when (and (match-beginning visible) (match-beginning invisible))
3760 (gnus-article-hide-text
3761 (match-beginning invisible) (match-end invisible) props)
3762 (gnus-article-unhide-text-type
3763 (match-beginning visible) (match-end visible) 'emphasis)
3764 (gnus-put-overlay-excluding-newlines
3765 (match-beginning visible) (match-end visible) 'face face)
3766 (gnus-add-wash-type 'emphasis)
3767 (goto-char (match-end invisible)))))))))
eec82323 3768
16409b0b
GM		 3769(defun gnus-article-setup-highlight-words (&optional highlight-words)
3770 "Setup newsgroup emphasis alist."
3771 (unless gnus-article-emphasis-alist
3772 (let ((name (and gnus-newsgroup-name
3773 (gnus-group-real-name gnus-newsgroup-name))))
3774 (make-local-variable 'gnus-article-emphasis-alist)
a1506d29
JB		 3775 (setq gnus-article-emphasis-alist
3776 (nconc
16409b0b
GM		 3777 (let ((alist gnus-group-highlight-words-alist) elem highlight)
3778 (while (setq elem (pop alist))
3779 (when (and name (string-match (car elem) name))
3780 (setq alist nil
3781 highlight (copy-sequence (cdr elem)))))
3782 highlight)
3783 (copy-sequence highlight-words)
3784 (if gnus-newsgroup-name
a1506d29 3785 (copy-sequence (gnus-group-find-parameter
16409b0b
GM		 3786 gnus-newsgroup-name 'highlight-words t)))
3787 gnus-emphasis-alist)))))
3788
9efa445f
DN		 3789(defvar gnus-summary-article-menu)
3790(defvar gnus-summary-post-menu)
eec82323
LMI		 3791
3792;;; Saving functions.
3793
3794(defun gnus-article-save (save-buffer file &optional num)
3795 "Save the currently selected article."
26c9afc3
MB		 3796 (when (or (get gnus-default-article-saver :headers)
3797 (not gnus-save-all-headers))
3798 ;; Remove headers according to `gnus-saved-headers' or the value
3799 ;; of the `:headers' property that the saver function might have.
eec82323 3800 (let ((gnus-visible-headers
26c9afc3
MB		 3801 (or (symbol-value (get gnus-default-article-saver :headers))
3802 gnus-saved-headers gnus-visible-headers))
16c85f26
MB		 3803 ;; Ignore group parameter. See `article-hide-headers'.
3804 (gnus-summary-buffer nil))
80de1778 3805 (with-current-buffer save-buffer
6748645f 3806 (article-hide-headers 1 t))))
eec82323
LMI		 3807 (save-window-excursion
3808 (if (not gnus-default-article-saver)
a8151ef7 3809 (error "No default saver is defined")
eec82323 3810 ;; !!! Magic! The saving functions all save
16409b0b 3811 ;; `gnus-save-article-buffer' (or so they think), but we
eec82323
LMI		 3812 ;; bind that variable to our save-buffer.
3813 (set-buffer gnus-article-buffer)
3814 (let* ((gnus-save-article-buffer save-buffer)
3815 (filename
3816 (cond
3817 ((not gnus-prompt-before-saving) 'default)
3818 ((eq gnus-prompt-before-saving 'always) nil)
3819 (t file)))
3820 (gnus-number-of-articles-to-be-saved
3821 (when (eq gnus-prompt-before-saving t)
3822 num))) ; Magic
6748645f 3823 (set-buffer gnus-article-current-summary)
eec82323
LMI		 3824 (funcall gnus-default-article-saver filename)))))
3825
3826(defun gnus-read-save-file-name (prompt &optional filename
26c9afc3
MB		 3827 function group headers variable
3828 dir-var)
eec82323
LMI		 3829 (let ((default-name
3830 (funcall function group headers (symbol-value variable)))
3831 result)
4325195c 3832 (setq result
a1506d29 3833 (expand-file-name
4325195c
DL		 3834 (cond
3835 ((eq filename 'default)
3836 default-name)
3837 ((eq filename t)
3838 default-name)
3839 (filename filename)
3840 (t
26c9afc3
MB		 3841 (when (symbol-value dir-var)
3842 (setq default-name (expand-file-name
3843 (file-name-nondirectory default-name)
3844 (symbol-value dir-var))))
4325195c
DL		 3845 (let* ((split-name (gnus-get-split-value gnus-split-methods))
3846 (prompt
3847 (format prompt
3848 (if (and gnus-number-of-articles-to-be-saved
3849 (> gnus-number-of-articles-to-be-saved 1))
3850 (format "these %d articles"
3851 gnus-number-of-articles-to-be-saved)
3852 "this article")))
3853 (file
3854 ;; Let the split methods have their say.
3855 (cond
3856 ;; No split name was found.
3857 ((null split-name)
3858 (read-file-name
3859 (concat prompt " (default "
81df110a 3860 (file-name-nondirectory default-name) "): ")
4325195c
DL		 3861 (file-name-directory default-name)
3862 default-name))
3863 ;; A single group name is returned.
3864 ((stringp split-name)
3865 (setq default-name
3866 (funcall function split-name headers
3867 (symbol-value variable)))
3868 (read-file-name
3869 (concat prompt " (default "
81df110a 3870 (file-name-nondirectory default-name) "): ")
4325195c
DL		 3871 (file-name-directory default-name)
3872 default-name))
3873 ;; A single split name was found
3874 ((= 1 (length split-name))
3875 (let* ((name (expand-file-name
23f87bed
MB		 3876 (car split-name)
3877 gnus-article-save-directory))
4325195c
DL		 3878 (dir (cond ((file-directory-p name)
3879 (file-name-as-directory name))
3880 ((file-exists-p name) name)
3881 (t gnus-article-save-directory))))
3882 (read-file-name
81df110a 3883 (concat prompt " (default " name "): ")
4325195c
DL		 3884 dir name)))
3885 ;; A list of splits was found.
3886 (t
3887 (setq split-name (nreverse split-name))
3888 (let (result)
3889 (let ((file-name-history
3890 (nconc split-name file-name-history)))
3891 (setq result
3892 (expand-file-name
3893 (read-file-name
81df110a 3894 (concat prompt " (`M-p' for defaults): ")
4325195c
DL		 3895 gnus-article-save-directory
3896 (car split-name))
3897 gnus-article-save-directory)))
3898 (car (push result file-name-history)))))))
3899 ;; Create the directory.
3900 (gnus-make-directory (file-name-directory file))
23f87bed 3901 ;; If we have read a directory, we append the default file name.
4325195c 3902 (when (file-directory-p file)
23f87bed
MB		 3903 (setq file (expand-file-name (file-name-nondirectory
3904 default-name)
4325195c
DL		 3905 (file-name-as-directory file))))
3906 ;; Possibly translate some characters.
3907 (nnheader-translate-file-chars file))))))
eec82323 3908 (gnus-make-directory (file-name-directory result))
26c9afc3
MB		 3909 (when variable
3910 (set variable result))
3911 (when dir-var
3912 (set dir-var (file-name-directory result)))
3913 result))
eec82323
LMI		 3914
3915(defun gnus-article-archive-name (group)
3916 "Return the first instance of an \"Archive-name\" in the current buffer."
3917 (let ((case-fold-search t))
3918 (when (re-search-forward "archive-name: *\\([^ \n\t]+\\)[ \t]*$" nil t)
3919 (nnheader-concat gnus-article-save-directory
3920 (match-string 1)))))
3921
3922(defun gnus-article-nndoc-name (group)
3923 "If GROUP is an nndoc group, return the name of the parent group."
3924 (when (eq (car (gnus-find-method-for-group group)) 'nndoc)
3925 (gnus-group-get-parameter group 'save-article-group)))
3926
3927(defun gnus-summary-save-in-rmail (&optional filename)
3928 "Append this article to Rmail file.
3929Optional argument FILENAME specifies file name.
3930Directory to save to is default to `gnus-article-save-directory'."
eec82323 3931 (setq filename (gnus-read-save-file-name
81df110a 3932 "Save %s in rmail file" filename
eec82323
LMI		 3933 gnus-rmail-save-name gnus-newsgroup-name
3934 gnus-current-headers 'gnus-newsgroup-last-rmail))
a3f57c41 3935 (with-current-buffer gnus-save-article-buffer
eec82323
LMI		 3936 (save-excursion
3937 (save-restriction
3938 (widen)
fef8d38e
GM		 3939 ;; Note that unlike gnus-summary-save-in-mail, there is no
3940 ;; check to see if filename is Babyl. Rmail in Emacs 23 does
3941 ;; not use Babyl.
6748645f
LMI		 3942 (gnus-output-to-rmail filename))))
3943 filename)
eec82323
LMI		 3944
3945(defun gnus-summary-save-in-mail (&optional filename)
3946 "Append this article to Unix mail file.
3947Optional argument FILENAME specifies file name.
3948Directory to save to is default to `gnus-article-save-directory'."
eec82323 3949 (setq filename (gnus-read-save-file-name
81df110a 3950 "Save %s in Unix mail file" filename
eec82323
LMI		 3951 gnus-mail-save-name gnus-newsgroup-name
3952 gnus-current-headers 'gnus-newsgroup-last-mail))
a3f57c41 3953 (with-current-buffer gnus-save-article-buffer
eec82323
LMI		 3954 (save-excursion
3955 (save-restriction
3956 (widen)
3957 (if (and (file-readable-p filename)
23f87bed 3958 (file-regular-p filename)
eec82323 3959 (mail-file-babyl-p filename))
fef8d38e 3960 (gnus-output-to-rmail filename)
6748645f
LMI		 3961 (gnus-output-to-mail filename)))))
3962 filename)
eec82323 3963
26c9afc3
MB		 3964(put 'gnus-summary-save-in-file :decode t)
3965(put 'gnus-summary-save-in-file :headers 'gnus-saved-headers)
eec82323
LMI		 3966(defun gnus-summary-save-in-file (&optional filename overwrite)
3967 "Append this article to file.
3968Optional argument FILENAME specifies file name.
3969Directory to save to is default to `gnus-article-save-directory'."
eec82323 3970 (setq filename (gnus-read-save-file-name
81df110a 3971 "Save %s in file" filename
eec82323
LMI		 3972 gnus-file-save-name gnus-newsgroup-name
3973 gnus-current-headers 'gnus-newsgroup-last-file))
a3f57c41 3974 (with-current-buffer gnus-save-article-buffer
eec82323
LMI		 3975 (save-excursion
3976 (save-restriction
3977 (widen)
3978 (when (and overwrite
3979 (file-exists-p filename))
3980 (delete-file filename))
6748645f
LMI		 3981 (gnus-output-to-file filename))))
3982 filename)
eec82323 3983
26c9afc3
MB		 3984(put 'gnus-summary-write-to-file :decode t)
3985(put 'gnus-summary-write-to-file :function 'gnus-summary-save-in-file)
3986(put 'gnus-summary-write-to-file :headers 'gnus-saved-headers)
eec82323 3987(defun gnus-summary-write-to-file (&optional filename)
23f87bed 3988 "Write this article to a file, overwriting it if the file exists.
eec82323
LMI		 3989Optional argument FILENAME specifies file name.
3990The directory to save in defaults to `gnus-article-save-directory'."
26c9afc3
MB		 3991 (setq filename (gnus-read-save-file-name
3992 "Save %s in file" filename
3993 gnus-file-save-name gnus-newsgroup-name
3994 gnus-current-headers nil 'gnus-newsgroup-last-directory))
3995 (gnus-summary-save-in-file filename t))
eec82323 3996
26c9afc3
MB		 3997(put 'gnus-summary-save-body-in-file :decode t)
3998(defun gnus-summary-save-body-in-file (&optional filename overwrite)
eec82323
LMI		 3999 "Append this article body to a file.
4000Optional argument FILENAME specifies file name.
4001The directory to save in defaults to `gnus-article-save-directory'."
eec82323 4002 (setq filename (gnus-read-save-file-name
81df110a 4003 "Save %s body in file" filename
eec82323
LMI		 4004 gnus-file-save-name gnus-newsgroup-name
4005 gnus-current-headers 'gnus-newsgroup-last-file))
a3f57c41 4006 (with-current-buffer gnus-save-article-buffer
eec82323
LMI		 4007 (save-excursion
4008 (save-restriction
4009 (widen)
16409b0b 4010 (when (article-goto-body)
eec82323 4011 (narrow-to-region (point) (point-max)))
26c9afc3
MB		 4012 (when (and overwrite
4013 (file-exists-p filename))
4014 (delete-file filename))
6748645f
LMI		 4015 (gnus-output-to-file filename))))
4016 filename)
eec82323 4017
26c9afc3
MB		 4018(put 'gnus-summary-write-body-to-file :decode t)
4019(put 'gnus-summary-write-body-to-file
4020 :function 'gnus-summary-save-body-in-file)
4021(defun gnus-summary-write-body-to-file (&optional filename)
4022 "Write this article body to a file, overwriting it if the file exists.
4023Optional argument FILENAME specifies file name.
4024The directory to save in defaults to `gnus-article-save-directory'."
4025 (setq filename (gnus-read-save-file-name
4026 "Save %s body in file" filename
4027 gnus-file-save-name gnus-newsgroup-name
4028 gnus-current-headers nil 'gnus-newsgroup-last-directory))
4029 (gnus-summary-save-body-in-file filename t))
4030
89167438
MB		 4031(put 'gnus-summary-save-in-pipe :decode t)
4032(put 'gnus-summary-save-in-pipe :headers 'gnus-saved-headers)
d62672f3
MB		 4033(defun gnus-summary-save-in-pipe (&optional command raw)
4034 "Pipe this article to subprocess COMMAND.
4035Valid values for COMMAND include:
4036 a string
4037 The executable command name and possibly arguments.
4038 nil
4039 You will be prompted for the command in the minibuffer.
4040 the symbol `default'
4041 It will be replaced with the command which the variable
4042 `gnus-summary-pipe-output-default-command' holds or the command
4043 last used for saving.
4044Non-nil value for RAW overrides `:decode' and `:headers' properties
4045and the raw article including all headers will be piped."
6ecfe5c2
MB		 4046 (let ((article (gnus-summary-article-number))
4047 (decode (unless raw
4048 (get 'gnus-summary-save-in-pipe :decode)))
4049 save-buffer default)
4050 (if article
4051 (if (vectorp (gnus-summary-article-header article))
4052 (save-current-buffer
4053 (gnus-summary-select-article decode decode nil article)
4054 (insert-buffer-substring
4055 (prog1
4056 (if decode
4057 gnus-article-buffer
4058 gnus-original-article-buffer)
4059 (setq save-buffer
4060 (nnheader-set-temp-buffer " *Gnus Save*"))))
4061 ;; Remove unwanted headers.
4062 (when (and (not raw)
4063 (or (get 'gnus-summary-save-in-pipe :headers)
4064 (not gnus-save-all-headers)))
4065 (let ((gnus-visible-headers
4066 (or (symbol-value (get 'gnus-summary-save-in-pipe
4067 :headers))
4068 gnus-saved-headers gnus-visible-headers))
4069 (gnus-summary-buffer nil))
4070 (article-hide-headers 1 t))))
4071 (error "%d is not a real article" article))
4072 (error "No article to pipe"))
4073 (setq default (or gnus-summary-pipe-output-default-command
4074 gnus-last-shell-command))
89167438
MB		 4075 (unless (stringp command)
4076 (setq command
4077 (if (and (eq command 'default) default)
4078 default
6ecfe5c2
MB		 4079 (gnus-read-shell-command "Shell command on this article: "
4080 default))))
89167438
MB		 4081 (when (string-equal command "")
4082 (if default
4083 (setq command default)
16c85f26 4084 (error "A command is required")))
a3f57c41 4085 (with-current-buffer save-buffer
16c85f26
MB		 4086 (save-restriction
4087 (widen)
4088 (shell-command-on-region (point-min) (point-max) command nil)))
4089 (gnus-kill-buffer save-buffer))
89167438 4090 (setq gnus-summary-pipe-output-default-command command))
eec82323 4091
23f87bed
MB		 4092(defun gnus-summary-pipe-to-muttprint (&optional command)
4093 "Pipe this article to muttprint."
16c85f26
MB		 4094 (unless (stringp command)
4095 (setq command (read-string
4096 "Print using command: " gnus-summary-muttprint-program
4097 nil gnus-summary-muttprint-program)))
4098 (let ((gnus-summary-pipe-output-default-command
4099 gnus-summary-pipe-output-default-command))
4100 (gnus-summary-save-in-pipe command))
4101 (setq gnus-summary-muttprint-program command))
23f87bed 4102
eec82323
LMI		 4103;;; Article file names when saving.
4104
4105(defun gnus-capitalize-newsgroup (newsgroup)
4106 "Capitalize NEWSGROUP name."
4107 (when (not (zerop (length newsgroup)))
4108 (concat (char-to-string (upcase (aref newsgroup 0)))
4109 (substring newsgroup 1))))
4110
4111(defun gnus-Numeric-save-name (newsgroup headers &optional last-file)
4112 "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE.
4113If variable `gnus-use-long-file-name' is non-nil, it is ~/News/News.group/num.
4114Otherwise, it is like ~/News/news/group/num."
4115 (let ((default
4116 (expand-file-name
4117 (concat (if (gnus-use-long-file-name 'not-save)
4118 (gnus-capitalize-newsgroup newsgroup)
4119 (gnus-newsgroup-directory-form newsgroup))
4120 "/" (int-to-string (mail-header-number headers)))
4121 gnus-article-save-directory)))
4122 (if (and last-file
4123 (string-equal (file-name-directory default)
4124 (file-name-directory last-file))
4125 (string-match "^[0-9]+$" (file-name-nondirectory last-file)))
4126 default
4127 (or last-file default))))
4128
4129(defun gnus-numeric-save-name (newsgroup headers &optional last-file)
4130 "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE.
4131If variable `gnus-use-long-file-name' is non-nil, it is
2ff9f5b4 4132~/News/news.group/num. Otherwise, it is like ~/News/news/group/num."
eec82323
LMI		 4133 (let ((default
4134 (expand-file-name
4135 (concat (if (gnus-use-long-file-name 'not-save)
4136 newsgroup
4137 (gnus-newsgroup-directory-form newsgroup))
4138 "/" (int-to-string (mail-header-number headers)))
4139 gnus-article-save-directory)))
4140 (if (and last-file
4141 (string-equal (file-name-directory default)
4142 (file-name-directory last-file))
4143 (string-match "^[0-9]+$" (file-name-nondirectory last-file)))
4144 default
4145 (or last-file default))))
4146
eec82323
LMI		 4147(defun gnus-plain-save-name (newsgroup headers &optional last-file)
4148 "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE.
4149If variable `gnus-use-long-file-name' is non-nil, it is
4150~/News/news.group. Otherwise, it is like ~/News/news/group/news."
4151 (or last-file
4152 (expand-file-name
4153 (if (gnus-use-long-file-name 'not-save)
4154 newsgroup
23f87bed
MB		 4155 (file-relative-name
4156 (expand-file-name "news" (gnus-newsgroup-directory-form newsgroup))
4157 default-directory))
eec82323
LMI		 4158 gnus-article-save-directory)))
4159
23f87bed
MB		 4160(defun gnus-sender-save-name (newsgroup headers &optional last-file)
4161 "Generate file name from sender."
4162 (let ((from (mail-header-from headers)))
4163 (expand-file-name
4164 (if (and from (string-match "\\([^ <]+\\)@" from))
4165 (match-string 1 from)
4166 "nobody")
4167 gnus-article-save-directory)))
4168
4169(defun article-verify-x-pgp-sig ()
4170 "Verify X-PGP-Sig."
bbbe940b 4171 ;; <ftp://ftp.isc.org/pub/pgpcontrol/FORMAT>
23f87bed
MB		 4172 (interactive)
4173 (if (gnus-buffer-live-p gnus-original-article-buffer)
4174 (let ((sig (with-current-buffer gnus-original-article-buffer
4175 (gnus-fetch-field "X-PGP-Sig")))
4176 items info headers)
4177 (when (and sig
4178 mml2015-use
4179 (mml2015-clear-verify-function))
4180 (with-temp-buffer
4181 (insert-buffer-substring gnus-original-article-buffer)
4182 (setq items (split-string sig))
4183 (message-narrow-to-head)
4184 (let ((inhibit-point-motion-hooks t)
4185 (case-fold-search t))
4186 ;; Don't verify multiple headers.
4187 (setq headers (mapconcat (lambda (header)
4188 (concat header ": "
4189 (mail-fetch-field header)
4190 "\n"))
4191 (split-string (nth 1 items) ",") "")))
4192 (delete-region (point-min) (point-max))
4193 (insert "-----BEGIN PGP SIGNED MESSAGE-----\n\n")
4194 (insert "X-Signed-Headers: " (nth 1 items) "\n")
4195 (insert headers)
4196 (widen)
4197 (forward-line)
4198 (while (not (eobp))
4199 (if (looking-at "^-")
4200 (insert "- "))
4201 (forward-line))
4202 (insert "\n-----BEGIN PGP SIGNATURE-----\n")
4203 (insert "Version: " (car items) "\n\n")
4204 (insert (mapconcat 'identity (cddr items) "\n"))
4205 (insert "\n-----END PGP SIGNATURE-----\n")
4206 (let ((mm-security-handle (list (format "multipart/signed"))))
4207 (mml2015-clean-buffer)
4208 (let ((coding-system-for-write (or gnus-newsgroup-charset
4209 'iso-8859-1)))
4210 (funcall (mml2015-clear-verify-function)))
4211 (setq info
4212 (or (mm-handle-multipart-ctl-parameter
4213 mm-security-handle 'gnus-details)
4214 (mm-handle-multipart-ctl-parameter
4215 mm-security-handle 'gnus-info)))))
4216 (when info
4217 (let ((inhibit-read-only t) bface eface)
4218 (save-restriction
4219 (message-narrow-to-head)
4220 (goto-char (point-max))
4221 (forward-line -1)
01c52d31
MB		 4222 (setq bface (get-text-property (point-at-bol) 'face)
4223 eface (get-text-property (1- (point-at-eol)) 'face))
23f87bed
MB		 4224 (message-remove-header "X-Gnus-PGP-Verify")
4225 (if (re-search-forward "^X-PGP-Sig:" nil t)
4226 (forward-line)
4227 (goto-char (point-max)))
4228 (narrow-to-region (point) (point))
4229 (insert "X-Gnus-PGP-Verify: " info "\n")
4230 (goto-char (point-min))
4231 (forward-line)
4232 (while (not (eobp))
4233 (if (not (looking-at "^[ \t]"))
4234 (insert " "))
4235 (forward-line))
4236 ;; Do highlighting.
4237 (goto-char (point-min))
4238 (when (looking-at "\\([^:]+\\): *")
4239 (put-text-property (match-beginning 1) (1+ (match-end 1))
4240 'face bface)
4241 (put-text-property (match-end 0) (point-max)
4242 'face eface)))))))))
4243
5843126b 4244(autoload 'canlock-verify "canlock" nil t) ;; for XEmacs.
ec7995fa 4245
23f87bed
MB		 4246(defun article-verify-cancel-lock ()
4247 "Verify Cancel-Lock header."
4248 (interactive)
4249 (if (gnus-buffer-live-p gnus-original-article-buffer)
4250 (canlock-verify gnus-original-article-buffer)))
4251
eec82323 4252(eval-and-compile
01c52d31 4253 (mapc
eec82323
LMI		 4254 (lambda (func)
4255 (let (afunc gfunc)
4256 (if (consp func)
4257 (setq afunc (car func)
4258 gfunc (cdr func))
4259 (setq afunc func
4260 gfunc (intern (format "gnus-%s" func))))
16409b0b 4261 (defalias gfunc
23f87bed 4262 (when (fboundp afunc)
16409b0b
GM		 4263 `(lambda (&optional interactive &rest args)
4264 ,(documentation afunc t)
4265 (interactive (list t))
80de1778 4266 (with-current-buffer gnus-article-buffer
16409b0b
GM		 4267 (if interactive
4268 (call-interactively ',afunc)
4269 (apply ',afunc args))))))))
eec82323 4270 '(article-hide-headers
23f87bed
MB		 4271 article-verify-x-pgp-sig
4272 article-verify-cancel-lock
eec82323
LMI		 4273 article-hide-boring-headers
4274 article-treat-overstrike
01c52d31 4275 article-treat-ansi-sequences
16409b0b
GM		 4276 article-fill-long-lines
4277 article-capitalize-sentences
eec82323 4278 article-remove-cr
23f87bed 4279 article-remove-leading-whitespace
eec82323 4280 article-display-x-face
23f87bed 4281 article-display-face
eec82323 4282 article-de-quoted-unreadable
16409b0b
GM		 4283 article-de-base64-unreadable
4284 article-decode-HZ
4285 article-wash-html
23f87bed 4286 article-unsplit-urls
16409b0b 4287 article-hide-list-identifiers
16409b0b
GM		 4288 article-strip-banner
4289 article-babel
eec82323
LMI		 4290 article-hide-pem
4291 article-hide-signature
16409b0b 4292 article-strip-headers-in-body
eec82323
LMI		 4293 article-remove-trailing-blank-lines
4294 article-strip-leading-blank-lines
4295 article-strip-multiple-blank-lines
4296 article-strip-leading-space
16409b0b 4297 article-strip-trailing-space
eec82323 4298 article-strip-blank-lines
6748645f 4299 article-strip-all-blank-lines
eec82323 4300 article-date-local
23f87bed 4301 article-date-english
6748645f 4302 article-date-iso8601
eec82323 4303 article-date-original
12e3ca0a 4304 article-treat-date
eec82323 4305 article-date-ut
16409b0b
GM		 4306 article-decode-mime-words
4307 article-decode-charset
4308 article-decode-encoded-words
eec82323
LMI		 4309 article-date-user
4310 article-date-lapsed
647559c2 4311 article-date-combined-lapsed
eec82323 4312 article-emphasize
6748645f 4313 article-treat-dumbquotes
be3c11b3 4314 article-treat-non-ascii
16409b0b 4315 article-normalize-headers
01c52d31 4316 ;;(article-show-all . gnus-article-show-all-headers)
23f87bed 4317 )))
eec82323
LMI		 4318\f
4319;;;
4320;;; Gnus article mode
4321;;;
4322
4323(put 'gnus-article-mode 'mode-class 'special)
4324
16409b0b
GM		 4325(set-keymap-parent gnus-article-mode-map widget-keymap)
4326
a8151ef7
LMI		 4327(gnus-define-keys gnus-article-mode-map
4328 " " gnus-article-goto-next-page
4329 "\177" gnus-article-goto-prev-page
4330 [delete] gnus-article-goto-prev-page
16409b0b 4331 [backspace] gnus-article-goto-prev-page
a8151ef7
LMI		 4332 "\C-c^" gnus-article-refer-article
4333 "h" gnus-article-show-summary
4334 "s" gnus-article-show-summary
4335 "\C-c\C-m" gnus-article-mail
4336 "?" gnus-article-describe-briefly
a8151ef7
LMI		 4337 "<" beginning-of-buffer
4338 ">" end-of-buffer
4339 "\C-c\C-i" gnus-info-find-node
4340 "\C-c\C-b" gnus-bug
23f87bed
MB		 4341 "R" gnus-article-reply-with-original
4342 "F" gnus-article-followup-with-original
520aa572
SZ		 4343 "\C-hk" gnus-article-describe-key
4344 "\C-hc" gnus-article-describe-key-briefly
0b6799c3 4345 "\C-hb" gnus-article-describe-bindings
a8151ef7 4346
6ab2c7a8 4347 "e" gnus-article-read-summary-keys
a8151ef7
LMI		 4348 "\C-d" gnus-article-read-summary-keys
4349 "\M-*" gnus-article-read-summary-keys
4350 "\M-#" gnus-article-read-summary-keys
4351 "\M-^" gnus-article-read-summary-keys
4352 "\M-g" gnus-article-read-summary-keys)
4353
4354(substitute-key-definition
4355 'undefined 'gnus-article-read-summary-keys gnus-article-mode-map)
eec82323 4356
95838435
MB		 4357(gnus-define-keys (gnus-article-send-map "S" gnus-article-mode-map)
4358 "W" gnus-article-wide-reply-with-original)
4359(if (featurep 'xemacs)
4360 (set-keymap-default-binding gnus-article-send-map
4361 'gnus-article-read-summary-send-keys)
4362 (define-key gnus-article-send-map [t] 'gnus-article-read-summary-send-keys))
4363
eec82323 4364(defun gnus-article-make-menu-bar ()
23f87bed
MB		 4365 (unless (boundp 'gnus-article-commands-menu)
4366 (gnus-summary-make-menu-bar))
eec82323
LMI		 4367 (unless (boundp 'gnus-article-article-menu)
4368 (easy-menu-define
4369 gnus-article-article-menu gnus-article-mode-map ""
4370 '("Article"
4371 ["Scroll forwards" gnus-article-goto-next-page t]
4372 ["Scroll backwards" gnus-article-goto-prev-page t]
4373 ["Show summary" gnus-article-show-summary t]
4374 ["Fetch Message-ID at point" gnus-article-refer-article t]
6748645f
LMI		 4375 ["Mail to address at point" gnus-article-mail t]
4376 ["Send a bug report" gnus-bug t]))
eec82323
LMI		 4377
4378 (easy-menu-define
4379 gnus-article-treatment-menu gnus-article-mode-map ""
bb367cba 4380 ;; Fixme: this should use :active (and maybe :visible).
eec82323
LMI		 4381 '("Treatment"
4382 ["Hide headers" gnus-article-hide-headers t]
4383 ["Hide signature" gnus-article-hide-signature t]
4384 ["Hide citation" gnus-article-hide-citation t]
4385 ["Treat overstrike" gnus-article-treat-overstrike t]
01c52d31 4386 ["Treat ANSI sequences" gnus-article-treat-ansi-sequences t]
eec82323 4387 ["Remove carriage return" gnus-article-remove-cr t]
23f87bed 4388 ["Remove leading whitespace" gnus-article-remove-leading-whitespace t]
16409b0b
GM		 4389 ["Remove quoted-unreadable" gnus-article-de-quoted-unreadable t]
4390 ["Remove base64" gnus-article-de-base64-unreadable t]
4391 ["Treat html" gnus-article-wash-html t]
23f87bed 4392 ["Remove newlines from within URLs" gnus-article-unsplit-urls t]
16409b0b 4393 ["Decode HZ" gnus-article-decode-HZ t]))
eec82323 4394
6748645f 4395 ;; Note "Commands" menu is defined in gnus-sum.el for consistency
eec82323 4396
23f87bed 4397 ;; Note "Post" menu is defined in gnus-sum.el for consistency
eec82323 4398
6748645f 4399 (gnus-run-hooks 'gnus-article-menu-hook)))
eec82323 4400
8e7d4ca1
GM		 4401(defvar bookmark-make-record-function)
4402
eec82323
LMI		 4403(defun gnus-article-mode ()
4404 "Major mode for displaying an article.
4405
4406All normal editing commands are switched off.
4407
4408The following commands are available in addition to all summary mode
4409commands:
4410\\<gnus-article-mode-map>
4411\\[gnus-article-next-page]\t Scroll the article one page forwards
4412\\[gnus-article-prev-page]\t Scroll the article one page backwards
4413\\[gnus-article-refer-article]\t Go to the article referred to by an article id near point
4414\\[gnus-article-show-summary]\t Display the summary buffer
4415\\[gnus-article-mail]\t Send a reply to the address near point
4416\\[gnus-article-describe-briefly]\t Describe the current mode briefly
4417\\[gnus-info-find-node]\t Go to the Gnus info node"
4418 (interactive)
0eb586fc 4419 (kill-all-local-variables)
eec82323
LMI		 4420 (gnus-simplify-mode-line)
4421 (setq mode-name "Article")
4422 (setq major-mode 'gnus-article-mode)
4423 (make-local-variable 'minor-mode-alist)
eec82323 4424 (use-local-map gnus-article-mode-map)
1653df0f 4425 (when (gnus-visual-p 'article-menu 'menu)
23f87bed
MB		 4426 (gnus-article-make-menu-bar)
4427 (when gnus-summary-tool-bar-map
4428 (set (make-local-variable 'tool-bar-map) gnus-summary-tool-bar-map)))
eec82323
LMI		 4429 (gnus-update-format-specifications nil 'article-mode)
4430 (set (make-local-variable 'page-delimiter) gnus-page-delimiter)
23f87bed 4431 (set (make-local-variable 'gnus-page-broken) nil)
6748645f 4432 (make-local-variable 'gnus-article-current-summary)
16409b0b
GM		 4433 (make-local-variable 'gnus-article-mime-handles)
4434 (make-local-variable 'gnus-article-decoded-p)
4435 (make-local-variable 'gnus-article-mime-handle-alist)
4436 (make-local-variable 'gnus-article-wash-types)
23f87bed
MB		 4437 (make-local-variable 'gnus-article-image-alist)
4438 (make-local-variable 'gnus-article-charset)
4439 (make-local-variable 'gnus-article-ignored-charsets)
33b48483
KF		 4440 (set (make-local-variable 'bookmark-make-record-function)
4441 'gnus-summary-bookmark-make-record)
524705ae
MB		 4442 ;; Prevent Emacs 22 from displaying non-break space with `nobreak-space'
4443 ;; face.
fc1c32c1 4444 (set (make-local-variable 'nobreak-char-display) nil)
e4a89ccf 4445 (setq cursor-in-non-selected-windows nil)
eec82323 4446 (gnus-set-default-directory)
16409b0b 4447 (buffer-disable-undo)
01c52d31
MB		 4448 (setq buffer-read-only t
4449 show-trailing-whitespace nil)
eec82323 4450 (set-syntax-table gnus-article-mode-syntax-table)
16409b0b 4451 (mm-enable-multibyte)
cfcd5c91 4452 (gnus-run-mode-hooks 'gnus-article-mode-hook))
eec82323
LMI		 4453
4454(defun gnus-article-setup-buffer ()
4455 "Initialize the article buffer."
4456 (let* ((name (if gnus-single-article-buffer "*Article*"
4457 (concat "*Article " gnus-newsgroup-name "*")))
4458 (original
4459 (progn (string-match "\\*Article" name)
4460 (concat " *Original Article"
4461 (substring name (match-end 0))))))
4462 (setq gnus-article-buffer name)
4463 (setq gnus-original-article-buffer original)
16409b0b 4464 (setq gnus-article-mime-handle-alist nil)
01c52d31
MB		 4465 (with-current-buffer gnus-summary-buffer
4466 ;; This might be a variable local to the summary buffer.
4467 (unless gnus-single-article-buffer
eec82323
LMI		 4468 (setq gnus-article-buffer name)
4469 (setq gnus-original-article-buffer original)
4470 (gnus-set-global-variables)))
16409b0b 4471 (gnus-article-setup-highlight-words)
eec82323 4472 ;; Init original article buffer.
80de1778 4473 (with-current-buffer (gnus-get-buffer-create gnus-original-article-buffer)
16409b0b 4474 (mm-enable-multibyte)
eec82323 4475 (setq major-mode 'gnus-original-article-mode)
eec82323 4476 (make-local-variable 'gnus-original-article))
aba1948a
MB		 4477 (if (and (get-buffer name)
4478 (with-current-buffer name
4479 (if gnus-article-edit-mode
4480 (if (y-or-n-p "Article mode edit in progress; discard? ")
4481 (progn
4482 (set-buffer-modified-p nil)
4483 (gnus-kill-buffer name)
4484 (message "")
4485 nil)
4486 (error "Action aborted"))
4487 t)))
80de1778 4488 (with-current-buffer name
23f87bed 4489 (set (make-local-variable 'gnus-article-edit-mode) nil)
16409b0b
GM		 4490 (when gnus-article-mime-handles
4491 (mm-destroy-parts gnus-article-mime-handles)
4492 (setq gnus-article-mime-handles nil))
4493 ;; Set it to nil in article-buffer!
a1506d29 4494 (setq gnus-article-mime-handle-alist nil)
16409b0b 4495 (buffer-disable-undo)
eec82323 4496 (setq buffer-read-only t)
eec82323
LMI		 4497 (unless (eq major-mode 'gnus-article-mode)
4498 (gnus-article-mode))
030158f3 4499 (setq truncate-lines gnus-article-truncate-lines)
eec82323 4500 (current-buffer))
80de1778 4501 (with-current-buffer (gnus-get-buffer-create name)
eec82323 4502 (gnus-article-mode)
030158f3 4503 (setq truncate-lines gnus-article-truncate-lines)
eec82323 4504 (make-local-variable 'gnus-summary-buffer)
01c52d31
MB		 4505 (setq gnus-summary-buffer
4506 (gnus-summary-buffer-name gnus-newsgroup-name))
16409b0b 4507 (gnus-summary-set-local-parameters gnus-newsgroup-name)
12e3ca0a 4508 (when (and gnus-article-update-date-headers
647559c2 4509 (not article-lapsed-timer))
12e3ca0a 4510 (gnus-start-date-timer gnus-article-update-date-headers))
eec82323
LMI		 4511 (current-buffer)))))
4512
4513;; Set article window start at LINE, where LINE is the number of lines
4514;; from the head of the article.
4515(defun gnus-article-set-window-start (&optional line)
01c52d31
MB		 4516 (let ((article-window (gnus-get-buffer-window gnus-article-buffer t)))
4517 (when article-window
4518 (set-window-start
4519 article-window
80de1778 4520 (with-current-buffer gnus-article-buffer
01c52d31
MB		 4521 (goto-char (point-min))
4522 (if (not line)
4523 (point-min)
4524 (gnus-message 6 "Moved to bookmark")
4525 (search-forward "\n\n" nil t)
4526 (forward-line line)
4527 (point)))))))
eec82323
LMI		 4528
4529(defun gnus-article-prepare (article &optional all-headers header)
4530 "Prepare ARTICLE in article mode buffer.
4531ARTICLE should either be an article number or a Message-ID.
4532If ARTICLE is an id, HEADER should be the article headers.
4533If ALL-HEADERS is non-nil, no headers are hidden."
4534 (save-excursion
4535 ;; Make sure we start in a summary buffer.
4536 (unless (eq major-mode 'gnus-summary-mode)
4537 (set-buffer gnus-summary-buffer))
4538 (setq gnus-summary-buffer (current-buffer))
eec82323
LMI		 4539 (let* ((gnus-article (if header (mail-header-number header) article))
4540 (summary-buffer (current-buffer))
6748645f 4541 (gnus-tmp-internal-hook gnus-article-internal-prepare-hook)
eec82323
LMI		 4542 (group gnus-newsgroup-name)
4543 result)
4544 (save-excursion
4545 (gnus-article-setup-buffer)
4546 (set-buffer gnus-article-buffer)
4547 ;; Deactivate active regions.
4548 (when (and (boundp 'transient-mark-mode)
4549 transient-mark-mode)
4550 (setq mark-active nil))
4e7d0221 4551 (if (not (setq result (let ((inhibit-read-only t))
eec82323
LMI		 4552 (gnus-request-article-this-buffer
4553 article group))))
4554 ;; There is no such article.
4555 (save-excursion
4556 (when (and (numberp article)
4557 (not (memq article gnus-newsgroup-sparse)))
4558 (setq gnus-article-current
4559 (cons gnus-newsgroup-name article))
4560 (set-buffer gnus-summary-buffer)
4561 (setq gnus-current-article article)
23f87bed
MB		 4562 (if (and (memq article gnus-newsgroup-undownloaded)
4563 (not (gnus-online (gnus-find-method-for-group
4564 gnus-newsgroup-name))))
6748645f
LMI		 4565 (progn
4566 (gnus-summary-set-agent-mark article)
4567 (message "Message marked for downloading"))
4568 (gnus-summary-mark-article article gnus-canceled-mark)
4569 (unless (memq article gnus-newsgroup-sparse)
16409b0b 4570 (gnus-error 1 "No such article (may have expired or been canceled)")))))
6748645f
LMI		 4571 (if (or (eq result 'pseudo)
4572 (eq result 'nneething))
eec82323 4573 (progn
80de1778 4574 (with-current-buffer summary-buffer
6748645f 4575 (push article gnus-newsgroup-history)
eec82323 4576 (setq gnus-last-article gnus-current-article
eec82323
LMI		 4577 gnus-current-article 0
4578 gnus-current-headers nil
4579 gnus-article-current nil)
4580 (if (eq result 'nneething)
4581 (gnus-configure-windows 'summary)
4582 (gnus-configure-windows 'article))
4583 (gnus-set-global-variables))
16409b0b
GM		 4584 (let ((gnus-article-mime-handle-alist-1
4585 gnus-article-mime-handle-alist))
4586 (gnus-set-mode-line 'article)))
eec82323
LMI		 4587 ;; The result from the `request' was an actual article -
4588 ;; or at least some text that is now displayed in the
4589 ;; article buffer.
4590 (when (and (numberp article)
4591 (not (eq article gnus-current-article)))
4592 ;; Seems like a new article has been selected.
4593 ;; `gnus-current-article' must be an article number.
80de1778 4594 (with-current-buffer summary-buffer
6748645f 4595 (push article gnus-newsgroup-history)
eec82323 4596 (setq gnus-last-article gnus-current-article
eec82323
LMI		 4597 gnus-current-article article
4598 gnus-current-headers
4599 (gnus-summary-article-header gnus-current-article)
4600 gnus-article-current
4601 (cons gnus-newsgroup-name gnus-current-article))
4602 (unless (vectorp gnus-current-headers)
4603 (setq gnus-current-headers nil))
6748645f
LMI		 4604 (gnus-summary-goto-subject gnus-current-article)
4605 (when (gnus-summary-show-thread)
4606 ;; If the summary buffer really was folded, the
4607 ;; previous goto may not actually have gone to
4608 ;; the right article, but the thread root instead.
4609 ;; So we go again.
4610 (gnus-summary-goto-subject gnus-current-article))
4611 (gnus-run-hooks 'gnus-mark-article-hook)
eec82323
LMI		 4612 (gnus-set-mode-line 'summary)
4613 (when (gnus-visual-p 'article-highlight 'highlight)
6748645f 4614 (gnus-run-hooks 'gnus-visual-mark-article-hook))
eec82323 4615 ;; Set the global newsgroup variables here.
eec82323
LMI		 4616 (gnus-set-global-variables)
4617 (setq gnus-have-all-headers
6748645f 4618 (or all-headers gnus-show-all-headers))))
e0bad764
DL		 4619 (save-excursion
4620 (gnus-configure-windows 'article))
eec82323
LMI		 4621 (when (or (numberp article)
4622 (stringp article))
16409b0b 4623 (gnus-article-prepare-display)
eec82323
LMI		 4624 ;; Do page break.
4625 (goto-char (point-min))
23f87bed
MB		 4626 (when gnus-break-pages
4627 (gnus-narrow-to-page)))
16409b0b
GM		 4628 (let ((gnus-article-mime-handle-alist-1
4629 gnus-article-mime-handle-alist))
4630 (gnus-set-mode-line 'article))
4631 (article-goto-body)
23f87bed
MB		 4632 (unless (bobp)
4633 (forward-line -1))
6748645f 4634 (set-window-point (get-buffer-window (current-buffer)) (point))
16409b0b 4635 (gnus-configure-windows 'article)
eec82323
LMI		 4636 t))))))
4637
16409b0b
GM		 4638;;;###autoload
4639(defun gnus-article-prepare-display ()
4640 "Make the current buffer look like a nice article."
4641 ;; Hooks for getting information from the article.
4642 ;; This hook must be called before being narrowed.
4643 (let ((gnus-article-buffer (current-buffer))
23f87bed
MB		 4644 buffer-read-only
4645 (inhibit-read-only t))
16409b0b
GM		 4646 (unless (eq major-mode 'gnus-article-mode)
4647 (gnus-article-mode))
4648 (setq buffer-read-only nil
23f87bed
MB		 4649 gnus-article-wash-types nil
4650 gnus-article-image-alist nil)
16409b0b
GM		 4651 (gnus-run-hooks 'gnus-tmp-internal-hook)
4652 (when gnus-display-mime-function
4653 (funcall gnus-display-mime-function))
4654 (gnus-run-hooks 'gnus-article-prepare-hook)))
4655
01c52d31
MB		 4656;;;
4657;;; Gnus Sticky Article Mode
4658;;;
4659
4660(define-derived-mode gnus-sticky-article-mode gnus-article-mode "StickyArticle"
4661 "Mode for sticky articles."
4662 ;; Release bindings that won't work.
4663 (substitute-key-definition 'gnus-article-read-summary-keys 'undefined
4664 gnus-sticky-article-mode-map)
4665 (substitute-key-definition 'gnus-article-refer-article 'undefined
4666 gnus-sticky-article-mode-map)
4667 (dolist (k '("e" "h" "s" "F" "R"))
4668 (define-key gnus-sticky-article-mode-map k nil))
4669 (define-key gnus-sticky-article-mode-map "k" 'gnus-kill-sticky-article-buffer)
4670 (define-key gnus-sticky-article-mode-map "q" 'bury-buffer)
4671 (define-key gnus-sticky-article-mode-map "\C-hc" 'describe-key-briefly)
4672 (define-key gnus-sticky-article-mode-map "\C-hk" 'describe-key))
4673
4674(defun gnus-sticky-article (arg)
4675 "Make the current article sticky.
4676If a prefix ARG is given, ask for a name for this sticky article buffer."
4677 (interactive "P")
4678 (gnus-summary-show-thread)
4679 (gnus-summary-select-article nil nil 'pseudo)
4680 (let (new-art-buf-name)
4681 (gnus-eval-in-buffer-window gnus-article-buffer
4682 (setq new-art-buf-name
4683 (concat
4684 "*Sticky Article: "
4685 (if arg
4686 (read-from-minibuffer "Sticky article buffer name: ")
4687 (gnus-with-article-headers
4688 (gnus-article-goto-header "subject")
4689 (setq new-art-buf-name
4690 (buffer-substring-no-properties
4691 (line-beginning-position) (line-end-position)))
4692 (goto-char (point-min))
4693 (gnus-article-goto-header "from")
4694 (setq new-art-buf-name
4695 (concat
4696 new-art-buf-name ", "
4697 (buffer-substring-no-properties
4698 (line-beginning-position) (line-end-position))))
4699 (goto-char (point-min))
4700 (gnus-article-goto-header "date")
4701 (setq new-art-buf-name
4702 (concat
4703 new-art-buf-name ", "
4704 (buffer-substring-no-properties
4705 (line-beginning-position) (line-end-position))))))
4706 "*"))
4707 (if (and (gnus-buffer-live-p new-art-buf-name)
4708 (with-current-buffer new-art-buf-name
4709 (eq major-mode 'gnus-sticky-article-mode)))
4710 (switch-to-buffer new-art-buf-name)
4711 (setq new-art-buf-name (rename-buffer new-art-buf-name t)))
4712 (gnus-sticky-article-mode))
4713 (setq gnus-article-buffer new-art-buf-name))
4714 (gnus-summary-recenter)
4715 (gnus-summary-position-point))
4716
4717(defun gnus-kill-sticky-article-buffer (&optional buffer)
4718 "Kill the given sticky article BUFFER.
4719If none is given, assume the current buffer and kill it if it has
4720`gnus-sticky-article-mode'."
4721 (interactive)
4722 (unless buffer
4723 (setq buffer (current-buffer)))
4724 (with-current-buffer buffer
4725 (when (eq major-mode 'gnus-sticky-article-mode)
4726 (gnus-kill-buffer buffer))))
4727
4728(defun gnus-kill-sticky-article-buffers (arg)
4729 "Kill all sticky article buffers.
4730If a prefix ARG is given, ask for confirmation."
4731 (interactive "P")
4732 (dolist (buf (gnus-buffers))
4733 (with-current-buffer buf
4734 (when (eq major-mode 'gnus-sticky-article-mode)
4735 (if (not arg)
4736 (gnus-kill-buffer buf)
4737 (when (yes-or-no-p (concat "Kill buffer " (buffer-name buf) "? "))
4738 (gnus-kill-buffer buf)))))))
4739
16409b0b
GM		 4740;;;
4741;;; Gnus MIME viewing functions
4742;;;
4743
4744(defvar gnus-mime-button-line-format "%{%([%p. %d%T]%)%}%e\n"
23f87bed
MB		 4745 "Format of the MIME buttons.
4746
4747Valid specifiers include:
16409b0b
GM		 4748%t The MIME type
4749%T MIME type, along with additional info
4750%n The `name' parameter
4751%d The description, if any
4752%l The length of the encoded part
4753%p The part identifier number
23f87bed
MB		 4754%e Dots if the part isn't displayed
4755
4756General format specifiers can also be used. See Info node
4757`(gnus)Formatting Variables'.")
16409b0b
GM		 4758
4759(defvar gnus-mime-button-line-format-alist
4760 '((?t gnus-tmp-type ?s)
4761 (?T gnus-tmp-type-long ?s)
4762 (?n gnus-tmp-name ?s)
4763 (?d gnus-tmp-description ?s)
4764 (?p gnus-tmp-id ?s)
4765 (?l gnus-tmp-length ?d)
4766 (?e gnus-tmp-dots ?s)))
4767
4768(defvar gnus-mime-button-commands
4769 '((gnus-article-press-button "\r" "Toggle Display")
4770 (gnus-mime-view-part "v" "View Interactively...")
4771 (gnus-mime-view-part-as-type "t" "View As Type...")
23f87bed 4772 (gnus-mime-view-part-as-charset "C" "View As charset...")
16409b0b 4773 (gnus-mime-save-part "o" "Save...")
23f87bed 4774 (gnus-mime-save-part-and-strip "\C-o" "Save and Strip")
01c52d31 4775 (gnus-mime-replace-part "r" "Replace part")
23f87bed 4776 (gnus-mime-delete-part "d" "Delete part")
16409b0b
GM		 4777 (gnus-mime-copy-part "c" "View As Text, In Other Buffer")
4778 (gnus-mime-inline-part "i" "View As Text, In This Buffer")
01c52d31 4779 (gnus-mime-view-part-internally "E" "View Internally") ;; Why `E'?
23f87bed
MB		 4780 (gnus-mime-view-part-externally "e" "View Externally")
4781 (gnus-mime-print-part "p" "Print")
e0bad764 4782 (gnus-mime-pipe-part "|" "Pipe To Command...")
23f87bed 4783 (gnus-mime-action-on-part "." "Take action on the part...")))
16409b0b
GM		 4784
4785(defun gnus-article-mime-part-status ()
4786 (if gnus-article-mime-handle-alist-1
23f87bed
MB		 4787 (if (eq 1 (length gnus-article-mime-handle-alist-1))
4788 " (1 part)"
4789 (format " (%d parts)" (length gnus-article-mime-handle-alist-1)))
16409b0b
GM		 4790 ""))
4791
4792(defvar gnus-mime-button-map
4793 (let ((map (make-sparse-keymap)))
16409b0b
GM		 4794 (define-key map gnus-mouse-2 'gnus-article-push-button)
4795 (define-key map gnus-down-mouse-3 'gnus-mime-button-menu)
4796 (dolist (c gnus-mime-button-commands)
4797 (define-key map (cadr c) (car c)))
4798 map))
4799
23f87bed
MB		 4800(easy-menu-define
4801 gnus-mime-button-menu gnus-mime-button-map "MIME button menu."
4802 `("MIME Part"
4803 ,@(mapcar (lambda (c)
01c52d31 4804 (vector (caddr c) (car c) :active t))
23f87bed
MB		 4805 gnus-mime-button-commands)))
4806
7426b4f7
LMI		 4807(defvar gnus-url-button-commands
4808 '((gnus-article-copy-string "u" "Copy URL to kill ring")))
4809
4810(defvar gnus-url-button-map
4811 (let ((map (make-sparse-keymap)))
4812 (dolist (c gnus-url-button-commands)
4813 (define-key map (cadr c) (car c)))
4814 map))
4815
4816(easy-menu-define
4817 gnus-url-button-menu gnus-url-button-map "URL button menu."
4818 `("Url Button"
4819 ,@(mapcar (lambda (c)
4820 (vector (caddr c) (car c) :active t))
4821 gnus-url-button-commands)))
4822
b0b63450
MB		 4823(defmacro gnus-bind-safe-url-regexp (&rest body)
4824 "Bind `mm-w3m-safe-url-regexp' according to `gnus-safe-html-newsgroups'."
4825 `(let ((mm-w3m-safe-url-regexp
4826 (let ((group (if (and (eq major-mode 'gnus-article-mode)
4827 (gnus-buffer-live-p
4828 gnus-article-current-summary))
4829 (with-current-buffer gnus-article-current-summary
4830 gnus-newsgroup-name)
4831 gnus-newsgroup-name)))
7cab80f9
KY		 4832 (if (cond ((not group)
4833 ;; Maybe we're in a mml-preview buffer
4834 ;; and no group is selected.
4835 t)
4836 ((stringp gnus-safe-html-newsgroups)
b0b63450
MB		 4837 (string-match gnus-safe-html-newsgroups group))
4838 ((consp gnus-safe-html-newsgroups)
4839 (member group gnus-safe-html-newsgroups)))
4840 nil
4841 mm-w3m-safe-url-regexp))))
4842 ,@body))
4843
23f87bed
MB		 4844(defun gnus-mime-button-menu (event prefix)
4845 "Construct a context-sensitive menu of MIME commands."
4846 (interactive "e\nP")
4847 (save-window-excursion
4848 (let ((pos (event-start event)))
4849 (select-window (posn-window pos))
4850 (goto-char (posn-point pos))
4851 (gnus-article-check-buffer)
4852 (popup-menu gnus-mime-button-menu nil prefix))))
16409b0b
GM		 4853
4854(defun gnus-mime-view-all-parts (&optional handles)
4855 "View all the MIME parts."
4856 (interactive)
01c52d31 4857 (with-current-buffer gnus-article-buffer
16409b0b
GM		 4858 (let ((handles (or handles gnus-article-mime-handles))
4859 (mail-parse-charset gnus-newsgroup-charset)
a1506d29 4860 (mail-parse-ignored-charsets
23f87bed
MB		 4861 (with-current-buffer gnus-summary-buffer
4862 gnus-newsgroup-ignored-charsets)))
4863 (when handles
4864 (mm-remove-parts handles)
4865 (goto-char (point-min))
4866 (or (search-forward "\n\n") (goto-char (point-max)))
4867 (let ((inhibit-read-only t))
4868 (delete-region (point) (point-max))
b0b63450 4869 (gnus-bind-safe-url-regexp (mm-display-parts handles)))))))
23f87bed 4870
01c52d31
MB		 4871(defun gnus-article-jump-to-part (n)
4872 "Jump to MIME part N."
4873 (interactive "P")
a87ee50b
KY		 4874 (let ((parts (with-current-buffer gnus-article-buffer
4875 (length gnus-article-mime-handle-alist))))
4876 (when (zerop parts)
4877 (error "No such part"))
4878 (pop-to-buffer gnus-article-buffer)
4879 ;; FIXME: why is it necessary?
4880 (sit-for 0)
4881 (or n
4882 (setq n (if (= parts 1)
4883 1
4884 (read-number (format "Jump to part (1..%s): " parts)))))
01c52d31
MB		 4885 (unless (and (integerp n) (<= n parts) (>= n 1))
4886 (setq n
4887 (progn
4888 (gnus-message 7 "Invalid part `%s', using %s instead."
4889 n parts)
4890 parts)))
4891 (gnus-message 9 "Jumping to part %s." n)
4892 (cond ((>= gnus-auto-select-part 1)
4893 (while (and (<= n parts)
4894 (not (gnus-article-goto-part n)))
4895 (setq n (1+ n))))
4896 ((< gnus-auto-select-part 0)
4897 (while (and (>= n 1)
4898 (not (gnus-article-goto-part n)))
4899 (setq n (1- n))))
4900 (t
4901 (gnus-article-goto-part n)))))
4902
3e3ab3ab
KY		 4903(defvar gnus-mime-buttonized-part-id nil
4904 "ID of a mime part that should be buttonized.
4905`gnus-mime-save-part-and-strip' and `gnus-mime-delete-part' bind it.")
4906
01c52d31
MB		 4907(eval-when-compile
4908 (defsubst gnus-article-edit-part (handles &optional current-id)
4909 "Edit an article in order to delete a mime part.
4910This function is exclusively used by `gnus-mime-save-part-and-strip'
4911and `gnus-mime-delete-part', and not provided at run-time normally."
4912 (gnus-article-edit-article
4913 `(lambda ()
4914 (buffer-disable-undo)
4915 (erase-buffer)
4916 (let ((mail-parse-charset (or gnus-article-charset
4917 ',gnus-newsgroup-charset))
4918 (mail-parse-ignored-charsets
4919 (or gnus-article-ignored-charsets
4920 ',gnus-newsgroup-ignored-charsets))
4921 (mbl mml-buffer-list))
4922 (setq mml-buffer-list nil)
4923 (insert-buffer-substring gnus-original-article-buffer)
4924 (mime-to-mml ',handles)
4925 (setq gnus-article-mime-handles nil)
4926 (let ((mbl1 mml-buffer-list))
4927 (setq mml-buffer-list mbl)
4928 (set (make-local-variable 'mml-buffer-list) mbl1))
4929 (gnus-make-local-hook 'kill-buffer-hook)
4930 (add-hook 'kill-buffer-hook 'mml-destroy-buffers t t)))
4931 `(lambda (no-highlight)
4932 (let ((mail-parse-charset (or gnus-article-charset
4933 ',gnus-newsgroup-charset))
4934 (message-options message-options)
4935 (message-options-set-recipient)
4936 (mail-parse-ignored-charsets
4937 (or gnus-article-ignored-charsets
4938 ',gnus-newsgroup-ignored-charsets)))
4939 (mml-to-mime)
4940 (mml-destroy-buffers)
4941 (remove-hook 'kill-buffer-hook
4942 'mml-destroy-buffers t)
4943 (kill-local-variable 'mml-buffer-list))
4944 (gnus-summary-edit-article-done
4945 ,(or (mail-header-references gnus-current-headers) "")
4946 ,(gnus-group-read-only-p)
4947 ,gnus-summary-buffer no-highlight))
4948 t)
3e3ab3ab
KY		 4949 ;; Force buttonizing this part.
4950 (let ((gnus-mime-buttonized-part-id current-id))
4951 (gnus-article-edit-done))
54c72c31 4952 (gnus-configure-windows 'article)
01c52d31 4953 (when (and current-id (integerp gnus-auto-select-part))
3e3ab3ab
KY		 4954 (gnus-article-jump-to-part
4955 (min (max (+ current-id gnus-auto-select-part) 1)
4956 (with-current-buffer gnus-article-buffer
4957 (length gnus-article-mime-handle-alist)))))))
01c52d31
MB		 4958
4959(defun gnus-mime-replace-part (file)
4960 "Replace MIME part under point with an external body."
4961 ;; Useful if file has already been saved to disk
4962 (interactive
4963 (list
75eda25b
SM		 4964 (read-file-name "Replace MIME part with file: "
4965 (or mm-default-directory default-directory)
4966 nil nil)))
01c52d31
MB		 4967 (gnus-mime-save-part-and-strip file))
4968
4969(defun gnus-mime-save-part-and-strip (&optional file)
4970 "Save the MIME part under point then replace it with an external body.
4971If FILE is given, use it for the external part."
23f87bed
MB		 4972 (interactive)
4973 (gnus-article-check-buffer)
4974 (when (gnus-group-read-only-p)
4975 (error "The current group does not support deleting of parts"))
4976 (when (mm-complicated-handles gnus-article-mime-handles)
4977 (error "\
4978The current article has a complicated MIME structure, giving up..."))
01c52d31
MB		 4979 (let* ((data (get-text-property (point) 'gnus-data))
4980 (id (get-text-property (point) 'gnus-part))
4981 param
4982 (handles gnus-article-mime-handles))
4983 (unless file
4984 (setq file
4985 (and data (mm-save-part data "Delete MIME part and save to: "))))
4986 (when file
4987 (with-current-buffer (mm-handle-buffer data)
4988 (erase-buffer)
4989 (insert "Content-Type: " (mm-handle-media-type data))
4990 (mml-insert-parameter-string (cdr (mm-handle-type data))
4991 '(charset))
4992 ;; Add a filename for the sake of saving the part again.
4993 (mml-insert-parameter
4994 (mail-header-encode-parameter "name" (file-name-nondirectory file)))
4995 (insert "\n")
4996 (insert "Content-ID: " (message-make-message-id) "\n")
4997 (insert "Content-Transfer-Encoding: binary\n")
4998 (insert "\n"))
4999 (setcdr data
5000 (cdr (mm-make-handle nil
5001 `("message/external-body"
5002 (access-type . "LOCAL-FILE")
5003 (name . ,file)))))
5004 ;; (set-buffer gnus-summary-buffer)
5005 (gnus-article-edit-part handles id))))
5006
5007;; A function like `gnus-summary-save-parts' (`X m', `<MIME> <Extract all
5008;; parts...>') but with stripping would be nice.
23f87bed
MB		 5009
5010(defun gnus-mime-delete-part ()
5011 "Delete the MIME part under point.
5012Replace it with some information about the removed part."
5013 (interactive)
5014 (gnus-article-check-buffer)
5015 (when (gnus-group-read-only-p)
5016 (error "The current group does not support deleting of parts"))
5017 (when (mm-complicated-handles gnus-article-mime-handles)
5018 (error "\
5019The current article has a complicated MIME structure, giving up..."))
01c52d31
MB		 5020 (when (or gnus-expert-user
5021 (gnus-yes-or-no-p "\
5022Deleting parts may malfunction or destroy the article; continue? "))
23f87bed 5023 (let* ((data (get-text-property (point) 'gnus-data))
01c52d31 5024 (id (get-text-property (point) 'gnus-part))
23f87bed
MB		 5025 (handles gnus-article-mime-handles)
5026 (none "(none)")
5027 (description
bbbe940b
MB		 5028 (let ((desc (mm-handle-description data)))
5029 (when desc
5030 (mail-decode-encoded-word-string desc))))
23f87bed
MB		 5031 (filename
5032 (or (mail-content-type-get (mm-handle-disposition data) 'filename)
5033 none))
5034 (type (mm-handle-media-type data)))
5035 (unless data
5036 (error "No MIME part under point"))
5037 (with-current-buffer (mm-handle-buffer data)
e5fa3899 5038 (let ((bsize (buffer-size)))
23f87bed
MB		 5039 (erase-buffer)
5040 (insert
5041 (concat
5042 ",----\n"
5043 "| The following attachment has been deleted:\n"
5044 "|\n"
5045 "| Type: " type "\n"
5046 "| Filename: " filename "\n"
e5fa3899
KY		 5047 "| Size (encoded): " (format "%s byte%s\n"
5048 bsize (if (= bsize 1)
8ccbef23
G		 5049 ""
5050 "s"))
bbbe940b
MB		 5051 (when description
5052 (concat "| Description: " description "\n"))
23f87bed
MB		 5053 "`----\n"))
5054 (setcdr data
5055 (cdr (mm-make-handle
0cf681b6 5056 nil `("text/plain" (charset . gnus-decoded)) nil nil
23f87bed
MB		 5057 (list "attachment")
5058 (format "Deleted attachment (%s bytes)" bsize))))))
01c52d31
MB		 5059 ;; (set-buffer gnus-summary-buffer)
5060 (gnus-article-edit-part handles id))))
16409b0b
GM		 5061
5062(defun gnus-mime-save-part ()
5063 "Save the MIME part under point."
5064 (interactive)
5065 (gnus-article-check-buffer)
5066 (let ((data (get-text-property (point) 'gnus-data)))
23f87bed
MB		 5067 (when data
5068 (mm-save-part data))))
16409b0b 5069
9581ba4d
KY		 5070(defun gnus-mime-pipe-part (&optional cmd)
5071 "Pipe the MIME part under point to a process.
5072Use CMD as the process."
16409b0b
GM		 5073 (interactive)
5074 (gnus-article-check-buffer)
5075 (let ((data (get-text-property (point) 'gnus-data)))
23f87bed 5076 (when data
9581ba4d 5077 (mm-pipe-part data cmd))))
16409b0b
GM		 5078
5079(defun gnus-mime-view-part ()
5080 "Interactively choose a viewing method for the MIME part under point."
5081 (interactive)
5082 (gnus-article-check-buffer)
5083 (let ((data (get-text-property (point) 'gnus-data)))
23f87bed
MB		 5084 (when data
5085 (setq gnus-article-mime-handles
5086 (mm-merge-handles
5087 gnus-article-mime-handles (setq data (copy-sequence data))))
5088 (mm-interactively-view-part data))))
16409b0b
GM		 5089
5090(defun gnus-mime-view-part-as-type-internal ()
5091 (gnus-article-check-buffer)
54e573e6
MB		 5092 (let* ((handle (get-text-property (point) 'gnus-data))
5093 (name (or
5094 ;; Content-Type: foo/bar; name=...
5095 (mail-content-type-get (mm-handle-type handle) 'name)
5096 ;; Content-Disposition: attachment; filename=...
5097 (cdr (assq 'filename (cdr (mm-handle-disposition handle))))))
16409b0b 5098 (def-type (and name (mm-default-file-encoding name))))
01c52d31
MB		 5099 (or (and def-type (cons def-type 0))
5100 (and handle
5101 (equal (mm-handle-media-supertype handle) "text")
5102 '("text/plain" . 0))
5103 '("application/octet-stream" . 0))))
16409b0b 5104
54e573e6
MB		 5105(defun gnus-mime-view-part-as-type (&optional mime-type pred)
5106 "Choose a MIME media type, and view the part as such.
5107If non-nil, PRED is a predicate to use during completion to limit the
5108available media-types."
23f87bed
MB		 5109 (interactive)
5110 (unless mime-type
54e573e6
MB		 5111 (setq mime-type
5112 (let ((default (gnus-mime-view-part-as-type-internal)))
229b59da
G		 5113 (gnus-completing-read
5114 "View as MIME type"
568f71a8
KY		 5115 (if pred
5116 (gnus-remove-if-not pred (mailcap-mime-types))
5117 (mailcap-mime-types))
229b59da 5118 nil nil nil
54e573e6 5119 (car default)))))
16409b0b
GM		 5120 (gnus-article-check-buffer)
5121 (let ((handle (get-text-property (point) 'gnus-data)))
23f87bed 5122 (when handle
531bedc3
MB		 5123 (when (equal (mm-handle-media-type handle) "message/external-body")
5124 (unless (mm-handle-cache handle)
5125 (mm-extern-cache-contents handle))
5126 (setq handle (mm-handle-cache handle)))
23f87bed
MB		 5127 (setq handle
5128 (mm-make-handle (mm-handle-buffer handle)
5129 (cons mime-type (cdr (mm-handle-type handle)))
5130 (mm-handle-encoding handle)
5131 (mm-handle-undisplayer handle)
5132 (mm-handle-disposition handle)
5133 (mm-handle-description handle)
5134 nil
5135 (mm-handle-id handle)))
5136 (setq gnus-article-mime-handles
5137 (mm-merge-handles gnus-article-mime-handles handle))
01c52d31
MB		 5138 (when (mm-handle-displayed-p handle)
5139 (mm-remove-part handle))
23f87bed
MB		 5140 (gnus-mm-display-part handle))))
5141
01c52d31 5142(defun gnus-mime-copy-part (&optional handle arg)
23f87bed
MB		 5143 "Put the MIME part under point into a new buffer.
5144If `auto-compression-mode' is enabled, compressed files like .gz and .bz2
5145are decompressed."
01c52d31 5146 (interactive (list nil current-prefix-arg))
16409b0b 5147 (gnus-article-check-buffer)
01c52d31
MB		 5148 (unless handle
5149 (setq handle (get-text-property (point) 'gnus-data)))
5150 (when handle
5151 (let ((filename (or (mail-content-type-get (mm-handle-type handle)
5152 'name)
5153 (mail-content-type-get (mm-handle-disposition handle)
5154 'filename)))
5155 contents dont-decode charset coding-system)
5156 (mm-with-unibyte-buffer
5157 (mm-insert-part handle)
5158 (setq contents (or (condition-case nil
5159 (mm-decompress-buffer filename nil 'sig)
5160 (error
5161 (setq dont-decode t)
5162 nil))
5163 (buffer-string))))
5164 (setq filename (cond (filename (file-name-nondirectory filename))
5165 (dont-decode "*raw data*")
5166 (t "*decoded*")))
5167 (cond
5168 (dont-decode)
5169 ((not arg)
5170 (unless (setq charset (mail-content-type-get
5171 (mm-handle-type handle) 'charset))
5172 (unless (setq coding-system (mm-with-unibyte-buffer
5173 (insert contents)
5174 (mm-find-buffer-file-coding-system)))
5175 (setq charset gnus-newsgroup-charset))))
5176 ((numberp arg)
5177 (setq charset (or (cdr (assq arg
5178 gnus-summary-show-article-charset-alist))
5179 (mm-read-coding-system "Charset: ")))))
5180 (switch-to-buffer (generate-new-buffer filename))
5181 (if (or coding-system
5182 (and charset
5183 (setq coding-system (mm-charset-to-coding-system charset))
a87ee50b 5184 (not (eq coding-system 'ascii))))
01c52d31
MB		 5185 (progn
5186 (mm-enable-multibyte)
5187 (insert (mm-decode-coding-string contents coding-system))
5188 (setq buffer-file-coding-system
5189 (if (boundp 'last-coding-system-used)
5190 (symbol-value 'last-coding-system-used)
5191 coding-system)))
5192 (mm-disable-multibyte)
5193 (insert contents)
5194 (setq buffer-file-coding-system mm-binary-coding-system))
23f87bed
MB		 5195 ;; We do it this way to make `normal-mode' set the appropriate mode.
5196 (unwind-protect
5197 (progn
01c52d31 5198 (setq buffer-file-name (expand-file-name filename))
23f87bed
MB		 5199 (normal-mode))
5200 (setq buffer-file-name nil))
5201 (goto-char (point-min)))))
5202
5203(defun gnus-mime-print-part (&optional handle filename)
5204 "Print the MIME part under point."
5205 (interactive (list nil (ps-print-preprint current-prefix-arg)))
5206 (gnus-article-check-buffer)
5207 (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
5208 (contents (and handle (mm-get-part handle)))
5209 (file (mm-make-temp-file (expand-file-name "mm." mm-tmp-directory)))
5210 (printer (mailcap-mime-info (mm-handle-media-type handle) "print")))
5211 (when contents
5212 (if printer
5213 (unwind-protect
5214 (progn
5215 (mm-save-part-to-file handle file)
5216 (call-process shell-file-name nil
5217 (generate-new-buffer " *mm*")
5218 nil
5219 shell-command-switch
5220 (mm-mailcap-command
5221 printer file (mm-handle-type handle))))
5222 (delete-file file))
5223 (with-temp-buffer
5224 (insert contents)
5225 (gnus-print-buffer))
5226 (ps-despool filename)))))
16409b0b 5227
e0bad764 5228(defun gnus-mime-inline-part (&optional handle arg)
01c52d31
MB		 5229 "Insert the MIME part under point into the current buffer.
5230Compressed files like .gz and .bz2 are decompressed."
e0bad764 5231 (interactive (list nil current-prefix-arg))
16409b0b 5232 (gnus-article-check-buffer)
01c52d31
MB		 5233 (unless handle
5234 (setq handle (get-text-property (point) 'gnus-data)))
5235 (when handle
5236 (let ((b (point))
5237 (inhibit-read-only t)
5238 contents charset coding-system)
23f87bed
MB		 5239 (if (and (not arg) (mm-handle-undisplayer handle))
5240 (mm-remove-part handle)
01c52d31
MB		 5241 (mm-with-unibyte-buffer
5242 (mm-insert-part handle)
5243 (setq contents
5244 (or (mm-decompress-buffer
5245 (or (mail-content-type-get (mm-handle-type handle)
5246 'name)
5247 (mail-content-type-get (mm-handle-disposition handle)
5248 'filename))
5249 nil t)
5250 (buffer-string))))
23f87bed
MB		 5251 (cond
5252 ((not arg)
01c52d31
MB		 5253 (unless (setq charset (mail-content-type-get
5254 (mm-handle-type handle) 'charset))
5255 (unless (setq coding-system
5256 (mm-with-unibyte-buffer
5257 (insert contents)
5258 (mm-find-buffer-file-coding-system)))
5259 (setq charset gnus-newsgroup-charset))))
23f87bed
MB		 5260 ((numberp arg)
5261 (if (mm-handle-undisplayer handle)
5262 (mm-remove-part handle))
5263 (setq charset
5264 (or (cdr (assq arg
5265 gnus-summary-show-article-charset-alist))
56c30d72
MB		 5266 (mm-read-coding-system "Charset: "))))
5267 (t
5268 (if (mm-handle-undisplayer handle)
850c333d 5269 (mm-remove-part handle))))
23f87bed 5270 (forward-line 2)
6e3165fb 5271 (mm-display-inline handle)
23f87bed
MB		 5272 (goto-char b)))))
5273
c0ccb0d6
KY		 5274(defun gnus-mime-set-charset-parameters (handle charset)
5275 "Set CHARSET to parameters in HANDLE.
5276CHARSET may either be a string or a symbol."
5277 (unless (stringp charset)
5278 (setq charset (symbol-name charset)))
6b554e88 5279 (if (stringp (car handle))
c0ccb0d6
KY		 5280 (dolist (h (cdr handle))
5281 (gnus-mime-set-charset-parameters h charset))
6b554e88
MB		 5282 (let* ((type (mm-handle-type (if (equal (mm-handle-media-type handle)
5283 "message/external-body")
5284 (progn
5285 (unless (mm-handle-cache handle)
5286 (mm-extern-cache-contents handle))
5287 (mm-handle-cache handle))
5288 handle)))
c0ccb0d6
KY		 5289 (param (assq 'charset (cdr type))))
5290 (if param
5291 (setcdr param charset)
5292 (setcdr type (cons (cons 'charset charset) (cdr type)))))))
6b554e88 5293
23f87bed
MB		 5294(defun gnus-mime-view-part-as-charset (&optional handle arg)
5295 "Insert the MIME part under point into the current buffer using the
5296specified charset."
5297 (interactive (list nil current-prefix-arg))
5298 (gnus-article-check-buffer)
163cb72d
MB		 5299 (let ((handle (or handle (get-text-property (point) 'gnus-data)))
5300 (fun (get-text-property (point) 'gnus-callback))
5301 (gnus-newsgroup-ignored-charsets 'gnus-all)
c0ccb0d6 5302 charset form preferred parts)
23f87bed 5303 (when handle
01c52d31
MB		 5304 (when (prog1
5305 (and fun
c0ccb0d6 5306 (setq charset
01c52d31
MB		 5307 (or (cdr (assq
5308 arg
5309 gnus-summary-show-article-charset-alist))
5310 (mm-read-coding-system "Charset: "))))
5311 (if (mm-handle-undisplayer handle)
5312 (mm-remove-part handle)))
c0ccb0d6 5313 (gnus-mime-set-charset-parameters handle charset)
6b554e88
MB		 5314 (when (and (consp (setq form (cdr-safe fun)))
5315 (setq form (ignore-errors
5316 (assq 'gnus-mime-display-alternative form)))
5317 (setq preferred (caddr form))
5318 (progn
5319 (when (eq (car preferred) 'quote)
5320 (setq preferred (cadr preferred)))
5321 (not (equal preferred
5322 (get-text-property (point) 'gnus-data))))
5323 (setq parts (get-text-property (point) 'gnus-part))
5324 (setq parts (cdr (assq parts
5325 gnus-article-mime-handle-alist)))
5326 (equal (mm-handle-media-type parts) "multipart/alternative")
5327 (setq parts (reverse (cdr parts))))
5328 (setcar (cddr form)
5329 (list 'quote (or (cadr (member preferred parts))
5330 (car parts)))))
163cb72d 5331 (funcall fun handle)))))
23f87bed
MB		 5332
5333(defun gnus-mime-view-part-externally (&optional handle)
16409b0b
GM		 5334 "View the MIME part under point with an external viewer."
5335 (interactive)
5336 (gnus-article-check-buffer)
5337 (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
5338 (mm-user-display-methods nil)
5339 (mm-inlined-types nil)
5340 (mail-parse-charset gnus-newsgroup-charset)
a1506d29 5341 (mail-parse-ignored-charsets
54e573e6
MB		 5342 (with-current-buffer gnus-summary-buffer
5343 gnus-newsgroup-ignored-charsets))
5344 (type (mm-handle-media-type handle))
5345 (method (mailcap-mime-info type))
5346 (mm-enable-external t))
5347 (if (not (stringp method))
5348 (gnus-mime-view-part-as-type
f7aa0b8f 5349 nil (lambda (type) (stringp (mailcap-mime-info type))))
54e573e6 5350 (when handle
a87ee50b 5351 (mm-display-part handle nil t)))))
16409b0b 5352
23f87bed 5353(defun gnus-mime-view-part-internally (&optional handle)
16409b0b 5354 "View the MIME part under point with an internal viewer.
23f87bed 5355If no internal viewer is available, use an external viewer."
16409b0b
GM		 5356 (interactive)
5357 (gnus-article-check-buffer)
5358 (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
5359 (mm-inlined-types '(".*"))
5360 (mm-inline-large-images t)
5361 (mail-parse-charset gnus-newsgroup-charset)
a1506d29 5362 (mail-parse-ignored-charsets
54e573e6
MB		 5363 (with-current-buffer gnus-summary-buffer
5364 gnus-newsgroup-ignored-charsets))
23f87bed 5365 (inhibit-read-only t))
54e573e6
MB		 5366 (if (not (mm-inlinable-p handle))
5367 (gnus-mime-view-part-as-type
f7aa0b8f 5368 nil (lambda (type) (mm-inlinable-p handle type)))
54e573e6 5369 (when handle
a87ee50b 5370 (gnus-bind-safe-url-regexp (mm-display-part handle))))))
16409b0b 5371
e0bad764
DL		 5372(defun gnus-mime-action-on-part (&optional action)
5373 "Do something with the MIME attachment at \(point\)."
5374 (interactive
229b59da 5375 (list (gnus-completing-read "Action" (mapcar 'car gnus-mime-action-alist) t)))
e0bad764
DL		 5376 (gnus-article-check-buffer)
5377 (let ((action-pair (assoc action gnus-mime-action-alist)))
5378 (if action-pair
5379 (funcall (cdr action-pair)))))
5380
01c52d31
MB		 5381(defun gnus-article-part-wrapper (n function &optional no-handle interactive)
5382 "Call FUNCTION on MIME part N.
5383Unless NO-HANDLE, call FUNCTION with N-th MIME handle as it's only argument.
5384If INTERACTIVE, call FUNCTION interactivly."
5385 (let (window frame)
5386 ;; Check whether the article is displayed.
5387 (unless (and (gnus-buffer-live-p gnus-article-buffer)
5388 (setq window (get-buffer-window gnus-article-buffer t))
5389 (frame-visible-p (setq frame (window-frame window))))
5390 (error "No article is displayed"))
5391 (with-current-buffer gnus-article-buffer
5392 ;; Check whether the article displays the right contents.
5393 (unless (with-current-buffer gnus-summary-buffer
5394 (eq gnus-current-article (gnus-summary-article-number)))
5395 (error "You should select the right article first"))
5396 (if n
5397 (setq n (prefix-numeric-value n))
5398 (let ((pt (point)))
5399 (setq n (or (get-text-property pt 'gnus-part)
5400 (and (not (bobp))
5401 (get-text-property (1- pt) 'gnus-part))
5402 (get-text-property (prog2
5403 (forward-line 1)
5404 (point)
5405 (goto-char pt))
5406 'gnus-part)
5407 (get-text-property
5408 (or (and (setq pt (previous-single-property-change
5409 pt 'gnus-part))
5410 (1- pt))
5411 (next-single-property-change (point) 'gnus-part)
5412 (point))
5413 'gnus-part)
5414 1))))
5415 ;; Check whether the specified part exists.
5416 (when (> n (length gnus-article-mime-handle-alist))
5417 (error "No such part")))
5418 (unless
5419 (progn
5420 ;; To select the window is needed so that the cursor
5421 ;; might be visible on the MIME button.
5422 (select-window (prog1
5423 window
5424 (setq window (selected-window))
5425 ;; Article may be displayed in the other frame.
5426 (gnus-select-frame-set-input-focus
5427 (prog1
5428 frame
5429 (setq frame (selected-frame))))))
5430 (when (gnus-article-goto-part n)
5431 ;; We point the cursor and the arrow at the MIME button
5432 ;; when the `function' prompt the user for something.
a87ee50b
KY		 5433 (unless (and (pos-visible-in-window-p)
5434 (> (count-lines (point) (window-end))
5435 (/ (1- (window-height)) 3)))
5436 (recenter (/ (1- (window-height)) 3)))
01c52d31
MB		 5437 (let ((cursor-in-non-selected-windows t)
5438 (overlay-arrow-string "=>")
5439 (overlay-arrow-position (point-marker)))
5440 (unwind-protect
5441 (cond
5442 ((and no-handle interactive)
5443 (call-interactively function))
5444 (no-handle
5445 (funcall function))
5446 (interactive
5447 (call-interactively
a87ee50b 5448 function (get-text-property (point) 'gnus-data)))
01c52d31
MB		 5449 (t
5450 (funcall function
a87ee50b 5451 (get-text-property (point) 'gnus-data))))
01c52d31
MB		 5452 (set-marker overlay-arrow-position nil)
5453 (unless gnus-auto-select-part
5454 (gnus-select-frame-set-input-focus frame)
5455 (select-window window))))
5456 t))
5457 (if gnus-inhibit-mime-unbuttonizing
5458 ;; This is the default though the program shouldn't reach here.
5459 (error "No such part")
5460 ;; The part which doesn't have the MIME button is selected.
5461 ;; So, we display all the buttons and redo it.
5462 (let ((gnus-inhibit-mime-unbuttonizing t))
5463 (gnus-summary-show-article)
5464 (gnus-article-part-wrapper n function no-handle))))))
16409b0b
GM		 5465
5466(defun gnus-article-pipe-part (n)
5467 "Pipe MIME part N, which is the numerical prefix."
01c52d31 5468 (interactive "P")
16409b0b
GM		 5469 (gnus-article-part-wrapper n 'mm-pipe-part))
5470
5471(defun gnus-article-save-part (n)
5472 "Save MIME part N, which is the numerical prefix."
01c52d31 5473 (interactive "P")
16409b0b
GM		 5474 (gnus-article-part-wrapper n 'mm-save-part))
5475
5476(defun gnus-article-interactively-view-part (n)
5477 "View MIME part N interactively, which is the numerical prefix."
01c52d31 5478 (interactive "P")
16409b0b
GM		 5479 (gnus-article-part-wrapper n 'mm-interactively-view-part))
5480
5481(defun gnus-article-copy-part (n)
5482 "Copy MIME part N, which is the numerical prefix."
01c52d31 5483 (interactive "P")
16409b0b
GM		 5484 (gnus-article-part-wrapper n 'gnus-mime-copy-part))
5485
23f87bed
MB		 5486(defun gnus-article-view-part-as-charset (n)
5487 "View MIME part N using a specified charset.
5488N is the numerical prefix."
01c52d31 5489 (interactive "P")
23f87bed
MB		 5490 (gnus-article-part-wrapper n 'gnus-mime-view-part-as-charset))
5491
5492(defun gnus-article-view-part-externally (n)
16409b0b 5493 "View MIME part N externally, which is the numerical prefix."
01c52d31 5494 (interactive "P")
23f87bed 5495 (gnus-article-part-wrapper n 'gnus-mime-view-part-externally))
16409b0b
GM		 5496
5497(defun gnus-article-inline-part (n)
5498 "Inline MIME part N, which is the numerical prefix."
01c52d31 5499 (interactive "P")
16409b0b
GM		 5500 (gnus-article-part-wrapper n 'gnus-mime-inline-part))
5501
01c52d31
MB		 5502(defun gnus-article-save-part-and-strip (n)
5503 "Save MIME part N and replace it with an external body.
5504N is the numerical prefix."
5505 (interactive "P")
5506 (gnus-article-part-wrapper n 'gnus-mime-save-part-and-strip t))
5507
5508(defun gnus-article-replace-part (n)
5509 "Replace MIME part N with an external body.
5510N is the numerical prefix."
5511 (interactive "P")
5512 (gnus-article-part-wrapper n 'gnus-mime-replace-part t t))
5513
5514(defun gnus-article-delete-part (n)
5515 "Delete MIME part N and add some information about the removed part.
5516N is the numerical prefix."
5517 (interactive "P")
5518 (gnus-article-part-wrapper n 'gnus-mime-delete-part t))
5519
5520(defun gnus-article-view-part-as-type (n)
5521 "Choose a MIME media type, and view part N as such.
5522N is the numerical prefix."
5523 (interactive "P")
5524 (gnus-article-part-wrapper n 'gnus-mime-view-part-as-type t))
5525
16409b0b
GM		 5526(defun gnus-article-mime-match-handle-first (condition)
5527 (if condition
01c52d31
MB		 5528 (let (n)
5529 (dolist (ihandle gnus-article-mime-handle-alist)
a1506d29 5530 (if (and (cond
16409b0b
GM		 5531 ((functionp condition)
5532 (funcall condition (cdr ihandle)))
a1506d29 5533 ((eq condition 'undisplayed)
16409b0b
GM		 5534 (not (or (mm-handle-undisplayer (cdr ihandle))
5535 (equal (mm-handle-media-type (cdr ihandle))
5536 "multipart/alternative"))))
5537 ((eq condition 'undisplayed-alternative)
5538 (not (mm-handle-undisplayer (cdr ihandle))))
5539 (t t))
5540 (gnus-article-goto-part (car ihandle))
5541 (or (not n) (< (car ihandle) n)))
5542 (setq n (car ihandle))))
5543 (or n 1))
5544 1))
5545
5546(defun gnus-article-view-part (&optional n)
47fe149b
KY		 5547 "View MIME part N, which is the numerical prefix.
5548If the part is already shown, hide the part. If N is nil, view
5549all parts."
16409b0b 5550 (interactive "P")
01c52d31 5551 (with-current-buffer gnus-article-buffer
a1506d29 5552 (or (numberp n) (setq n (gnus-article-mime-match-handle-first
16409b0b
GM		 5553 gnus-article-mime-match-handle-function)))
5554 (when (> n (length gnus-article-mime-handle-alist))
5555 (error "No such part"))
5556 (let ((handle (cdr (assq n gnus-article-mime-handle-alist))))
5557 (when (gnus-article-goto-part n)
5558 (if (equal (car handle) "multipart/alternative")
5559 (gnus-article-press-button)
5560 (when (eq (gnus-mm-display-part handle) 'internal)
5561 (gnus-set-window-start)))))))
5562
e0bad764
DL		 5563(defsubst gnus-article-mime-total-parts ()
5564 (if (bufferp (car gnus-article-mime-handles))
5565 1 ;; single part
5566 (1- (length gnus-article-mime-handles))))
5567
16409b0b
GM		 5568(defun gnus-mm-display-part (handle)
5569 "Display HANDLE and fix MIME button."
5570 (let ((id (get-text-property (point) 'gnus-part))
5571 (point (point))
23f87bed 5572 (inhibit-read-only t))
16409b0b
GM		 5573 (forward-line 1)
5574 (prog1
5575 (let ((window (selected-window))
5576 (mail-parse-charset gnus-newsgroup-charset)
a1506d29 5577 (mail-parse-ignored-charsets
23f87bed 5578 (if (gnus-buffer-live-p gnus-summary-buffer)
01c52d31 5579 (with-current-buffer gnus-summary-buffer
23f87bed
MB		 5580 gnus-newsgroup-ignored-charsets)
5581 nil)))
16409b0b
GM		 5582 (save-excursion
5583 (unwind-protect
23f87bed 5584 (let ((win (gnus-get-buffer-window (current-buffer) t))
16409b0b
GM		 5585 (beg (point)))
5586 (when win
5587 (select-window win))
5588 (goto-char point)
5589 (forward-line)
5590 (if (mm-handle-displayed-p handle)
5591 ;; This will remove the part.
5592 (mm-display-part handle)
5593 (save-restriction
23f87bed
MB		 5594 (narrow-to-region (point)
5595 (if (eobp) (point) (1+ (point))))
b0b63450 5596 (gnus-bind-safe-url-regexp (mm-display-part handle))
16409b0b
GM		 5597 ;; We narrow to the part itself and
5598 ;; then call the treatment functions.
5599 (goto-char (point-min))
5600 (forward-line 1)
5601 (narrow-to-region (point) (point-max))
5602 (gnus-treat-article
5603 nil id
e0bad764 5604 (gnus-article-mime-total-parts)
16409b0b 5605 (mm-handle-media-type handle)))))
23f87bed
MB		 5606 (if (window-live-p window)
5607 (select-window window)))))
16409b0b 5608 (goto-char point)
23f87bed 5609 (gnus-delete-line)
16409b0b
GM		 5610 (gnus-insert-mime-button
5611 handle id (list (mm-handle-displayed-p handle)))
5612 (goto-char point))))
5613
5614(defun gnus-article-goto-part (n)
5615 "Go to MIME part N."
9efcd224
KY		 5616 (when gnus-break-pages
5617 (widen))
95de0327
KY		 5618 (prog1
5619 (let ((start (text-property-any (point-min) (point-max) 'gnus-part n))
5620 part handle end next handles)
5621 (when start
5622 (goto-char start)
5623 (if (setq handle (get-text-property start 'gnus-data))
5624 start
5625 ;; Go to the displayed subpart, assuming this is
5626 ;; multipart/alternative.
5627 (setq part start
5628 end (point-at-eol))
5629 (while (and (not handle)
5630 part
5631 (< part end)
5632 (setq next (text-property-not-all part end
5633 'gnus-data nil)))
5634 (setq part next
5635 handle (get-text-property part 'gnus-data))
5636 (push (cons handle part) handles)
5637 (unless (mm-handle-displayed-p handle)
5638 (setq handle nil
5639 part (text-property-any part end 'gnus-data nil))))
5640 (unless handle
5641 ;; No subpart is displayed, so we find preferred one.
5642 (setq part
5643 (cdr (assq (mm-preferred-alternative
5644 (nreverse (mapcar 'car handles)))
5645 handles))))
5646 (if part
5647 (goto-char (1+ part))
5648 start))))
5649 (when gnus-break-pages
5650 (gnus-narrow-to-page))))
16409b0b
GM		 5651
5652(defun gnus-insert-mime-button (handle gnus-tmp-id &optional displayed)
5653 (let ((gnus-tmp-name
23f87bed
MB		 5654 (or (mail-content-type-get (mm-handle-type handle) 'name)
5655 (mail-content-type-get (mm-handle-disposition handle) 'filename)
5656 (mail-content-type-get (mm-handle-type handle) 'url)
16409b0b
GM		 5657 ""))
5658 (gnus-tmp-type (mm-handle-media-type handle))
4599d0ec 5659 (gnus-tmp-description (or (mm-handle-description handle) ""))
16409b0b
GM		 5660 (gnus-tmp-dots
5661 (if (if displayed (car displayed)
5662 (mm-handle-displayed-p handle))
5663 "" "..."))
5664 (gnus-tmp-length (with-current-buffer (mm-handle-buffer handle)
5665 (buffer-size)))
5666 gnus-tmp-type-long b e)
5667 (when (string-match ".*/" gnus-tmp-name)
5668 (setq gnus-tmp-name (replace-match "" t t gnus-tmp-name)))
5669 (setq gnus-tmp-type-long (concat gnus-tmp-type
5670 (and (not (equal gnus-tmp-name ""))
5671 (concat "; " gnus-tmp-name))))
23f87bed
MB		 5672 (unless (equal gnus-tmp-description "")
5673 (setq gnus-tmp-type-long (concat " --- " gnus-tmp-type-long)))
16409b0b
GM		 5674 (unless (bolp)
5675 (insert "\n"))
5676 (setq b (point))
5677 (gnus-eval-format
5678 gnus-mime-button-line-format gnus-mime-button-line-format-alist
01c52d31
MB		 5679 `(keymap ,gnus-mime-button-map
5680 gnus-callback gnus-mm-display-part
5681 gnus-part ,gnus-tmp-id
5682 article-type annotation
5683 gnus-data ,handle))
23f87bed
MB		 5684 (setq e (if (bolp)
5685 ;; Exclude a newline.
5686 (1- (point))
5687 (point)))
01c52d31
MB		 5688 (when gnus-article-button-face
5689 (gnus-overlay-put (gnus-make-overlay b e nil t)
5690 'face gnus-article-button-face))
16409b0b
GM		 5691 (widget-convert-button
5692 'link b e
5693 :mime-handle handle
5694 :action 'gnus-widget-press-button
5695 :button-keymap gnus-mime-button-map
5696 :help-echo
5843126b 5697 (lambda (widget)
16409b0b
GM		 5698 ;; Needed to properly clear the message due to a bug in
5699 ;; wid-edit (XEmacs only).
5700 (if (boundp 'help-echo-owns-message)
5701 (setq help-echo-owns-message t))
5702 (format
5703 "%S: %s the MIME part; %S: more options"
5704 (aref gnus-mouse-2 0)
5843126b 5705 (if (mm-handle-displayed-p (widget-get widget :mime-handle))
16409b0b
GM		 5706 "hide" "show")
5707 (aref gnus-down-mouse-3 0))))))
5708
5709(defun gnus-widget-press-button (elems el)
5710 (goto-char (widget-get elems :from))
5711 (gnus-article-press-button))
5712
5713(defvar gnus-displaying-mime nil)
5714
5715(defun gnus-display-mime (&optional ihandles)
5716 "Display the MIME parts."
5717 (save-excursion
5718 (save-selected-window
5719 (let ((window (get-buffer-window gnus-article-buffer))
5720 (point (point)))
5721 (when window
5722 (select-window window)
5723 ;; We have to do this since selecting the window
5724 ;; may change the point. So we set the window point.
5725 (set-window-point window point)))
73043f7d
MB		 5726 (let ((handles ihandles)
5727 (inhibit-read-only t)
5728 handle)
5729 (cond (handles)
5730 ((setq handles (mm-dissect-buffer nil gnus-article-loose-mime))
5731 (when gnus-article-emulate-mime
5732 (mm-uu-dissect-text-parts handles)))
5733 (gnus-article-emulate-mime
5734 (setq handles (mm-uu-dissect))))
16409b0b
GM		 5735 (when (and (not ihandles)
5736 (not gnus-displaying-mime))
5737 ;; Top-level call; we clean up.
5738 (when gnus-article-mime-handles
5739 (mm-destroy-parts gnus-article-mime-handles)
5740 (setq gnus-article-mime-handle-alist nil));; A trick.
5741 (setq gnus-article-mime-handles handles)
5742 ;; We allow users to glean info from the handles.
5743 (when gnus-article-mime-part-function
5744 (gnus-mime-part-function handles)))
5745 (if (and handles
5746 (or (not (stringp (car handles)))
5747 (cdr handles)))
5748 (progn
5749 (when (and (not ihandles)
5750 (not gnus-displaying-mime))
5751 ;; Clean up for mime parts.
5752 (article-goto-body)
5753 (delete-region (point) (point-max)))
5754 (let ((gnus-displaying-mime t))
5755 (gnus-mime-display-part handles)))
5756 (save-restriction
5757 (article-goto-body)
5758 (narrow-to-region (point) (point-max))
389b76fa 5759 (gnus-treat-article nil 1 1 "text/plain")
16409b0b
GM		 5760 (widen)))
5761 (unless ihandles
5762 ;; Highlight the headers.
5763 (save-excursion
5764 (save-restriction
5765 (article-goto-body)
5766 (narrow-to-region (point-min) (point))
31640842 5767 (gnus-article-save-original-date
f362b760
MB		 5768 (gnus-treat-article 'head)))))))
5769 ;; Cope with broken MIME messages.
5770 (goto-char (point-max))
5771 (unless (bolp)
5772 (insert "\n"))))
16409b0b 5773
23f87bed
MB		 5774(defcustom gnus-mime-display-multipart-as-mixed nil
5775 "Display \"multipart\" parts as \"multipart/mixed\".
5776
5777If t, it overrides nil values of
5778`gnus-mime-display-multipart-alternative-as-mixed' and
5779`gnus-mime-display-multipart-related-as-mixed'."
5780 :group 'gnus-article-mime
5781 :type 'boolean)
5782
5783(defcustom gnus-mime-display-multipart-alternative-as-mixed nil
5784 "Display \"multipart/alternative\" parts as \"multipart/mixed\"."
bf247b6e 5785 :version "22.1"
23f87bed
MB		 5786 :group 'gnus-article-mime
5787 :type 'boolean)
5788
5789(defcustom gnus-mime-display-multipart-related-as-mixed nil
5790 "Display \"multipart/related\" parts as \"multipart/mixed\".
5791
5792If displaying \"text/html\" is discouraged \(see
5793`mm-discouraged-alternatives'\) images or other material inside a
5794\"multipart/related\" part might be overlooked when this variable is nil."
bf247b6e 5795 :version "22.1"
23f87bed
MB		 5796 :group 'gnus-article-mime
5797 :type 'boolean)
16409b0b
GM		 5798
5799(defun gnus-mime-display-part (handle)
5800 (cond
430d3ed7
MB		 5801 ;; Maybe a broken MIME message.
5802 ((null handle))
16409b0b
GM		 5803 ;; Single part.
5804 ((not (stringp (car handle)))
5805 (gnus-mime-display-single handle))
5806 ;; User-defined multipart
5807 ((cdr (assoc (car handle) gnus-mime-multipart-functions))
5808 (funcall (cdr (assoc (car handle) gnus-mime-multipart-functions))
5809 handle))
5810 ;; multipart/alternative
5811 ((and (equal (car handle) "multipart/alternative")
23f87bed
MB		 5812 (not (or gnus-mime-display-multipart-as-mixed
5813 gnus-mime-display-multipart-alternative-as-mixed)))
16409b0b
GM		 5814 (let ((id (1+ (length gnus-article-mime-handle-alist))))
5815 (push (cons id handle) gnus-article-mime-handle-alist)
5816 (gnus-mime-display-alternative (cdr handle) nil nil id)))
5817 ;; multipart/related
5818 ((and (equal (car handle) "multipart/related")
23f87bed
MB		 5819 (not (or gnus-mime-display-multipart-as-mixed
5820 gnus-mime-display-multipart-related-as-mixed)))
16409b0b
GM		 5821 ;;;!!!We should find the start part, but we just default
5822 ;;;!!!to the first part.
23f87bed
MB		 5823 ;;(gnus-mime-display-part (cadr handle))
5824 ;;;!!! Most multipart/related is an HTML message plus images.
5825 ;;;!!! Unfortunately we are unable to let W3 display those
5826 ;;;!!! included images, so we just display it as a mixed multipart.
5827 ;;(gnus-mime-display-mixed (cdr handle))
5828 ;;;!!! No, w3 can display everything just fine.
16409b0b 5829 (gnus-mime-display-part (cadr handle)))
23f87bed
MB		 5830 ((equal (car handle) "multipart/signed")
5831 (gnus-add-wash-type 'signed)
5832 (gnus-mime-display-security handle))
5833 ((equal (car handle) "multipart/encrypted")
5834 (gnus-add-wash-type 'encrypted)
5835 (gnus-mime-display-security handle))
16409b0b
GM		 5836 ;; Other multiparts are handled like multipart/mixed.
5837 (t
5838 (gnus-mime-display-mixed (cdr handle)))))
5839
5840(defun gnus-mime-part-function (handles)
5841 (if (stringp (car handles))
5842 (mapcar 'gnus-mime-part-function (cdr handles))
5843 (funcall gnus-article-mime-part-function handles)))
5844
5845(defun gnus-mime-display-mixed (handles)
5846 (mapcar 'gnus-mime-display-part handles))
5847
5848(defun gnus-mime-display-single (handle)
5849 (let ((type (mm-handle-media-type handle))
5850 (ignored gnus-ignored-mime-types)
5851 (not-attachment t)
5852 (move nil)
5853 display text)
5854 (catch 'ignored
5855 (progn
5856 (while ignored
5857 (when (string-match (pop ignored) type)
5858 (throw 'ignored nil)))
b59a9eef
KY		 5859 (if (and (not (and (if (gnus-buffer-live-p gnus-summary-buffer)
5860 (with-current-buffer gnus-summary-buffer
5861 gnus-inhibit-images)
5862 gnus-inhibit-images)
40de2c6d
KY		 5863 (string-match "\\`image/" type)))
5864 (setq not-attachment
16409b0b
GM		 5865 (and (not (mm-inline-override-p handle))
5866 (or (not (mm-handle-disposition handle))
5867 (equal (car (mm-handle-disposition handle))
5868 "inline")
5869 (mm-attachment-override-p handle))))
5870 (mm-automatic-display-p handle)
23f87bed
MB		 5871 (or (and
5872 (mm-inlinable-p handle)
5873 (mm-inlined-p handle))
16409b0b
GM		 5874 (mm-automatic-external-display-p type)))
5875 (setq display t)
5876 (when (equal (mm-handle-media-supertype handle) "text")
5877 (setq text t)))
e0bad764
DL		 5878 (let ((id (1+ (length gnus-article-mime-handle-alist)))
5879 beg)
16409b0b 5880 (push (cons id handle) gnus-article-mime-handle-alist)
531bedc3
MB		 5881 (when (and display
5882 (equal (mm-handle-media-supertype handle) "message"))
5883 (insert-char
5884 ?\n
5885 (cond ((not (bolp)) 2)
5886 ((or (bobp) (eq (char-before (1- (point))) ?\n)) 0)
5887 (t 1))))
16409b0b 5888 (when (or (not display)
3e3ab3ab
KY		 5889 (not (gnus-unbuttonized-mime-type-p type))
5890 (eq id gnus-mime-buttonized-part-id))
16409b0b
GM		 5891 (gnus-insert-mime-button
5892 handle id (list (or display (and not-attachment text))))
5893 (gnus-article-insert-newline)
23f87bed 5894 ;; Remember modify the number of forward lines.
e0bad764
DL		 5895 (setq move t))
5896 (setq beg (point))
16409b0b
GM		 5897 (cond
5898 (display
5899 (when move
23f87bed 5900 (forward-line -1)
16409b0b
GM		 5901 (setq beg (point)))
5902 (let ((mail-parse-charset gnus-newsgroup-charset)
a1506d29 5903 (mail-parse-ignored-charsets
16409b0b
GM		 5904 (save-excursion (condition-case ()
5905 (set-buffer gnus-summary-buffer)
5906 (error))
5907 gnus-newsgroup-ignored-charsets)))
b0b63450 5908 (gnus-bind-safe-url-regexp (mm-display-part handle t)))
16409b0b
GM		 5909 (goto-char (point-max)))
5910 ((and text not-attachment)
5911 (when move
23f87bed 5912 (forward-line -1)
16409b0b
GM		 5913 (setq beg (point)))
5914 (gnus-article-insert-newline)
f205c6e7 5915 (mm-display-inline handle)
16409b0b
GM		 5916 (goto-char (point-max))))
5917 ;; Do highlighting.
5918 (save-excursion
5919 (save-restriction
5920 (narrow-to-region beg (point))
01c52d31
MB		 5921 (if (eq handle gnus-article-mime-handles)
5922 ;; The format=flowed case.
5923 (gnus-treat-article nil 1 1 (mm-handle-media-type handle))
5924 ;; Don't count signature parts that are never displayed.
5925 ;; The part number should be re-calculated supposing this
5926 ;; might be a message/rfc822 part.
5927 (let (handles)
5928 (dolist (part gnus-article-mime-handles)
5929 (unless (or (stringp part)
5930 (equal (car (mm-handle-type part))
5931 "application/pgp-signature"))
5932 (push part handles)))
5933 (gnus-treat-article
5934 nil (length (memq handle handles)) (length handles)
5935 (mm-handle-media-type handle)))))))))))
16409b0b
GM		 5936
5937(defun gnus-unbuttonized-mime-type-p (type)
5938 "Say whether TYPE is to be unbuttonized."
5939 (unless gnus-inhibit-mime-unbuttonizing
23f87bed
MB		 5940 (when (catch 'found
5941 (let ((types gnus-unbuttonized-mime-types))
5942 (while types
5943 (when (string-match (pop types) type)
5944 (throw 'found t)))))
5945 (not (catch 'found
5946 (let ((types gnus-buttonized-mime-types))
5947 (while types
5948 (when (string-match (pop types) type)
5949 (throw 'found t)))))))))
16409b0b
GM		 5950
5951(defun gnus-article-insert-newline ()
5952 "Insert a newline, but mark it as undeletable."
5953 (gnus-put-text-property
5954 (point) (progn (insert "\n") (point)) 'gnus-undeletable t))
5955
5956(defun gnus-mime-display-alternative (handles &optional preferred ibegend id)
5957 (let* ((preferred (or preferred (mm-preferred-alternative handles)))
5958 (ihandles handles)
5959 (point (point))
23f87bed 5960 handle (inhibit-read-only t) from props begend not-pref)
16409b0b
GM		 5961 (save-window-excursion
5962 (save-restriction
5963 (when ibegend
5964 (narrow-to-region (car ibegend)
5965 (or (cdr ibegend)
5966 (progn
5967 (goto-char (car ibegend))
5968 (forward-line 2)
5969 (point))))
5970 (delete-region (point-min) (point-max))
5971 (mm-remove-parts handles))
5972 (setq begend (list (point-marker)))
5973 ;; Do the toggle.
5974 (unless (setq not-pref (cadr (member preferred ihandles)))
5975 (setq not-pref (car ihandles)))
5976 (when (or ibegend
23f87bed 5977 (not preferred)
16409b0b
GM		 5978 (not (gnus-unbuttonized-mime-type-p
5979 "multipart/alternative")))
5980 (gnus-add-text-properties
5981 (setq from (point))
5982 (progn
5983 (insert (format "%d. " id))
5984 (point))
5985 `(gnus-callback
5986 (lambda (handles)
5987 (unless ,(not ibegend)
5988 (setq gnus-article-mime-handle-alist
5989 ',gnus-article-mime-handle-alist))
5990 (gnus-mime-display-alternative
5991 ',ihandles ',not-pref ',begend ,id))
01c52d31 5992 keymap ,gnus-mime-button-map
16409b0b
GM		 5993 ,gnus-mouse-face-prop ,gnus-article-mouse-face
5994 face ,gnus-article-button-face
16409b0b 5995 gnus-part ,id
7dafe00b 5996 article-type multipart))
16409b0b
GM		 5997 (widget-convert-button 'link from (point)
5998 :action 'gnus-widget-press-button
5999 :button-keymap gnus-widget-button-keymap)
6000 ;; Do the handles
6001 (while (setq handle (pop handles))
6002 (gnus-add-text-properties
6003 (setq from (point))
6004 (progn
6005 (insert (format "(%c) %-18s"
6006 (if (equal handle preferred) ?* ? )
6007 (mm-handle-media-type handle)))
6008 (point))
6009 `(gnus-callback
6010 (lambda (handles)
6011 (unless ,(not ibegend)
6012 (setq gnus-article-mime-handle-alist
6013 ',gnus-article-mime-handle-alist))
6014 (gnus-mime-display-alternative
6015 ',ihandles ',handle ',begend ,id))
01c52d31 6016 keymap ,gnus-mime-button-map
16409b0b
GM		 6017 ,gnus-mouse-face-prop ,gnus-article-mouse-face
6018 face ,gnus-article-button-face
16409b0b
GM		 6019 gnus-part ,id
6020 gnus-data ,handle))
6021 (widget-convert-button 'link from (point)
6022 :action 'gnus-widget-press-button
6023 :button-keymap gnus-widget-button-keymap)
6024 (insert " "))
6025 (insert "\n\n"))
6026 (when preferred
6027 (if (stringp (car preferred))
6028 (gnus-display-mime preferred)
6029 (let ((mail-parse-charset gnus-newsgroup-charset)
a1506d29 6030 (mail-parse-ignored-charsets
01c52d31
MB		 6031 (with-current-buffer gnus-summary-buffer
6032 gnus-newsgroup-ignored-charsets)))
b0b63450 6033 (gnus-bind-safe-url-regexp (mm-display-part preferred))
16409b0b
GM		 6034 ;; Do highlighting.
6035 (save-excursion
6036 (save-restriction
6037 (narrow-to-region (car begend) (point-max))
6038 (gnus-treat-article
6039 nil (length gnus-article-mime-handle-alist)
e0bad764 6040 (gnus-article-mime-total-parts)
389b76fa 6041 (mm-handle-media-type preferred))))))
16409b0b
GM		 6042 (goto-char (point-max))
6043 (setcdr begend (point-marker)))))
6044 (when ibegend
6045 (goto-char point))))
6046
23f87bed
MB		 6047(defconst gnus-article-wash-status-strings
6048 (let ((alist '((cite "c" "Possible hidden citation text"
6049 " " "All citation text visible")
6050 (headers "h" "Hidden headers"
6051 " " "All headers visible.")
6052 (pgp "p" "Encrypted or signed message status hidden"
6053 " " "No hidden encryption nor digital signature status")
6054 (signature "s" "Signature has been hidden"
6055 " " "Signature is visible")
6056 (overstrike "o" "Overstrike (^H) characters applied"
6057 " " "No overstrike characters applied")
6058 (emphasis "e" "/*_Emphasis_*/ characters applied"
6059 " " "No /*_emphasis_*/ characters applied")))
6060 result)
6061 (dolist (entry alist result)
6062 (let ((key (nth 0 entry))
6063 (on (copy-sequence (nth 1 entry)))
6064 (on-help (nth 2 entry))
6065 (off (copy-sequence (nth 3 entry)))
6066 (off-help (nth 4 entry)))
6067 (put-text-property 0 1 'help-echo on-help on)
6068 (put-text-property 0 1 'help-echo off-help off)
6069 (push (list key on off) result))))
6070 "Alist of strings describing wash status in the mode line.
6071Each entry has the form (KEY ON OF), where the KEY is a symbol
6072representing the particular washing function, ON is the string to use
6073in the article mode line when the washing function is active, and OFF
6074is the string to use when it is inactive.")
6075
6076(defun gnus-article-wash-status-entry (key value)
6077 (let ((entry (assoc key gnus-article-wash-status-strings)))
6078 (if value (nth 1 entry) (nth 2 entry))))
6079
eec82323
LMI		 6080(defun gnus-article-wash-status ()
6081 "Return a string which display status of article washing."
01c52d31 6082 (with-current-buffer gnus-article-buffer
16409b0b
GM		 6083 (let ((cite (memq 'cite gnus-article-wash-types))
6084 (headers (memq 'headers gnus-article-wash-types))
6085 (boring (memq 'boring-headers gnus-article-wash-types))
6086 (pgp (memq 'pgp gnus-article-wash-types))
6087 (pem (memq 'pem gnus-article-wash-types))
23f87bed
MB		 6088 (signed (memq 'signed gnus-article-wash-types))
6089 (encrypted (memq 'encrypted gnus-article-wash-types))
16409b0b
GM		 6090 (signature (memq 'signature gnus-article-wash-types))
6091 (overstrike (memq 'overstrike gnus-article-wash-types))
6092 (emphasis (memq 'emphasis gnus-article-wash-types)))
23f87bed
MB		 6093 (concat
6094 (gnus-article-wash-status-entry 'cite cite)
6095 (gnus-article-wash-status-entry 'headers (or headers boring))
6096 (gnus-article-wash-status-entry 'pgp (or pgp pem signed encrypted))
6097 (gnus-article-wash-status-entry 'signature signature)
6098 (gnus-article-wash-status-entry 'overstrike overstrike)
6099 (gnus-article-wash-status-entry 'emphasis emphasis)))))
6100
6101(defun gnus-add-wash-type (type)
6102 "Add a washing of TYPE to the current status."
6103 (add-to-list 'gnus-article-wash-types type))
6104
6105(defun gnus-delete-wash-type (type)
6106 "Add a washing of TYPE to the current status."
6107 (setq gnus-article-wash-types (delq type gnus-article-wash-types)))
6108
6109(defun gnus-add-image (category image)
6110 "Add IMAGE of CATEGORY to the list of displayed images."
6111 (let ((entry (assq category gnus-article-image-alist)))
6112 (unless entry
6113 (setq entry (list category))
6114 (push entry gnus-article-image-alist))
6115 (nconc entry (list image))))
6116
6117(defun gnus-delete-images (category)
6118 "Delete all images in CATEGORY."
6119 (let ((entry (assq category gnus-article-image-alist)))
6120 (dolist (image (cdr entry))
6121 (gnus-remove-image image category))
6122 (setq gnus-article-image-alist (delq entry gnus-article-image-alist))
6123 (gnus-delete-wash-type category)))
eec82323 6124
16409b0b 6125(defalias 'gnus-article-hide-headers-if-wanted 'gnus-article-maybe-hide-headers)
6748645f
LMI		 6126
6127(defun gnus-article-maybe-hide-headers ()
eec82323
LMI		 6128 "Hide unwanted headers if `gnus-have-all-headers' is nil.
6129Provided for backwards compatibility."
16409b0b 6130 (when (and (or (not (gnus-buffer-live-p gnus-summary-buffer))
01c52d31
MB		 6131 (not (with-current-buffer gnus-summary-buffer
6132 gnus-have-all-headers)))
16409b0b
GM		 6133 (not gnus-inhibit-hiding))
6134 (gnus-article-hide-headers)))
eec82323
LMI		 6135
6136;;; Article savers.
6137
6138(defun gnus-output-to-file (file-name)
26c9afc3
MB		 6139 "Append the current article to a file named FILE-NAME.
6140If `gnus-article-save-coding-system' is non-nil, it is used to encode
6141text and used as the value of the coding cookie which is added to the
6142top of a file. Otherwise, this function saves a raw article without
6143the coding cookie."
6144 (let* ((artbuf (current-buffer))
6145 (file-name-coding-system nnmail-pathname-coding-system)
6146 (coding gnus-article-save-coding-system)
6147 (coding-system-for-read (if coding
6148 nil ;; Rely on the coding cookie.
6149 mm-text-coding-system))
6150 (coding-system-for-write (or coding
6151 mm-text-coding-system-for-write
6152 mm-text-coding-system))
6153 (exists (file-exists-p file-name)))
16409b0b 6154 (with-temp-buffer
26c9afc3
MB		 6155 (when exists
6156 (insert-file-contents file-name)
6157 (goto-char (point-min))
6158 ;; Remove the existing coding cookie.
6159 (when (looking-at "X-Gnus-Coding-System: .+\n\n")
6160 (delete-region (match-beginning 0) (match-end 0))))
6161 (goto-char (point-max))
eec82323
LMI		 6162 (insert-buffer-substring artbuf)
6163 ;; Append newline at end of the buffer as separator, and then
6164 ;; save it to file.
6165 (goto-char (point-max))
6166 (insert "\n")
26c9afc3
MB		 6167 (when coding
6168 ;; If the coding system is not suitable to encode the text,
6169 ;; ask a user for a proper one.
6170 (when (fboundp 'select-safe-coding-system)
6171 (setq coding (coding-system-base
6172 (save-window-excursion
6173 (select-safe-coding-system (point-min) (point-max)
6174 coding))))
6175 (setq coding-system-for-write
6176 (or (cdr (assq coding '((mule-utf-8 . utf-8))))
6177 coding)))
6178 (goto-char (point-min))
6179 ;; Add the coding cookie.
6180 (insert (format "X-Gnus-Coding-System: -*- coding: %s; -*-\n\n"
6181 coding-system-for-write)))
6182 (if exists
6183 (progn
6184 (write-region (point-min) (point-max) file-name nil 'no-message)
6185 (message "Appended to %s" file-name))
6186 (write-region (point-min) (point-max) file-name))))
6187 t)
eec82323
LMI		 6188
6189(defun gnus-narrow-to-page (&optional arg)
6190 "Narrow the article buffer to a page.
6191If given a numerical ARG, move forward ARG pages."
6192 (interactive "P")
6193 (setq arg (if arg (prefix-numeric-value arg) 0))
80de1778 6194 (with-current-buffer gnus-article-buffer
eec82323
LMI		 6195 (widen)
6196 ;; Remove any old next/prev buttons.
6197 (when (gnus-visual-p 'page-marker)
4e7d0221 6198 (let ((inhibit-read-only t))
eec82323
LMI		 6199 (gnus-remove-text-with-property 'gnus-prev)
6200 (gnus-remove-text-with-property 'gnus-next)))
8f7abae3
MB		 6201 (let (st nd pt)
6202 (when (save-excursion
6203 (cond ((< arg 0)
6204 (if (re-search-backward page-delimiter nil 'move (abs arg))
6205 (prog1
6206 (setq nd (match-beginning 0)
6207 pt nd)
6208 (when (re-search-backward page-delimiter nil t)
6209 (setq st (match-end 0))))
6210 (when (re-search-forward page-delimiter nil t)
6211 (setq nd (match-beginning 0)
6212 pt (point-min)))))
6213 ((> arg 0)
6214 (if (re-search-forward page-delimiter nil 'move arg)
6215 (prog1
6216 (setq st (match-end 0)
6217 pt st)
6218 (when (re-search-forward page-delimiter nil t)
6219 (setq nd (match-beginning 0))))
6220 (when (re-search-backward page-delimiter nil t)
6221 (setq st (match-end 0)
6222 pt (point-max)))))
6223 (t
6224 (when (re-search-backward page-delimiter nil t)
6225 (goto-char (setq st (match-end 0))))
6226 (when (re-search-forward page-delimiter nil t)
6227 (setq nd (match-beginning 0)))
6228 (or st nd))))
6229 (setq gnus-page-broken t)
6230 (when pt (goto-char pt))
6231 (narrow-to-region (or st (point-min)) (or nd (point-max)))
6232 (when (gnus-visual-p 'page-marker)
6233 (save-excursion
6234 (when nd
6235 (goto-char nd)
6236 (gnus-insert-next-page-button))
6237 (when st
6238 (goto-char st)
6239 (gnus-insert-prev-page-button))))))))
eec82323
LMI		 6240
6241;; Article mode commands
6242
6243(defun gnus-article-goto-next-page ()
6244 "Show the next page of the article."
6245 (interactive)
6246 (when (gnus-article-next-page)
6247 (goto-char (point-min))
6248 (gnus-article-read-summary-keys nil (gnus-character-to-event ?n))))
6249
23f87bed 6250
eec82323 6251(defun gnus-article-goto-prev-page ()
23f87bed 6252 "Show the previous page of the article."
eec82323 6253 (interactive)
8f7abae3 6254 (if (save-restriction (widen) (bobp)) ;; Real beginning-of-buffer?
23f87bed 6255 (gnus-article-read-summary-keys nil (gnus-character-to-event ?p))
eec82323
LMI		 6256 (gnus-article-prev-page nil)))
6257
23f87bed
MB		 6258;; This is cleaner but currently breaks `gnus-pick-mode':
6259;;
6260;; (defun gnus-article-goto-next-page ()
6261;; "Show the next page of the article."
6262;; (interactive)
6263;; (gnus-eval-in-buffer-window gnus-summary-buffer
6264;; (gnus-summary-next-page)))
6265;;
6266;; (defun gnus-article-goto-prev-page ()
6267;; "Show the next page of the article."
6268;; (interactive)
6269;; (gnus-eval-in-buffer-window gnus-summary-buffer
6270;; (gnus-summary-prev-page)))
6271
eec82323
LMI		 6272(defun gnus-article-next-page (&optional lines)
6273 "Show the next page of the current article.
6274If end of article, return non-nil. Otherwise return nil.
6275Argument LINES specifies lines to be scrolled up."
6276 (interactive "p")
9153f10d 6277 (move-to-window-line (if (featurep 'xemacs) -1 (- -1 scroll-margin)))
60ece9b0
MB		 6278 (if (and (not (and gnus-article-over-scroll
6279 (> (count-lines (window-start) (point-max))
9153f10d
MB		 6280 (if (featurep 'xemacs)
6281 (or lines (1- (window-height)))
6282 (+ (or lines (1- (window-height))) scroll-margin)))))
60ece9b0
MB		 6283 (save-excursion
6284 (end-of-line)
6285 (and (pos-visible-in-window-p) ;Not continuation line.
647559c2 6286 (>= (point) (point-max)))))
eec82323
LMI		 6287 ;; Nothing in this page.
6288 (if (or (not gnus-page-broken)
6289 (save-excursion
6290 (save-restriction
23f87bed
MB		 6291 (widen)
6292 (forward-line)
6293 (eobp)))) ;Real end-of-buffer?
6294 (progn
6295 (when gnus-article-over-scroll
6296 (gnus-article-next-page-1 lines))
6297 t) ;Nothing more.
eec82323
LMI		 6298 (gnus-narrow-to-page 1) ;Go to next page.
6299 nil)
6300 ;; More in this page.
23f87bed 6301 (gnus-article-next-page-1 lines)
eec82323
LMI		 6302 nil))
6303
b1992461 6304(defun gnus-article-beginning-of-window ()
d8a88581
MB		 6305 "Move point to the beginning of the window.
6306In Emacs, the point is placed at the line number which `scroll-margin'
6307specifies."
6308 (if (featurep 'xemacs)
b1992461
KY		 6309 (move-to-window-line 0)
6310 ;; There is an obscure bug in Emacs that makes it impossible to
6311 ;; scroll past big pictures in the article buffer. Try to fix
6312 ;; this by adding a sanity check by counting the lines visible.
6313 (when (> (count-lines (window-start) (window-end)) 30)
6314 (move-to-window-line
6315 (min (max 0 scroll-margin)
6316 (max 1 (- (window-height)
6317 (if mode-line-format 1 0)
6318 (if header-line-format 1 0)
6319 2)))))))
d8a88581 6320
23f87bed 6321(defun gnus-article-next-page-1 (lines)
4b91459a
MB		 6322 (condition-case ()
6323 (let ((scroll-in-place nil))
6324 (scroll-up lines))
6325 (end-of-buffer
6326 ;; Long lines may cause an end-of-buffer error.
6327 (goto-char (point-max))))
6328 (gnus-article-beginning-of-window))
23f87bed 6329
eec82323
LMI		 6330(defun gnus-article-prev-page (&optional lines)
6331 "Show previous page of current article.
6332Argument LINES specifies lines to be scrolled down."
6333 (interactive "p")
d8a88581 6334 (move-to-window-line 0)
eec82323
LMI		 6335 (if (and gnus-page-broken
6336 (bobp)
6337 (not (save-restriction (widen) (bobp)))) ;Real beginning-of-buffer?
6338 (progn
6339 (gnus-narrow-to-page -1) ;Go to previous page.
6340 (goto-char (point-max))
60ece9b0
MB		 6341 (recenter (if gnus-article-over-scroll
6342 (if lines
9153f10d
MB		 6343 (max (if (featurep 'xemacs)
6344 lines
6345 (+ lines scroll-margin))
60ece9b0
MB		 6346 3)
6347 (- (window-height) 2))
6348 -1)))
c03ac728
MB		 6349 (prog1
6350 (condition-case ()
6351 (let ((scroll-in-place nil))
6352 (scroll-down lines))
6353 (beginning-of-buffer
6354 (goto-char (point-min))))
6355 (gnus-article-beginning-of-window))))
eec82323 6356
23f87bed
MB		 6357(defun gnus-article-only-boring-p ()
6358 "Decide whether there is only boring text remaining in the article.
6359Something \"interesting\" is a word of at least two letters that does
6360not have a face in `gnus-article-boring-faces'."
6361 (when (and gnus-article-skip-boring
6362 (boundp 'gnus-article-boring-faces)
6363 (symbol-value 'gnus-article-boring-faces))
6364 (save-excursion
531bedc3
MB		 6365 (let ((inhibit-point-motion-hooks t))
6366 (catch 'only-boring
6367 (while (re-search-forward "\\b\\w\\w" nil t)
6368 (forward-char -1)
6369 (when (not (gnus-intersection
6370 (gnus-faces-at (point))
6371 (symbol-value 'gnus-article-boring-faces)))
6372 (throw 'only-boring nil)))
6373 (throw 'only-boring t))))))
23f87bed 6374
eec82323
LMI		 6375(defun gnus-article-refer-article ()
6376 "Read article specified by message-id around point."
6377 (interactive)
23f87bed 6378 (save-excursion
01c52d31
MB		 6379 (re-search-backward "[ \t]\\|^" (point-at-bol) t)
6380 (re-search-forward "<?news:<?\\|<" (point-at-eol) t)
6381 (if (re-search-forward "[^@ ]+@[^ \t>]+" (point-at-eol) t)
23f87bed 6382 (let ((msg-id (concat "<" (match-string 0) ">")))
eec82323 6383 (set-buffer gnus-summary-buffer)
23f87bed 6384 (gnus-summary-refer-article msg-id))
eec82323
LMI		 6385 (error "No references around point"))))
6386
6387(defun gnus-article-show-summary ()
6388 "Reconfigure windows to show summary buffer."
6389 (interactive)
6390 (if (not (gnus-buffer-live-p gnus-summary-buffer))
6391 (error "There is no summary buffer for this article buffer")
a8151ef7 6392 (gnus-article-set-globals)
eec82323 6393 (gnus-configure-windows 'article)
6748645f
LMI		 6394 (gnus-summary-goto-subject gnus-current-article)
6395 (gnus-summary-position-point)))
eec82323
LMI		 6396
6397(defun gnus-article-describe-briefly ()
6398 "Describe article mode commands briefly."
6399 (interactive)
bdaa75c7 6400 (gnus-message 6 "%s" (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 6401
16409b0b
GM		 6402(defun gnus-article-check-buffer ()
6403 "Beep if not in an article buffer."
6404 (unless (equal major-mode 'gnus-article-mode)
6405 (error "Command invoked outside of a Gnus article buffer")))
6406
eec82323
LMI		 6407(defun gnus-article-read-summary-keys (&optional arg key not-restore-window)
6408 "Read a summary buffer key sequence and execute it from the article buffer."
6409 (interactive "P")
16409b0b 6410 (gnus-article-check-buffer)
eec82323 6411 (let ((nosaves
23f87bed
MB		 6412 '("q" "Q" "c" "r" "\C-c\C-f" "m" "a" "f"
6413 "Zc" "ZC" "ZE" "ZQ" "ZZ" "Zn" "ZR" "ZG" "ZN" "ZP"
6414 "=" "^" "\M-^" "|"))
6415 (nosave-but-article
0b6799c3
MB		 6416 '("A " "A<" "A>" "AM" "AP" "AR" "AT" "A\C-?" "A\M-\r" "A\r" "Ab" "Ae"
6417 "An" "Ap" [?A (meta return)] [?A delete]))
23f87bed 6418 (nosave-in-article
0b6799c3 6419 '("AS" "\C-d"))
23f87bed
MB		 6420 (up-to-top
6421 '("n" "Gn" "p" "Gp"))
6422 keys new-sum-point)
80de1778 6423 (with-current-buffer gnus-article-current-summary
eec82323 6424 (let (gnus-pick-mode)
95838435
MB		 6425 (setq unread-command-events (nconc unread-command-events
6426 (list (or key last-command-event)))
6427 keys (if (featurep 'xemacs)
6428 (events-to-keys (read-key-sequence nil t))
6429 (read-key-sequence nil t)))))
a1506d29 6430
eec82323
LMI		 6431 (message "")
6432
01c52d31
MB		 6433 (cond
6434 ((eq (aref keys (1- (length keys))) ?\C-h)
0b6799c3 6435 (gnus-article-describe-bindings (substring keys 0 -1)))
01c52d31
MB		 6436 ((or (member keys nosaves)
6437 (member keys nosave-but-article)
6438 (member keys nosave-in-article))
6439 (let (func)
6440 (save-window-excursion
6441 (pop-to-buffer gnus-article-current-summary)
6442 ;; We disable the pick minor mode commands.
6443 (let (gnus-pick-mode)
6ab2c7a8 6444 (setq func (key-binding keys t))))
01c52d31
MB		 6445 (if (or (not func)
6446 (numberp func))
6447 (ding)
6448 (unless (member keys nosave-in-article)
6449 (set-buffer gnus-article-current-summary))
cb51ba08
LI		 6450 (when (get func 'disabled)
6451 (error "Function %s disabled" func))
01c52d31
MB		 6452 (call-interactively func)
6453 (setq new-sum-point (point)))
6454 (when (member keys nosave-but-article)
6455 (pop-to-buffer gnus-article-buffer))))
6456 (t
eec82323
LMI		 6457 ;; These commands should restore window configuration.
6458 (let ((obuf (current-buffer))
23f87bed 6459 (owin (current-window-configuration))
01c52d31 6460 win func in-buffer selected new-sum-start new-sum-hscroll err)
23f87bed 6461 (cond (not-restore-window
01c52d31
MB		 6462 (pop-to-buffer gnus-article-current-summary)
6463 (setq win (selected-window)))
23f87bed
MB		 6464 ((setq win (get-buffer-window gnus-article-current-summary))
6465 (select-window win))
6466 (t
01c52d31
MB		 6467 (let ((summary-buffer gnus-article-current-summary))
6468 (gnus-configure-windows 'article)
6469 (unless (setq win (get-buffer-window summary-buffer 'visible))
6470 (let ((gnus-buffer-configuration
de0bdfe7
KY		 6471 '((article ((vertical 1.0
6472 (summary 0.25 point)
6473 (article 1.0)))))))
01c52d31
MB		 6474 (gnus-configure-windows 'article))
6475 (setq win (get-buffer-window summary-buffer 'visible)))
6476 (gnus-select-frame-set-input-focus (window-frame win))
6477 (select-window win))))
23f87bed
MB		 6478 (setq in-buffer (current-buffer))
6479 ;; We disable the pick minor mode commands.
cb51ba08
LI		 6480 (setq func (let (gnus-pick-mode)
6481 (key-binding keys t)))
6482 (when (get func 'disabled)
6483 (error "Function %s disabled" func))
6484 (if (and func
01c52d31
MB		 6485 (functionp func)
6486 (condition-case code
6487 (progn
6488 (call-interactively func)
6489 t)
6490 (error
6491 (setq err code)
6492 nil)))
23f87bed 6493 (progn
23f87bed
MB		 6494 (when (eq win (selected-window))
6495 (setq new-sum-point (point)
6496 new-sum-start (window-start win)
9a89f5b0 6497 new-sum-hscroll (window-hscroll win)))
01c52d31
MB		 6498 (when (or (eq in-buffer (current-buffer))
6499 (when (eq obuf (current-buffer))
6500 (set-buffer in-buffer)
6501 t))
520aa572
SZ		 6502 (setq selected (gnus-summary-select-article))
6503 (set-buffer obuf)
6504 (unless not-restore-window
6505 (set-window-configuration owin))
01c52d31
MB		 6506 (when (and (eq selected 'old)
6507 new-sum-point)
520aa572
SZ		 6508 (set-window-start (get-buffer-window (current-buffer))
6509 1)
6510 (set-window-point (get-buffer-window (current-buffer))
01c52d31
MB		 6511 (if (article-goto-body)
6512 (1- (point))
6513 (point))))
23f87bed 6514 (when (and (not not-restore-window)
01c52d31 6515 new-sum-point
4520e527 6516 (window-live-p win)
01c52d31
MB		 6517 (with-current-buffer (window-buffer win)
6518 (eq major-mode 'gnus-summary-mode)))
23f87bed
MB		 6519 (set-window-point win new-sum-point)
6520 (set-window-start win new-sum-start)
9a89f5b0 6521 (set-window-hscroll win new-sum-hscroll))))
23f87bed 6522 (set-window-configuration owin)
01c52d31
MB		 6523 (if err
6524 (signal (car err) (cdr err))
6525 (ding))))))))
520aa572 6526
95838435
MB		 6527(defun gnus-article-read-summary-send-keys ()
6528 (interactive)
0b6799c3 6529 (let ((unread-command-events (list (gnus-character-to-event ?S))))
95838435
MB		 6530 (gnus-article-read-summary-keys)))
6531
520aa572 6532(defun gnus-article-describe-key (key)
95838435
MB		 6533 "Display documentation of the function invoked by KEY.
6534KEY is a string or a vector."
6535 (interactive (list (let ((cursor-in-echo-area t)) ;; better for XEmacs.
6536 (read-key-sequence "Describe key: "))))
520aa572 6537 (gnus-article-check-buffer)
95838435
MB		 6538 (if (memq (key-binding key t) '(gnus-article-read-summary-keys
6539 gnus-article-read-summary-send-keys))
80de1778 6540 (with-current-buffer gnus-article-current-summary
95838435
MB		 6541 (setq unread-command-events
6542 (if (featurep 'xemacs)
6543 (append key nil)
6544 (mapcar (lambda (x) (if (and (integerp x) (>= x 128))
6545 (list 'meta (- x 128))
6546 x))
6547 key)))
6548 (let ((cursor-in-echo-area t)
6549 gnus-pick-mode)
6550 (describe-key (read-key-sequence nil t))))
520aa572
SZ		 6551 (describe-key key)))
6552
6553(defun gnus-article-describe-key-briefly (key &optional insert)
95838435
MB		 6554 "Display documentation of the function invoked by KEY.
6555KEY is a string or a vector."
6556 (interactive (list (let ((cursor-in-echo-area t)) ;; better for XEmacs.
6557 (read-key-sequence "Describe key: "))
6558 current-prefix-arg))
520aa572 6559 (gnus-article-check-buffer)
95838435
MB		 6560 (if (memq (key-binding key t) '(gnus-article-read-summary-keys
6561 gnus-article-read-summary-send-keys))
80de1778 6562 (with-current-buffer gnus-article-current-summary
95838435
MB		 6563 (setq unread-command-events
6564 (if (featurep 'xemacs)
6565 (append key nil)
6566 (mapcar (lambda (x) (if (and (integerp x) (>= x 128))
6567 (list 'meta (- x 128))
6568 x))
6569 key)))
6570 (let ((cursor-in-echo-area t)
6571 gnus-pick-mode)
6572 (describe-key-briefly (read-key-sequence nil t) insert)))
520aa572 6573 (describe-key-briefly key insert)))
eec82323 6574
0b6799c3
MB		 6575;;`gnus-agent-mode' in gnus-agent.el will define it.
6576(defvar gnus-agent-summary-mode)
e9198520 6577(defvar gnus-draft-mode)
12ea3d65
GM		 6578;; Calling help-buffer will autoload help-mode.
6579(defvar help-xref-stack-item)
5843126b
KY		 6580;; Emacs 22 doesn't load it in the batch mode.
6581(eval-when-compile
6582 (autoload 'help-buffer "help-mode"))
0b6799c3
MB		 6583
6584(defun gnus-article-describe-bindings (&optional prefix)
6585 "Show a list of all defined keys, and their definitions.
6586The optional argument PREFIX, if non-nil, should be a key sequence;
6587then we display only bindings that start with that prefix."
6588 (interactive)
6589 (gnus-article-check-buffer)
6590 (let ((keymap (copy-keymap gnus-article-mode-map))
6591 (map (copy-keymap gnus-article-send-map))
6592 (sumkeys (where-is-internal 'gnus-article-read-summary-keys))
8a908224 6593 parent agent draft)
0b6799c3
MB		 6594 (define-key keymap "S" map)
6595 (define-key map [t] nil)
6596 (with-current-buffer gnus-article-current-summary
8a908224
KY		 6597 (set-keymap-parent
6598 keymap
6599 (if (setq parent (keymap-parent gnus-article-mode-map))
6600 (prog1
6601 (setq parent (copy-keymap parent))
6602 (set-keymap-parent parent (current-local-map)))
6603 (current-local-map)))
0b6799c3 6604 (set-keymap-parent map (key-binding "S"))
8f7abae3
MB		 6605 (let (key def gnus-pick-mode)
6606 (while sumkeys
6607 (setq key (pop sumkeys))
6608 (cond ((and (vectorp key) (= (length key) 1)
6609 (consp (setq def (aref key 0)))
6610 (numberp (car def)) (numberp (cdr def)))
6611 (when (< (max (car def) (cdr def)) 128)
6612 (setq sumkeys
6613 (append (mapcar
6614 #'vector
6615 (nreverse (gnus-uncompress-range def)))
6616 sumkeys))))
6617 ((setq def (key-binding key))
6618 (unless (eq def 'undefined)
6619 (define-key keymap key def))))))
0b6799c3 6620 (when (boundp 'gnus-agent-summary-mode)
e9198520
MB		 6621 (setq agent gnus-agent-summary-mode))
6622 (when (boundp 'gnus-draft-mode)
6623 (setq draft gnus-draft-mode)))
0b6799c3
MB		 6624 (with-temp-buffer
6625 (use-local-map keymap)
6626 (set (make-local-variable 'gnus-agent-summary-mode) agent)
e9198520 6627 (set (make-local-variable 'gnus-draft-mode) draft)
0b6799c3
MB		 6628 (describe-bindings prefix))
6629 (let ((item `((lambda (prefix)
80de1778 6630 (with-current-buffer ,(current-buffer)
0b6799c3
MB		 6631 (gnus-article-describe-bindings prefix)))
6632 ,prefix)))
5843126b 6633 (with-current-buffer (let (help-xref-following) (help-buffer))
0b6799c3
MB		 6634 (setq help-xref-stack-item item)))))
6635
23f87bed
MB		 6636(defun gnus-article-reply-with-original (&optional wide)
6637 "Start composing a reply mail to the current message.
6638The text in the region will be yanked. If the region isn't active,
6639the entire article will be yanked."
95838435 6640 (interactive)
23f87bed
MB		 6641 (let ((article (cdr gnus-article-current))
6642 contents)
1d0df8af 6643 (if (not (gnus-region-active-p))
23f87bed
MB		 6644 (with-current-buffer gnus-summary-buffer
6645 (gnus-summary-reply (list (list article)) wide))
6646 (setq contents (buffer-substring (point) (mark t)))
6647 ;; Deactivate active regions.
6648 (when (and (boundp 'transient-mark-mode)
6649 transient-mark-mode)
6650 (setq mark-active nil))
6651 (with-current-buffer gnus-summary-buffer
6652 (gnus-summary-reply
6653 (list (list article contents)) wide)))))
6654
95838435
MB		 6655(defun gnus-article-wide-reply-with-original ()
6656 "Start composing a wide reply mail to the current message.
6657The text in the region will be yanked. If the region isn't active,
6658the entire article will be yanked."
6659 (interactive)
6660 (gnus-article-reply-with-original t))
6661
23f87bed
MB		 6662(defun gnus-article-followup-with-original ()
6663 "Compose a followup to the current article.
6664The text in the region will be yanked. If the region isn't active,
6665the entire article will be yanked."
6666 (interactive)
6667 (let ((article (cdr gnus-article-current))
6668 contents)
1d0df8af 6669 (if (not (gnus-region-active-p))
23f87bed
MB		 6670 (with-current-buffer gnus-summary-buffer
6671 (gnus-summary-followup (list (list article))))
6672 (setq contents (buffer-substring (point) (mark t)))
6673 ;; Deactivate active regions.
6674 (when (and (boundp 'transient-mark-mode)
6675 transient-mark-mode)
6676 (setq mark-active nil))
6677 (with-current-buffer gnus-summary-buffer
6678 (gnus-summary-followup
6679 (list (list article contents)))))))
6680
eec82323
LMI		 6681(defun gnus-article-hide (&optional arg force)
6682 "Hide all the gruft in the current article.
23f87bed
MB		 6683This means that signatures, cited text and (some) headers will be
6684hidden.
eec82323 6685If given a prefix, show the hidden text instead."
6748645f 6686 (interactive (append (gnus-article-hidden-arg) (list 'force)))
eec82323 6687 (gnus-article-hide-headers arg)
16409b0b 6688 (gnus-article-hide-list-identifiers arg)
eec82323
LMI		 6689 (gnus-article-hide-citation-maybe arg force)
6690 (gnus-article-hide-signature arg))
6691
6692(defun gnus-article-maybe-highlight ()
6748645f 6693 "Do some article highlighting if article highlighting is requested."
eec82323
LMI		 6694 (when (gnus-visual-p 'article-highlight 'highlight)
6695 (gnus-article-highlight-some)))
6696
6748645f
LMI		 6697(defun gnus-check-group-server ()
6698 ;; Make sure the connection to the server is alive.
6699 (unless (gnus-server-opened
6700 (gnus-find-method-for-group gnus-newsgroup-name))
6701 (gnus-check-server (gnus-find-method-for-group gnus-newsgroup-name))
6702 (gnus-request-group gnus-newsgroup-name t)))
6703
23f87bed
MB		 6704(eval-when-compile
6705 (autoload 'nneething-get-file-name "nneething"))
6706
eec82323
LMI		 6707(defun gnus-request-article-this-buffer (article group)
6708 "Get an article and insert it into this buffer."
6748645f 6709 (let (do-update-line sparse-header)
eec82323
LMI		 6710 (prog1
6711 (save-excursion
6712 (erase-buffer)
6713 (gnus-kill-all-overlays)
6714 (setq group (or group gnus-newsgroup-name))
6715
eec82323
LMI		 6716 ;; Using `gnus-request-article' directly will insert the article into
6717 ;; `nntp-server-buffer' - so we'll save some time by not having to
6718 ;; copy it from the server buffer into the article buffer.
6719
6720 ;; We only request an article by message-id when we do not have the
6721 ;; headers for it, so we'll have to get those.
6722 (when (stringp article)
16409b0b 6723 (gnus-read-header article))
eec82323
LMI		 6724
6725 ;; If the article number is negative, that means that this article
6726 ;; doesn't belong in this newsgroup (possibly), so we find its
6727 ;; message-id and request it by id instead of number.
6728 (when (and (numberp article)
6729 gnus-summary-buffer
6730 (get-buffer gnus-summary-buffer)
6748645f 6731 (gnus-buffer-exists-p gnus-summary-buffer))
80de1778 6732 (with-current-buffer gnus-summary-buffer
eec82323
LMI		 6733 (let ((header (gnus-summary-article-header article)))
6734 (when (< article 0)
6735 (cond
6736 ((memq article gnus-newsgroup-sparse)
6737 ;; This is a sparse gap article.
6738 (setq do-update-line article)
6739 (setq article (mail-header-id header))
16409b0b 6740 (setq sparse-header (gnus-read-header article))
eec82323
LMI		 6741 (setq gnus-newsgroup-sparse
6742 (delq article gnus-newsgroup-sparse)))
6743 ((vectorp header)
6744 ;; It's a real article.
6745 (setq article (mail-header-id header)))
6746 (t
6747 ;; It is an extracted pseudo-article.
6748 (setq article 'pseudo)
6749 (gnus-request-pseudo-article header))))
6750
6751 (let ((method (gnus-find-method-for-group
6752 gnus-newsgroup-name)))
6748645f
LMI		 6753 (when (and (eq (car method) 'nneething)
6754 (vectorp header))
23f87bed
MB		 6755 (let ((dir (nneething-get-file-name
6756 (mail-header-id header))))
6757 (when (and (stringp dir)
6758 (file-directory-p dir))
eec82323
LMI		 6759 (setq article 'nneething)
6760 (gnus-group-enter-directory dir))))))))
6761
6762 (cond
6763 ;; Refuse to select canceled articles.
6764 ((and (numberp article)
6765 gnus-summary-buffer
6766 (get-buffer gnus-summary-buffer)
6748645f 6767 (gnus-buffer-exists-p gnus-summary-buffer)
01c52d31 6768 (eq (cdr (with-current-buffer gnus-summary-buffer
eec82323
LMI		 6769 (assq article gnus-newsgroup-reads)))
6770 gnus-canceled-mark))
6771 nil)
6772 ;; We first check `gnus-original-article-buffer'.
6773 ((and (get-buffer gnus-original-article-buffer)
6774 (numberp article)
01c52d31 6775 (with-current-buffer gnus-original-article-buffer
eec82323
LMI		 6776 (and (equal (car gnus-original-article) group)
6777 (eq (cdr gnus-original-article) article))))
75eda25b
SM		 6778 ;; `insert-buffer-substring' would incorrectly use the
6779 ;; equivalent of string-make-multibyte which amount to decoding
6780 ;; with locale-coding-system, causing failure of
6781 ;; subsequent decoding.
6782 (insert (mm-string-to-multibyte
6783 (with-current-buffer gnus-original-article-buffer
6784 (buffer-substring (point-min) (point-max)))))
eec82323
LMI		 6785 'article)
6786 ;; Check the backlog.
6787 ((and gnus-keep-backlog
6788 (gnus-backlog-request-article group article (current-buffer)))
6789 'article)
6790 ;; Check asynchronous pre-fetch.
6791 ((gnus-async-request-fetched-article group article (current-buffer))
6792 (gnus-async-prefetch-next group article gnus-summary-buffer)
6748645f
LMI		 6793 (when (and (numberp article) gnus-keep-backlog)
6794 (gnus-backlog-enter-article group article (current-buffer)))
eec82323
LMI		 6795 'article)
6796 ;; Check the cache.
6797 ((and gnus-use-cache
6798 (numberp article)
6799 (gnus-cache-request-article article group))
6800 'article)
23f87bed
MB		 6801 ;; Check the agent cache.
6802 ((gnus-agent-request-article article group)
6803 'article)
eec82323 6804 ;; Get the article and put into the article buffer.
16409b0b
GM		 6805 ((or (stringp article)
6806 (numberp article))
6807 (let ((gnus-override-method gnus-override-method)
a1506d29 6808 (methods (and (stringp article)
16409b0b 6809 gnus-refer-article-method))
23f87bed
MB		 6810 (backend (car (gnus-find-method-for-group
6811 gnus-newsgroup-name)))
16409b0b 6812 result
4e7d0221 6813 (inhibit-read-only t))
e0bad764
DL		 6814 (if (or (not (listp methods))
6815 (and (symbolp (car methods))
6816 (assq (car methods) nnoo-definition-alist)))
6817 (setq methods (list methods)))
16409b0b
GM		 6818 (when (and (null gnus-override-method)
6819 methods)
6820 (setq gnus-override-method (pop methods)))
6821 (while (not result)
6822 (when (eq gnus-override-method 'current)
c55f89a5
GM		 6823 (setq gnus-override-method
6824 (with-current-buffer gnus-summary-buffer
6825 gnus-current-select-method)))
16409b0b
GM		 6826 (erase-buffer)
6827 (gnus-kill-all-overlays)
6828 (let ((gnus-newsgroup-name group))
6829 (gnus-check-group-server))
23f87bed
MB		 6830 (cond
6831 ((gnus-request-article article group (current-buffer))
16409b0b 6832 (when (numberp article)
a1506d29 6833 (gnus-async-prefetch-next group article
16409b0b
GM		 6834 gnus-summary-buffer)
6835 (when gnus-keep-backlog
6836 (gnus-backlog-enter-article
6837 group article (current-buffer))))
6838 (setq result 'article))
23f87bed
MB		 6839 (methods
6840 (setq gnus-override-method (pop methods)))
6841 ((not (string-match "^400 "
6842 (nnheader-get-report backend)))
6843 ;; If we get 400 server disconnect, reconnect and
6844 ;; retry; otherwise, assume the article has expired.
6845 (setq result 'done))))
16409b0b 6846 (and (eq result 'article) 'article)))
eec82323
LMI		 6847 ;; It was a pseudo.
6848 (t article)))
6849
6748645f
LMI		 6850 ;; Associate this article with the current summary buffer.
6851 (setq gnus-article-current-summary gnus-summary-buffer)
6852
eec82323
LMI		 6853 ;; Take the article from the original article buffer
6854 ;; and place it in the buffer it's supposed to be in.
6855 (when (and (get-buffer gnus-article-buffer)
eec82323
LMI		 6856 (equal (buffer-name (current-buffer))
6857 (buffer-name (get-buffer gnus-article-buffer))))
6858 (save-excursion
6859 (if (get-buffer gnus-original-article-buffer)
6748645f
LMI		 6860 (set-buffer gnus-original-article-buffer)
6861 (set-buffer (gnus-get-buffer-create gnus-original-article-buffer))
16409b0b 6862 (buffer-disable-undo)
eec82323 6863 (setq major-mode 'gnus-original-article-mode)
6748645f 6864 (setq buffer-read-only t))
23f87bed 6865 (let ((inhibit-read-only t))
eec82323
LMI		 6866 (erase-buffer)
6867 (insert-buffer-substring gnus-article-buffer))
16409b0b
GM		 6868 (setq gnus-original-article (cons group article)))
6869
6870 ;; Decode charsets.
6871 (run-hooks 'gnus-article-decode-hook)
6872 ;; Mark article as decoded or not.
6873 (setq gnus-article-decoded-p gnus-article-decode-hook))
eec82323
LMI		 6874
6875 ;; Update sparse articles.
6876 (when (and do-update-line
6877 (or (numberp article)
6878 (stringp article)))
6879 (let ((buf (current-buffer)))
6880 (set-buffer gnus-summary-buffer)
6748645f 6881 (gnus-summary-update-article do-update-line sparse-header)
eec82323 6882 (gnus-summary-goto-subject do-update-line nil t)
23f87bed 6883 (set-window-point (gnus-get-buffer-window (current-buffer) t)
eec82323
LMI		 6884 (point))
6885 (set-buffer buf))))))
6886
2526f423
G		 6887(defun gnus-block-private-groups (group)
6888 (if (gnus-news-group-p group)
6889 ;; Block nothing in news groups.
6890 nil
6891 ;; Block everything anywhere else.
6892 "."))
6893
6894(defun gnus-blocked-images ()
6895 (if (functionp gnus-blocked-images)
6896 (funcall gnus-blocked-images gnus-newsgroup-name)
6897 gnus-blocked-images))
6898
eec82323
LMI		 6899;;;
6900;;; Article editing
6901;;;
6902
6903(defcustom gnus-article-edit-mode-hook nil
6904 "Hook run in article edit mode buffers."
6905 :group 'gnus-article-various
6906 :type 'hook)
6907
6908(defvar gnus-article-edit-done-function nil)
6909
6910(defvar gnus-article-edit-mode-map nil)
6911
16409b0b 6912;; Should we be using derived.el for this?
eec82323 6913(unless gnus-article-edit-mode-map
23f87bed 6914 (setq gnus-article-edit-mode-map (make-keymap))
16409b0b 6915 (set-keymap-parent gnus-article-edit-mode-map text-mode-map)
eec82323
LMI		 6916
6917 (gnus-define-keys gnus-article-edit-mode-map
23f87bed 6918 "\C-c?" describe-mode
eec82323 6919 "\C-c\C-c" gnus-article-edit-done
23f87bed
MB		 6920 "\C-c\C-k" gnus-article-edit-exit
6921 "\C-c\C-f\C-t" message-goto-to
6922 "\C-c\C-f\C-o" message-goto-from
6923 "\C-c\C-f\C-b" message-goto-bcc
6924 ;;"\C-c\C-f\C-w" message-goto-fcc
6925 "\C-c\C-f\C-c" message-goto-cc
6926 "\C-c\C-f\C-s" message-goto-subject
6927 "\C-c\C-f\C-r" message-goto-reply-to
6928 "\C-c\C-f\C-n" message-goto-newsgroups
6929 "\C-c\C-f\C-d" message-goto-distribution
6930 "\C-c\C-f\C-f" message-goto-followup-to
6931 "\C-c\C-f\C-m" message-goto-mail-followup-to
6932 "\C-c\C-f\C-k" message-goto-keywords
6933 "\C-c\C-f\C-u" message-goto-summary
6934 "\C-c\C-f\C-i" message-insert-or-toggle-importance
6935 "\C-c\C-f\C-a" message-generate-unsubscribed-mail-followup-to
6936 "\C-c\C-b" message-goto-body
6937 "\C-c\C-i" message-goto-signature
6938
6939 "\C-c\C-t" message-insert-to
6940 "\C-c\C-n" message-insert-newsgroups
6941 "\C-c\C-o" message-sort-headers
6942 "\C-c\C-e" message-elide-region
6943 "\C-c\C-v" message-delete-not-region
6944 "\C-c\C-z" message-kill-to-signature
6945 "\M-\r" message-newline-and-reformat
6946 "\C-c\C-a" mml-attach-file
6947 "\C-a" message-beginning-of-line
6948 "\t" message-tab
6949 "\M-;" comment-region)
eec82323
LMI		 6950
6951 (gnus-define-keys (gnus-article-edit-wash-map
6952 "\C-c\C-w" gnus-article-edit-mode-map)
6953 "f" gnus-article-edit-full-stops))
6954
23f87bed
MB		 6955(easy-menu-define
6956 gnus-article-edit-mode-field-menu gnus-article-edit-mode-map ""
6957 '("Field"
6958 ["Fetch To" message-insert-to t]
6959 ["Fetch Newsgroups" message-insert-newsgroups t]
6960 "----"
6961 ["To" message-goto-to t]
6962 ["From" message-goto-from t]
6963 ["Subject" message-goto-subject t]
6964 ["Cc" message-goto-cc t]
6965 ["Reply-To" message-goto-reply-to t]
6966 ["Summary" message-goto-summary t]
6967 ["Keywords" message-goto-keywords t]
6968 ["Newsgroups" message-goto-newsgroups t]
6969 ["Followup-To" message-goto-followup-to t]
6970 ["Mail-Followup-To" message-goto-mail-followup-to t]
6971 ["Distribution" message-goto-distribution t]
6972 ["Body" message-goto-body t]
6973 ["Signature" message-goto-signature t]))
6974
4e7d0221 6975(define-derived-mode gnus-article-edit-mode message-mode "Article Edit"
eec82323
LMI		 6976 "Major mode for editing articles.
6977This is an extended text-mode.
6978
6979\\{gnus-article-edit-mode-map}"
eec82323
LMI		 6980 (make-local-variable 'gnus-article-edit-done-function)
6981 (make-local-variable 'gnus-prev-winconf)
80b47379
SZ		 6982 (set (make-local-variable 'font-lock-defaults)
6983 '(message-font-lock-keywords t))
23f87bed
MB		 6984 (set (make-local-variable 'mail-header-separator) "")
6985 (set (make-local-variable 'gnus-article-edit-mode) t)
6986 (easy-menu-add message-mode-field-menu message-mode-map)
6987 (mml-mode)
eec82323
LMI		 6988 (setq buffer-read-only nil)
6989 (buffer-enable-undo)
80b47379 6990 (widen))
eec82323
LMI		 6991
6992(defun gnus-article-edit (&optional force)
6993 "Edit the current article.
6994This will have permanent effect only in mail groups.
6995If FORCE is non-nil, allow editing of articles even in read-only
6996groups."
6997 (interactive "P")
6998 (when (and (not force)
6999 (gnus-group-read-only-p))
a8151ef7 7000 (error "The current newsgroup does not support article editing"))
6748645f 7001 (gnus-article-date-original)
eec82323 7002 (gnus-article-edit-article
16409b0b 7003 'ignore
6748645f 7004 `(lambda (no-highlight)
16409b0b 7005 'ignore
eec82323
LMI		 7006 (gnus-summary-edit-article-done
7007 ,(or (mail-header-references gnus-current-headers) "")
6748645f 7008 ,(gnus-group-read-only-p) ,gnus-summary-buffer no-highlight))))
eec82323 7009
01c52d31 7010(defun gnus-article-edit-article (start-func exit-func &optional quiet)
eec82323
LMI		 7011 "Start editing the contents of the current article buffer."
7012 (let ((winconf (current-window-configuration)))
7013 (set-buffer gnus-article-buffer)
0683d241
MB		 7014 (let ((message-auto-save-directory
7015 ;; Don't associate the article buffer with a draft file.
7016 nil))
7017 (gnus-article-edit-mode))
16409b0b 7018 (funcall start-func)
23f87bed 7019 (set-buffer-modified-p nil)
eec82323
LMI		 7020 (gnus-configure-windows 'edit-article)
7021 (setq gnus-article-edit-done-function exit-func)
7022 (setq gnus-prev-winconf winconf)
01c52d31
MB		 7023 (unless quiet
7024 (gnus-message 6 "C-c C-c to end edits"))))
eec82323 7025
6748645f 7026(defun gnus-article-edit-done (&optional arg)
eec82323 7027 "Update the article edits and exit."
6748645f 7028 (interactive "P")
eec82323
LMI		 7029 (let ((func gnus-article-edit-done-function)
7030 (buf (current-buffer))
23f87bed
MB		 7031 (start (window-start))
7032 (p (point))
7033 (winconf gnus-prev-winconf))
7034 (widen) ;; Widen it in case that users narrowed the buffer.
7035 (funcall func arg)
7036 (set-buffer buf)
7037 ;; The cache and backlog have to be flushed somewhat.
7038 (when gnus-keep-backlog
7039 (gnus-backlog-remove-article
7040 (car gnus-article-current) (cdr gnus-article-current)))
7041 ;; Flush original article as well.
8ccbef23 7042 (gnus-flush-original-article-buffer)
23f87bed
MB		 7043 (when gnus-use-cache
7044 (gnus-cache-update-article
7045 (car gnus-article-current) (cdr gnus-article-current)))
7046 ;; We remove all text props from the article buffer.
7047 (kill-all-local-variables)
01c52d31 7048 (set-text-properties (point-min) (point-max) nil)
23f87bed
MB		 7049 (gnus-article-mode)
7050 (set-window-configuration winconf)
eec82323
LMI		 7051 (set-buffer buf)
7052 (set-window-start (get-buffer-window buf) start)
23f87bed
MB		 7053 (set-window-point (get-buffer-window buf) (point)))
7054 (gnus-summary-show-article))
eec82323 7055
8ccbef23
G		 7056(defun gnus-flush-original-article-buffer ()
7057 (when (get-buffer gnus-original-article-buffer)
7058 (with-current-buffer gnus-original-article-buffer
7059 (setq gnus-original-article nil))))
7060
eec82323
LMI		 7061(defun gnus-article-edit-exit ()
7062 "Exit the article editing without updating."
7063 (interactive)
23f87bed
MB		 7064 (when (or (not (buffer-modified-p))
7065 (yes-or-no-p "Article modified; kill anyway? "))
7066 (let ((curbuf (current-buffer))
7067 (p (point))
7068 (window-start (window-start)))
7069 (erase-buffer)
7070 (if (gnus-buffer-live-p gnus-original-article-buffer)
d8a88581 7071 (insert-buffer-substring gnus-original-article-buffer))
23f87bed
MB		 7072 (let ((winconf gnus-prev-winconf))
7073 (kill-all-local-variables)
7074 (gnus-article-mode)
7075 (set-window-configuration winconf)
7076 ;; Tippy-toe some to make sure that point remains where it was.
7077 (save-current-buffer
7078 (set-buffer curbuf)
7079 (set-window-start (get-buffer-window (current-buffer)) window-start)
7080 (goto-char p))))
7081 (gnus-summary-show-article)))
eec82323
LMI		 7082
7083(defun gnus-article-edit-full-stops ()
7084 "Interactively repair spacing at end of sentences."
7085 (interactive)
7086 (save-excursion
7087 (goto-char (point-min))
7088 (search-forward-regexp "^$" nil t)
7089 (let ((case-fold-search nil))
7090 (query-replace-regexp "\\([.!?][])}]* \\)\\([[({A-Z]\\)" "\\1 \\2"))))
7091
7092;;;
7093;;; Article highlights
7094;;;
7095
7096;; Written by Per Abrahamsen <abraham@iesd.auc.dk>.
7097
7098;;; Internal Variables:
7099
a1506d29 7100(defcustom gnus-button-url-regexp
01c52d31
MB		 7101 (concat
7102 "\\b\\(\\(www\\.\\|\\(s?https?\\|ftp\\|file\\|gopher\\|"
7103 "nntp\\|news\\|telnet\\|wais\\|mailto\\|info\\):\\)"
7104 "\\(//[-a-z0-9_.]+:[0-9]*\\)?"
7105 (if (string-match "[[:digit:]]" "1") ;; Support POSIX?
7106 (let ((chars "-a-z0-9_=#$@~%&*+\\/[:word:]")
7107 (punct "!?:;.,"))
7108 (concat
7109 "\\(?:"
7110 ;; Match paired parentheses, e.g. in Wikipedia URLs:
9b3ebcb6
MB		 7111 ;; http://thread.gmane.org/47B4E3B2.3050402@gmail.com
7112 "[" chars punct "]+" "(" "[" chars punct "]+" "[" chars "]*)" "[" chars "]*"
01c52d31
MB		 7113 "\\|"
7114 "[" chars punct "]+" "[" chars "]"
7115 "\\)"))
7116 (concat ;; XEmacs 21.4 doesn't support POSIX.
7117 "\\([-a-z0-9_=!?#$@~%&*+\\/:;.,]\\|\\w\\)+"
7118 "\\([-a-z0-9_=#$@~%&*+\\/]\\|\\w\\)"))
7119 "\\)")
eec82323
LMI		 7120 "Regular expression that matches URLs."
7121 :group 'gnus-article-buttons
7122 :type 'regexp)
7123
23f87bed
MB		 7124(defcustom gnus-button-valid-fqdn-regexp
7125 message-valid-fqdn-regexp
7126 "Regular expression that matches a valid FQDN."
bf247b6e 7127 :version "22.1"
23f87bed
MB		 7128 :group 'gnus-article-buttons
7129 :type 'regexp)
7130
97f78c9b
MB		 7131;; Regexp suggested by Felix Wiemann in <87oeuomcz9.fsf@news2.ososo.de>
7132(defcustom gnus-button-valid-localpart-regexp
14e6dc54 7133 "[a-z0-9$%(*-=?[_][^<>\")!;:,{}\n\t @]*"
97f78c9b
MB		 7134 "Regular expression that matches a localpart of mail addresses or MIDs."
7135 :version "22.1"
7136 :group 'gnus-article-buttons
7137 :type 'regexp)
7138
23f87bed
MB		 7139(defcustom gnus-button-man-handler 'manual-entry
7140 "Function to use for displaying man pages.
7141The function must take at least one argument with a string naming the
7142man page."
bf247b6e 7143 :version "22.1"
23f87bed
MB		 7144 :type '(choice (function-item :tag "Man" manual-entry)
7145 (function-item :tag "Woman" woman)
7146 (function :tag "Other"))
7147 :group 'gnus-article-buttons)
7148
23f87bed 7149(defcustom gnus-button-mid-or-mail-regexp
97f78c9b 7150 (concat "\\b\\(<?" gnus-button-valid-localpart-regexp "@"
23f87bed
MB		 7151 gnus-button-valid-fqdn-regexp
7152 ">?\\)\\b")
7153 "Regular expression that matches a message ID or a mail address."
bf247b6e 7154 :version "22.1"
23f87bed
MB		 7155 :group 'gnus-article-buttons
7156 :type 'regexp)
7157
7158(defcustom gnus-button-prefer-mid-or-mail 'gnus-button-mid-or-mail-heuristic
7159 "What to do when the button on a string as \"foo123@bar.invalid\" is pushed.
7160Strings like this can be either a message ID or a mail address. If it is one
7161of the symbols `mid' or `mail', Gnus will always assume that the string is a
7162message ID or a mail address, respectively. If this variable is set to the
7163symbol `ask', always query the user what do do. If it is a function, this
aa819354 7164function will be called with the string as its only argument. The function
23f87bed 7165must return `mid', `mail', `invalid' or `ask'."
bf247b6e 7166 :version "22.1"
23f87bed
MB		 7167 :group 'gnus-article-buttons
7168 :type '(choice (function-item :tag "Heuristic function"
7169 gnus-button-mid-or-mail-heuristic)
7170 (const ask)
7171 (const mid)
7172 (const mail)))
7173
7174(defcustom gnus-button-mid-or-mail-heuristic-alist
7175 '((-10.0 . ".+\\$.+@")
7176 (-10.0 . "#")
7177 (-10.0 . "\\*")
7178 (-5.0 . "\\+[^+]*\\+.*@") ;; # two plus signs
7179 (-5.0 . "@[Nn][Ee][Ww][Ss]") ;; /\@news/i
7180 (-5.0 . "@.*[Dd][Ii][Aa][Ll][Uu][Pp]") ;; /\@.*dialup/i;
7181 (-1.0 . "^[^a-z]+@")
7182 ;;
7183 (-5.0 . "\\.[0-9][0-9]+.*@") ;; "\.[0-9]{2,}.*\@"
7184 (-5.0 . "[a-z].*[A-Z].*[a-z].*[A-Z].*@") ;; "([a-z].*[A-Z].*){2,}\@"
7185 (-3.0 . "[A-Z][A-Z][a-z][a-z].*@")
7186 (-5.0 . "\\...?.?@") ;; (-5.0 . "\..{1,3}\@")
7187 ;;
7188 (-2.0 . "^[0-9]")
7189 (-1.0 . "^[0-9][0-9]")
7190 ;;
7191 ;; -3.0 /^[0-9][0-9a-fA-F]{2,2}/;
7192 (-3.0 . "^[0-9][0-9a-fA-F][0-9a-fA-F][^0-9a-fA-F]")
7193 ;; -5.0 /^[0-9][0-9a-fA-F]{3,3}/;
7194 (-5.0 . "^[0-9][0-9a-fA-F][0-9a-fA-F][0-9a-fA-F][^0-9a-fA-F]")
7195 ;;
7196 (-3.0 . "[0-9][0-9][0-9][0-9][0-9][^0-9].*@") ;; "[0-9]{5,}.*\@"
7197 (-3.0 . "[0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][^0-9].*@")
7198 ;; "[0-9]{8,}.*\@"
7199 (-3.0
7200 . "[0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9].*@")
7201 ;; "[0-9]{12,}.*\@"
7202 ;; compensation for TDMA dated mail addresses:
7203 (25.0 . "-dated-[0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9]+.*@")
7204 ;;
7205 (-20.0 . "\\.fsf@") ;; Gnus
7206 (-20.0 . "^slrn")
7207 (-20.0 . "^Pine")
437ce4be 7208 (-20.0 . "^alpine\\.")
23f87bed
MB		 7209 (-20.0 . "_-_") ;; Subject change in thread
7210 ;;
7211 (-20.0 . "\\.ln@") ;; leafnode
7212 (-30.0 . "@ID-[0-9]+\\.[a-zA-Z]+\\.dfncis\\.de")
7213 (-30.0 . "@4[Aa][Xx]\\.com") ;; Forte Agent
7214 ;;
7215 ;; (5.0 . "") ;; $local_part_len <= 7
7216 (10.0 . "^[^0-9]+@")
7217 (3.0 . "^[^0-9]+[0-9][0-9]?[0-9]?@")
7218 ;; ^[^0-9]+[0-9]{1,3}\@ digits only at end of local part
7219 (3.0 . "\@stud")
7220 ;;
7221 (2.0 . "[a-z][a-z][._-][A-Z][a-z].*@")
7222 ;;
7223 (0.5 . "^[A-Z][a-z]")
7224 (0.5 . "^[A-Z][a-z][a-z]")
7225 (1.5 . "^[A-Z][a-z][A-Z][a-z][^a-z]") ;; ^[A-Z][a-z]{3,3}
7226 (2.0 . "^[A-Z][a-z][A-Z][a-z][a-z][^a-z]")) ;; ^[A-Z][a-z]{4,4}
7227 "An alist of \(RATE . REGEXP\) pairs for `gnus-button-mid-or-mail-heuristic'.
7228
7229A negative RATE indicates a message IDs, whereas a positive indicates a mail
7230address. The REGEXP is processed with `case-fold-search' set to nil."
bf247b6e 7231 :version "22.1"
23f87bed
MB		 7232 :group 'gnus-article-buttons
7233 :type '(repeat (cons (number :tag "Rate")
7234 (regexp :tag "Regexp"))))
7235
7236(defun gnus-button-mid-or-mail-heuristic (mid-or-mail)
7237 "Guess whether MID-OR-MAIL is a message ID or a mail address.
7238Returns `mid' if MID-OR-MAIL is a message IDs, `mail' if it's a mail
7239address, `ask' if unsure and `invalid' if the string is invalid."
7240 (let ((case-fold-search nil)
7241 (list gnus-button-mid-or-mail-heuristic-alist)
7242 (result 0) rate regexp lpartlen elem)
7243 (setq lpartlen
7244 (length (gnus-replace-in-string mid-or-mail "^\\(.*\\)@.*$" "\\1")))
7245 (gnus-message 8 "`%s', length of local part=`%s'." mid-or-mail lpartlen)
7246 ;; Certain special cases...
7247 (when (string-match
7248 (concat
7249 "^0[0-9]+-[0-9][0-9][0-9][0-9]@t-online\\.de$\\|"
7250 "^[0-9]+\\.[0-9]+@compuserve\\|"
7251 "@public\\.gmane\\.org")
7252 mid-or-mail)
7253 (gnus-message 8 "`%s' is a known mail address." mid-or-mail)
7254 (setq result 'mail))
7255 (when (string-match "@.*@\\| " mid-or-mail)
7256 (gnus-message 8 "`%s' is invalid." mid-or-mail)
7257 (setq result 'invalid))
7258 ;; Nothing more to do, if result is not a number here...
7259 (when (numberp result)
7260 (while list
7261 (setq elem (car list)
7262 rate (car elem)
7263 regexp (cdr elem)
7264 list (cdr list))
7265 (when (string-match regexp mid-or-mail)
7266 (setq result (+ result rate))
7267 (gnus-message
7268 9 "`%s' matched `%s', rate `%s', result `%s'."
7269 mid-or-mail regexp rate result)))
7270 (when (<= lpartlen 7)
7271 (setq result (+ result 5.0))
7272 (gnus-message 9 "`%s' matched (<= lpartlen 7), result `%s'."
7273 mid-or-mail result))
7274 (when (>= lpartlen 12)
7275 (gnus-message 9 "`%s' matched (>= lpartlen 12)" mid-or-mail)
7276 (cond
7277 ((string-match "[0-9][^0-9]+[0-9].*@" mid-or-mail)
7278 ;; Long local part should contain realname if e-mail address,
7279 ;; too many digits: message-id.
7280 ;; $score -= 5.0 + 0.1 * $local_part_len;
7281 (setq rate (* -1.0 (+ 5.0 (* 0.1 lpartlen))))
7282 (setq result (+ result rate))
7283 (gnus-message
7284 9 "Many digits in `%s', rate `%s', result `%s'."
7285 mid-or-mail rate result))
7286 ((string-match "[^aeiouy][^aeiouy][^aeiouy][^aeiouy]+.*\@"
7287 mid-or-mail)
7288 ;; Too few vowels [^aeiouy]{4,}.*\@
7289 (setq result (+ result -5.0))
7290 (gnus-message
7291 9 "Few vowels in `%s', rate `%s', result `%s'."
7292 mid-or-mail -5.0 result))
7293 (t
7294 (setq result (+ result 5.0))
7295 (gnus-message
7296 9 "`%s', rate `%s', result `%s'." mid-or-mail 5.0 result)))))
7297 (gnus-message 8 "`%s': Final rate is `%s'." mid-or-mail result)
7298 ;; Maybe we should make this a customizable alist: (condition . 'result)
7299 (cond
7300 ((symbolp result) result)
7301 ;; Now convert number into proper results:
7302 ((< result -10.0) 'mid)
7303 ((> result 10.0) 'mail)
7304 (t 'ask))))
7305
7306(defun gnus-button-handle-mid-or-mail (mid-or-mail)
7307 (let* ((pref gnus-button-prefer-mid-or-mail) guessed
7308 (url-mid (concat "news" ":" mid-or-mail))
7309 (url-mailto (concat "mailto" ":" mid-or-mail)))
7310 (gnus-message 9 "mid-or-mail=%s" mid-or-mail)
7311 (when (fboundp pref)
7312 (setq guessed
7313 ;; get rid of surrounding angles...
7314 (funcall pref
7315 (gnus-replace-in-string mid-or-mail "^<\\|>$" "")))
7316 (if (or (eq 'mid guessed) (eq 'mail guessed))
7317 (setq pref guessed)
7318 (setq pref 'ask)))
7319 (if (eq pref 'ask)
7320 (save-window-excursion
7321 (if (y-or-n-p (concat "Is <" mid-or-mail "> a mail address? "))
7322 (setq pref 'mail)
7323 (setq pref 'mid))))
7324 (cond ((eq pref 'mid)
7325 (gnus-message 8 "calling `gnus-button-handle-news' %s" url-mid)
7326 (gnus-button-handle-news url-mid))
7327 ((eq pref 'mail)
7328 (gnus-message 8 "calling `gnus-url-mailto' %s" url-mailto)
7329 (gnus-url-mailto url-mailto))
7330 (t (gnus-message 3 "Invalid string.")))))
7331
01c52d31
MB		 7332(defun gnus-button-handle-custom (fun arg)
7333 "Call function FUN on argument ARG.
7334Both FUN and ARG are supposed to be strings. ARG will be passed
7335as a symbol to FUN."
7336 (funcall (intern fun)
7337 (if (string-match "^customize-apropos" fun)
7338 arg
7339 (intern arg))))
23f87bed
MB		 7340
7341(defvar gnus-button-handle-describe-prefix "^\\(C-h\\|<?[Ff]1>?\\)")
7342
7343;; FIXME: Maybe we should merge some of the functions that do quite similar
7344;; stuff?
7345
7346(defun gnus-button-handle-describe-function (url)
7347 "Call `describe-function' when pushing the corresponding URL button."
7348 (describe-function
7349 (intern
7350 (gnus-replace-in-string url gnus-button-handle-describe-prefix ""))))
7351
7352(defun gnus-button-handle-describe-variable (url)
7353 "Call `describe-variable' when pushing the corresponding URL button."
7354 (describe-variable
7355 (intern
7356 (gnus-replace-in-string url gnus-button-handle-describe-prefix ""))))
7357
7358(defun gnus-button-handle-symbol (url)
7359"Display help on variable or function.
7360Calls `describe-variable' or `describe-function'."
7361 (let ((sym (intern url)))
7362 (cond
7363 ((fboundp sym) (describe-function sym))
7364 ((boundp sym) (describe-variable sym))
7365 (t (gnus-message 3 "`%s' is not a known function of variable." url)))))
7366
7367(defun gnus-button-handle-describe-key (url)
7368 "Call `describe-key' when pushing the corresponding URL button."
7369 (let* ((key-string
7370 (gnus-replace-in-string url gnus-button-handle-describe-prefix ""))
7371 (keys (ignore-errors (eval `(kbd ,key-string)))))
7372 (if keys
7373 (describe-key keys)
7374 (gnus-message 3 "Invalid key sequence in button: %s" key-string))))
7375
7376(defun gnus-button-handle-apropos (url)
7377 "Call `apropos' when pushing the corresponding URL button."
7378 (apropos (gnus-replace-in-string url gnus-button-handle-describe-prefix "")))
7379
7380(defun gnus-button-handle-apropos-command (url)
7381 "Call `apropos' when pushing the corresponding URL button."
7382 (apropos-command
7383 (gnus-replace-in-string url gnus-button-handle-describe-prefix "")))
7384
7385(defun gnus-button-handle-apropos-variable (url)
7386 "Call `apropos' when pushing the corresponding URL button."
7387 (funcall
7388 (if (fboundp 'apropos-variable) 'apropos-variable 'apropos)
7389 (gnus-replace-in-string url gnus-button-handle-describe-prefix "")))
7390
7391(defun gnus-button-handle-apropos-documentation (url)
7392 "Call `apropos' when pushing the corresponding URL button."
7393 (funcall
7394 (if (fboundp 'apropos-documentation) 'apropos-documentation 'apropos)
7395 (gnus-replace-in-string url gnus-button-handle-describe-prefix "")))
7396
7397(defun gnus-button-handle-library (url)
7398 "Call `locate-library' when pushing the corresponding URL button."
7399 (gnus-message 9 "url=`%s'" url)
7400 (let* ((lib (locate-library url))
7401 (file (gnus-replace-in-string (or lib "") "\.elc" ".el")))
7402 (if (not lib)
7403 (gnus-message 1 "Cannot locale library `%s'." url)
7404 (find-file-read-only file))))
7405
23f87bed
MB		 7406(defcustom gnus-button-man-level 5
7407 "*Integer that says how many man-related buttons Gnus will show.
7408The higher the number, the more buttons will appear and the more false
7409positives are possible. Note that you can set this variable local to
7410specific groups. Setting it higher in Unix groups is probably a good idea.
7411See Info node `(gnus)Group Parameters' and the variable `gnus-parameters' on
7412how to set variables in specific groups."
bf247b6e 7413 :version "22.1"
23f87bed
MB		 7414 :group 'gnus-article-buttons
7415 :link '(custom-manual "(gnus)Group Parameters")
7416 :type 'integer)
7417
7418(defcustom gnus-button-emacs-level 5
7419 "*Integer that says how many emacs-related buttons Gnus will show.
7420The higher the number, the more buttons will appear and the more false
7421positives are possible. Note that you can set this variable local to
7422specific groups. Setting it higher in Emacs or Gnus related groups is
7423probably a good idea. See Info node `(gnus)Group Parameters' and the variable
7424`gnus-parameters' on how to set variables in specific groups."
bf247b6e 7425 :version "22.1"
23f87bed
MB		 7426 :group 'gnus-article-buttons
7427 :link '(custom-manual "(gnus)Group Parameters")
7428 :type 'integer)
7429
7430(defcustom gnus-button-message-level 5
7431 "*Integer that says how many buttons for news or mail messages will appear.
7432The higher the number, the more buttons will appear and the more false
7433positives are possible."
7434 ;; mail addresses, MIDs, URLs for news, ...
bf247b6e 7435 :version "22.1"
23f87bed
MB		 7436 :group 'gnus-article-buttons
7437 :type 'integer)
7438
7439(defcustom gnus-button-browse-level 5
7440 "*Integer that says how many buttons for browsing will appear.
7441The higher the number, the more buttons will appear and the more false
7442positives are possible."
7443 ;; stuff handled by `browse-url' or `gnus-button-embedded-url'
bf247b6e 7444 :version "22.1"
23f87bed
MB		 7445 :group 'gnus-article-buttons
7446 :type 'integer)
7447
eec82323 7448(defcustom gnus-button-alist
23f87bed
MB		 7449 '(("<\\(url:[>\n\t ]*?\\)?\\(nntp\\|news\\):[>\n\t ]*\\([^>\n\t ]*@[^>\n\t ]*\\)>"
7450 0 (>= gnus-button-message-level 0) gnus-button-handle-news 3)
97f78c9b
MB		 7451 ((concat "\\b\\(nntp\\|news\\):\\("
7452 gnus-button-valid-localpart-regexp "@[a-z0-9.-]+[a-z]\\)")
7453 0 t gnus-button-handle-news 2)
23f87bed
MB		 7454 ("\\(\\b<\\(url:[>\n\t ]*\\)?\\(nntp\\|news\\):[>\n\t ]*\\(//\\)?\\([^>\n\t ]*\\)>\\)"
7455 1 (>= gnus-button-message-level 0) gnus-button-fetch-group 5)
7456 ("\\b\\(nntp\\|news\\):\\(//\\)?\\([^'\">\n\t ]+\\)"
7457 0 (>= gnus-button-message-level 0) gnus-button-fetch-group 3)
7458 ;; RFC 2392 (Don't allow `/' in domain part --> CID)
7459 ("\\bmid:\\(//\\)?\\([^'\">\n\t ]+@[^'\">\n\t /]+\\)"
7460 0 (>= gnus-button-message-level 0) gnus-button-message-id 2)
7461 ("\\bin\\( +article\\| +message\\)? +\\(<\\([^\n @<>]+@[^\n @<>]+\\)>\\)"
7462 2 (>= gnus-button-message-level 0) gnus-button-message-id 3)
01c52d31
MB		 7463 ("\\b\\(mid\\|message-id\\):? +\\(<\\([^\n @<>]+@[^\n @<>]+\\)>\\)"
7464 2 (>= gnus-button-message-level 0) gnus-button-message-id 3)
23f87bed
MB		 7465 ("\\(<URL: *\\)mailto: *\\([^> \n\t]+\\)>"
7466 0 (>= gnus-button-message-level 0) gnus-url-mailto 2)
7467 ;; RFC 2368 (The mailto URL scheme)
531e5812 7468 ("\\bmailto:\\([-a-z.@_+0-9%=?&/]+\\)"
23f87bed
MB		 7469 0 (>= gnus-button-message-level 0) gnus-url-mailto 1)
7470 ("\\bmailto:\\([^ \n\t]+\\)"
7471 0 (>= gnus-button-message-level 0) gnus-url-mailto 1)
9eb59592
MB		 7472 ;; Info Konqueror style <info:/foo/bar baz>.
7473 ;; Must come before " Gnus home-grown style".
7474 ("\\binfo://?\\([^'\">\n\t]+\\)"
7475 0 (>= gnus-button-emacs-level 1) gnus-button-handle-info-url 1)
7476 ;; Info, Gnus home-grown style (deprecated) <info://foo/bar+baz>
23f87bed
MB		 7477 ("\\binfo://\\([^'\">\n\t ]+\\)"
7478 0 (>= gnus-button-emacs-level 1) gnus-button-handle-info-url 1)
7479 ;; Info GNOME style <info:foo#bar_baz>
7480 ("\\binfo:\\([^('\n\t\r \"><][^'\n\t\r \"><]*\\)"
7481 0 (>= gnus-button-emacs-level 1) gnus-button-handle-info-url-gnome 1)
7482 ;; Info KDE style <info:(foo)bar baz>
7483 ("<\\(info:\\(([^)]+)[^>\n\r]*\\)\\)>"
7484 1 (>= gnus-button-emacs-level 1) gnus-button-handle-info-url-kde 2)
7485 ("\\((Info-goto-node\\|(info\\)[ \t\n]*\\(\"[^\"]*\"\\))" 0
7486 (>= gnus-button-emacs-level 1) gnus-button-handle-info-url 2)
9b3ebcb6
MB		 7487 ("\\b\\(C-h\\|<?[Ff]1>?\\)[ \t\n]+i[ \t\n]+d?[ \t\n]?m[ \t\n]+[^ ]+ ?[^ ]+[ \t\n]+RET\\([ \t\n]+i[ \t\n]+[^ ]+ ?[^ ]+[ \t\n]+RET\\([ \t\n,]*\\)\\)?"
7488 ;; Info links like `C-h i d m Gnus RET' or `C-h i d m Gnus RET i partial RET'
7489 0 (>= gnus-button-emacs-level 1) gnus-button-handle-info-keystrokes 0)
23f87bed 7490 ;; This is custom
e425f18b 7491 ("M-x[ \t\n]\\(customize-[^ ]+\\)[ \t\n]RET[ \t\n]\\([^ ]+\\)[ \t\n]RET\\>" 0
01c52d31 7492 (>= gnus-button-emacs-level 1) gnus-button-handle-custom 1 2)
23f87bed 7493 ;; Emacs help commands
e425f18b 7494 ("M-x[ \t\n]+apropos[ \t\n]+RET[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET\\>"
23f87bed
MB		 7495 ;; regexp doesn't match arguments containing ` '.
7496 0 (>= gnus-button-emacs-level 1) gnus-button-handle-apropos 1)
e425f18b 7497 ("M-x[ \t\n]+apropos-command[ \t\n]+RET[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET\\>"
23f87bed 7498 0 (>= gnus-button-emacs-level 1) gnus-button-handle-apropos-command 1)
e425f18b 7499 ("M-x[ \t\n]+apropos-variable[ \t\n]+RET[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET\\>"
23f87bed 7500 0 (>= gnus-button-emacs-level 1) gnus-button-handle-apropos-variable 1)
e425f18b 7501 ("M-x[ \t\n]+apropos-documentation[ \t\n]+RET[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET\\>"
23f87bed
MB		 7502 0 (>= gnus-button-emacs-level 1) gnus-button-handle-apropos-documentation 1)
7503 ;; The following entries may lead to many false positives so don't enable
531e5812
MB		 7504 ;; them by default (use a high button level).
7505 ("/\\([a-z][-a-z0-9]+\\.el\\)\\>[^.?]"
7506 ;; Exclude [.?] for URLs in gmane.emacs.cvs
23f87bed
MB		 7507 1 (>= gnus-button-emacs-level 8) gnus-button-handle-library 1)
7508 ("`\\([a-z][-a-z0-9]+\\.el\\)'"
7509 1 (>= gnus-button-emacs-level 8) gnus-button-handle-library 1)
01c52d31 7510 ("`\\([a-z][a-z0-9]+-[a-z0-9]+-[-a-z0-9]*[a-z]\\|\\(gnus\\|message\\)-[-a-z]+\\)'"
23f87bed
MB		 7511 0 (>= gnus-button-emacs-level 8) gnus-button-handle-symbol 1)
7512 ("`\\([a-z][a-z0-9]+-[a-z]+\\)'"
7513 0 (>= gnus-button-emacs-level 9) gnus-button-handle-symbol 1)
7514 ("(setq[ \t\n]+\\([a-z][a-z0-9]+-[-a-z0-9]+\\)[ \t\n]+.+)"
7515 1 (>= gnus-button-emacs-level 7) gnus-button-handle-describe-variable 1)
e425f18b 7516 ("\\bM-x[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET\\>"
23f87bed 7517 1 (>= gnus-button-emacs-level 7) gnus-button-handle-describe-function 1)
e425f18b 7518 ("\\b\\(C-h\\|<?[Ff]1>?\\)[ \t\n]+f[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET\\>"
23f87bed 7519 0 (>= gnus-button-emacs-level 1) gnus-button-handle-describe-function 2)
e425f18b 7520 ("\\b\\(C-h\\|<?[Ff]1>?\\)[ \t\n]+v[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET\\>"
23f87bed 7521 0 (>= gnus-button-emacs-level 1) gnus-button-handle-describe-variable 2)
87ba2830 7522 ("`\\(\\(C-h\\|<?[Ff]1>?\\)[ \t\n]+k[ \t\n]+\\([^']+\\)\\)'"
23f87bed
MB		 7523 ;; Unlike the other regexps we really have to require quoting
7524 ;; here to determine where it ends.
7525 1 (>= gnus-button-emacs-level 1) gnus-button-handle-describe-key 3)
7526 ;; This is how URLs _should_ be embedded in text (RFC 1738, RFC 2396)...
01c52d31 7527 ("<URL: *\\([^\n<>]*\\)>"
23f87bed
MB		 7528 1 (>= gnus-button-browse-level 0) gnus-button-embedded-url 1)
7529 ;; RFC 2396 (2.4.3., delims) ...
01c52d31 7530 ("\"URL: *\\([^\n\"]*\\)\""
23f87bed 7531 1 (>= gnus-button-browse-level 0) gnus-button-embedded-url 1)
eec82323 7532 ;; Raw URLs.
23f87bed
MB		 7533 (gnus-button-url-regexp
7534 0 (>= gnus-button-browse-level 0) browse-url 0)
7535 ;; man pages
531e5812 7536 ("\\b\\([a-z][a-z]+([1-9])\\)\\W"
23f87bed
MB		 7537 0 (and (>= gnus-button-man-level 1) (< gnus-button-man-level 3))
7538 gnus-button-handle-man 1)
7539 ;; more man pages: resolv.conf(5), iso_8859-1(7), xterm(1x)
531e5812 7540 ("\\b\\([a-z][-_.a-z0-9]+([1-9])\\)\\W"
23f87bed
MB		 7541 0 (and (>= gnus-button-man-level 3) (< gnus-button-man-level 5))
7542 gnus-button-handle-man 1)
7543 ;; even more: Apache::PerlRun(3pm), PDL::IO::FastRaw(3pm),
7544 ;; SoWWWAnchor(3iv), XSelectInput(3X11), X(1), X(7)
531e5812 7545 ("\\b\\(\\(?:[a-z][-+_.:a-z0-9]+([1-9][X1a-z]*)\\)\\|\\b\\(?:X([1-9])\\)\\)\\W"
23f87bed 7546 0 (>= gnus-button-man-level 5) gnus-button-handle-man 1)
01c52d31
MB		 7547 ;; Recognizing patches to .el files. This is somewhat obscure,
7548 ;; but considering the percentage of Gnus users who hack Emacs
7549 ;; Lisp files...
7550 ("^--- \\([^ .]+\\.el\\).*\n.*\n@@ -?\\([0-9]+\\)" 1
7551 (>= gnus-button-message-level 4) gnus-button-patch 1 2)
7552 ("^\\*\\*\\* \\([^ .]+\\.el\\).*\n.*\n\\*+\n\\*\\*\\* \\([0-9]+\\)" 1
7553 (>= gnus-button-message-level 4) gnus-button-patch 1 2)
23f87bed
MB		 7554 ;; MID or mail: To avoid too many false positives we don't try to catch
7555 ;; all kind of allowed MIDs or mail addresses. Domain part must contain
7556 ;; at least one dot. TLD must contain two or three chars or be a know TLD
7557 ;; (info|name|...). Put this entry near the _end_ of `gnus-button-alist'
7558 ;; so that non-ambiguous entries (see above) match first.
7559 (gnus-button-mid-or-mail-regexp
7560 0 (>= gnus-button-message-level 5) gnus-button-handle-mid-or-mail 1))
6748645f 7561 "*Alist of regexps matching buttons in article bodies.
eec82323
LMI		 7562
7563Each entry has the form (REGEXP BUTTON FORM CALLBACK PAR...), where
23f87bed
MB		 7564REGEXP: is the string (case insensitive) matching text around the button (can
7565also be Lisp expression evaluating to a string),
eec82323 7566BUTTON: is the number of the regexp grouping actually matching the button,
4e7d0221 7567FORM: is a Lisp expression which must eval to true for the button to
eec82323
LMI		 7568be added,
7569CALLBACK: is the function to call when the user push this button, and each
7570PAR: is a number of a regexp grouping whose text will be passed to CALLBACK.
7571
7572CALLBACK can also be a variable, in that case the value of that
7573variable it the real callback function."
7574 :group 'gnus-article-buttons
23f87bed 7575 :type '(repeat (list (choice regexp variable sexp)
eec82323
LMI		 7576 (integer :tag "Button")
7577 (sexp :tag "Form")
7578 (function :tag "Callback")
7579 (repeat :tag "Par"
7580 :inline t
7581 (integer :tag "Regexp group")))))
60ece9b0 7582(put 'gnus-button-alist 'risky-local-variable t)
eec82323
LMI		 7583
7584(defcustom gnus-header-button-alist
23f87bed
MB		 7585 '(("^\\(References\\|Message-I[Dd]\\|^In-Reply-To\\):" "<[^<>]+>"
7586 0 (>= gnus-button-message-level 0) gnus-button-message-id 0)
7587 ("^\\(From\\|Reply-To\\):" ": *\\(.+\\)$"
7588 1 (>= gnus-button-message-level 0) gnus-button-reply 1)
eec82323 7589 ("^\\(Cc\\|To\\):" "[^ \t\n<>,()\"]+@[^ \t\n<>,()\"]+"
fa9a04e1 7590 0 (>= gnus-button-message-level 0) gnus-msg-mail 0)
23f87bed
MB		 7591 ("^X-[Uu][Rr][Ll]:" gnus-button-url-regexp
7592 0 (>= gnus-button-browse-level 0) browse-url 0)
7593 ("^Subject:" gnus-button-url-regexp
7594 0 (>= gnus-button-browse-level 0) browse-url 0)
7595 ("^[^:]+:" gnus-button-url-regexp
7596 0 (>= gnus-button-browse-level 0) browse-url 0)
01c52d31
MB		 7597 ("^OpenPGP:.*url=" gnus-button-url-regexp
7598 0 (>= gnus-button-browse-level 0) gnus-button-openpgp 0)
531e5812 7599 ("^[^:]+:" "\\bmailto:\\([-a-z.@_+0-9%=?&/]+\\)"
23f87bed
MB		 7600 0 (>= gnus-button-message-level 0) gnus-url-mailto 1)
7601 ("^[^:]+:" "\\(<\\(url: \\)?\\(nntp\\|news\\):\\([^>\n ]*\\)>\\)"
7602 1 (>= gnus-button-message-level 0) gnus-button-message-id 4))
6748645f 7603 "*Alist of headers and regexps to match buttons in article heads.
eec82323
LMI		 7604
7605This alist is very similar to `gnus-button-alist', except that each
7606alist has an additional HEADER element first in each entry:
7607
7608\(HEADER REGEXP BUTTON FORM CALLBACK PAR)
7609
7610HEADER is a regexp to match a header. For a fuller explanation, see
7611`gnus-button-alist'."
7612 :group 'gnus-article-buttons
7613 :group 'gnus-article-headers
7614 :type '(repeat (list (regexp :tag "Header")
23f87bed 7615 (choice regexp variable)
eec82323
LMI		 7616 (integer :tag "Button")
7617 (sexp :tag "Form")
7618 (function :tag "Callback")
7619 (repeat :tag "Par"
7620 :inline t
7621 (integer :tag "Regexp group")))))
60ece9b0 7622(put 'gnus-header-button-alist 'risky-local-variable t)
eec82323 7623
eec82323
LMI		 7624;;; Commands:
7625
7626(defun gnus-article-push-button (event)
7627 "Check text under the mouse pointer for a callback function.
7628If the text under the mouse pointer has a `gnus-callback' property,
7629call it with the value of the `gnus-data' text property."
7630 (interactive "e")
7631 (set-buffer (window-buffer (posn-window (event-start event))))
7632 (let* ((pos (posn-point (event-start event)))
23f87bed 7633 (data (get-text-property pos 'gnus-data))
eec82323 7634 (fun (get-text-property pos 'gnus-callback)))
6748645f 7635 (goto-char pos)
eec82323
LMI		 7636 (when fun
7637 (funcall fun data))))
7638
7639(defun gnus-article-press-button ()
7640 "Check text at point for a callback function.
7641If the text at point has a `gnus-callback' property,
7642call it with the value of the `gnus-data' text property."
7643 (interactive)
23f87bed
MB		 7644 (let ((data (get-text-property (point) 'gnus-data))
7645 (fun (get-text-property (point) 'gnus-callback)))
eec82323
LMI		 7646 (when fun
7647 (funcall fun data))))
7648
eec82323
LMI		 7649(defun gnus-article-highlight (&optional force)
7650 "Highlight current article.
7651This function calls `gnus-article-highlight-headers',
7652`gnus-article-highlight-citation',
7653`gnus-article-highlight-signature', and `gnus-article-add-buttons' to
7654do the highlighting. See the documentation for those functions."
7655 (interactive (list 'force))
7656 (gnus-article-highlight-headers)
7657 (gnus-article-highlight-citation force)
7658 (gnus-article-highlight-signature)
a2e3ac99 7659 (gnus-article-add-buttons)
eec82323
LMI		 7660 (gnus-article-add-buttons-to-head))
7661
7662(defun gnus-article-highlight-some (&optional force)
7663 "Highlight current article.
7664This function calls `gnus-article-highlight-headers',
7665`gnus-article-highlight-signature', and `gnus-article-add-buttons' to
7666do the highlighting. See the documentation for those functions."
7667 (interactive (list 'force))
7668 (gnus-article-highlight-headers)
7669 (gnus-article-highlight-signature)
7670 (gnus-article-add-buttons))
7671
7672(defun gnus-article-highlight-headers ()
7673 "Highlight article headers as specified by `gnus-header-face-alist'."
7674 (interactive)
01c52d31
MB		 7675 (gnus-with-article-headers
7676 (let (regexp header-face field-face from hpoints fpoints)
7677 (dolist (entry gnus-header-face-alist)
7678 (goto-char (point-min))
7679 (setq regexp (concat "^\\("
7680 (if (string-equal "" (nth 0 entry))
7681 "[^\t ]"
7682 (nth 0 entry))
7683 "\\)")
7684 header-face (nth 1 entry)
7685 field-face (nth 2 entry))
7686 (while (and (re-search-forward regexp nil t)
7687 (not (eobp)))
7688 (beginning-of-line)
7689 (setq from (point))
7690 (unless (search-forward ":" nil t)
7691 (forward-char 1))
7692 (when (and header-face
7693 (not (memq (point) hpoints)))
7694 (push (point) hpoints)
7695 (gnus-put-text-property from (point) 'face header-face))
7696 (when (and field-face
7697 (not (memq (setq from (point)) fpoints)))
7698 (push from fpoints)
7699 (if (re-search-forward "^[^ \t]" nil t)
7700 (forward-char -2)
7701 (goto-char (point-max)))
7702 (gnus-put-text-property from (point) 'face field-face)))))))
eec82323
LMI		 7703
7704(defun gnus-article-highlight-signature ()
7705 "Highlight the signature in an article.
7706It does this by highlighting everything after
0f49874b 7707`gnus-signature-separator' using the face `gnus-signature'."
eec82323 7708 (interactive)
01c52d31
MB		 7709 (gnus-with-article-buffer
7710 (let ((inhibit-point-motion-hooks t))
eec82323
LMI		 7711 (save-restriction
7712 (when (and gnus-signature-face
7713 (gnus-article-narrow-to-signature))
01c52d31 7714 (gnus-overlay-put (gnus-make-overlay (point-min) (point-max) nil t)
eec82323
LMI		 7715 'face gnus-signature-face)
7716 (widen)
7717 (gnus-article-search-signature)
7718 (let ((start (match-beginning 0))
7719 (end (set-marker (make-marker) (1+ (match-end 0)))))
7720 (gnus-article-add-button start (1- end) 'gnus-signature-toggle
7721 end)))))))
7722
7723(defun gnus-button-in-region-p (b e prop)
7724 "Say whether PROP exists in the region."
7725 (text-property-not-all b e prop nil))
7726
672022e7 7727(defun gnus-article-add-buttons ()
eec82323
LMI		 7728 "Find external references in the article and make buttons of them.
7729\"External references\" are things like Message-IDs and URLs, as
7730specified by `gnus-button-alist'."
672022e7 7731 (interactive)
01c52d31
MB		 7732 (gnus-with-article-buffer
7733 (let ((inhibit-point-motion-hooks t)
eec82323
LMI		 7734 (case-fold-search t)
7735 (alist gnus-button-alist)
7736 beg entry regexp)
eec82323 7737 ;; We skip the headers.
16409b0b 7738 (article-goto-body)
eec82323
LMI		 7739 (setq beg (point))
7740 (while (setq entry (pop alist))
23f87bed 7741 (setq regexp (eval (car entry)))
eec82323
LMI		 7742 (goto-char beg)
7743 (while (re-search-forward regexp nil t)
01c52d31
MB		 7744 (let ((start (match-beginning (nth 1 entry)))
7745 (end (match-end (nth 1 entry)))
7746 (from (match-beginning 0)))
672022e7 7747 (when (and (eval (nth 2 entry))
eec82323
LMI		 7748 (not (gnus-button-in-region-p
7749 start end 'gnus-callback)))
7750 ;; That optional form returned non-nil, so we add the
7751 ;; button.
01c52d31 7752 (setq from (set-marker (make-marker) from))
01c52d31
MB		 7753 (unless (and (eq (car entry) 'gnus-button-url-regexp)
7754 (gnus-article-extend-url-button from start end))
7755 (gnus-article-add-button start end
672022e7 7756 'gnus-button-push (list from entry))
7426b4f7
LMI		 7757 (gnus-put-text-property
7758 start end
10e91ca9
LMI		 7759 'gnus-string (buffer-substring-no-properties
7760 start end))))))))))
01c52d31
MB		 7761
7762(defun gnus-article-extend-url-button (beg start end)
7763 "Extend url button if url is folded into two or more lines.
7764Return non-nil if button is extended. BEG is a marker that points to
7765the beginning position of a text containing url. START and END are
7766the endpoints of a url button before it is extended. The concatenated
7767url is put as the `gnus-button-url' overlay property on the button."
7768 (let ((opoint (point))
7769 (points (list start end))
7770 url delim regexp)
7771 (prog1
7772 (when (and (progn
7773 (goto-char end)
7774 (not (looking-at "[\t ]*[\">]")))
7775 (progn
7776 (goto-char start)
7777 (string-match
7778 "\\(?:\"\\|\\(<\\)\\)[\t ]*\\(?:url[\t ]*:[\t ]*\\)?\\'"
7779 (buffer-substring (point-at-bol) start)))
7780 (progn
7781 (setq url (list (buffer-substring start end))
7782 delim (if (match-beginning 1) ">" "\""))
7783 (beginning-of-line)
7784 (setq regexp (concat
7785 (when (and (looking-at
7786 message-cite-prefix-regexp)
7787 (< (match-end 0) start))
7788 (regexp-quote (match-string 0)))
7789 "\
7790\[\t ]*\\(?:\\([^\t\n \">]+\\)[\t ]*$\\|\\([^\t\n \">]*\\)[\t ]*"
7791 delim "\\)"))
7792 (while (progn
7793 (forward-line 1)
7794 (and (looking-at regexp)
7795 (prog1
7796 (match-beginning 1)
7797 (push (or (match-string 2)
7798 (match-string 1))
7799 url)
7800 (push (setq end (or (match-end 2)
7801 (match-end 1)))
7802 points)
7803 (push (or (match-beginning 2)
7804 (match-beginning 1))
7805 points)))))
7806 (match-beginning 2)))
7807 (let (gnus-article-mouse-face widget-mouse-face)
7808 (while points
7809 (gnus-article-add-button (pop points) (pop points)
7810 'gnus-button-push beg)))
7811 (let ((overlay (gnus-make-overlay start end)))
7812 (gnus-overlay-put overlay 'evaporate t)
7813 (gnus-overlay-put overlay 'gnus-button-url
7814 (list (mapconcat 'identity (nreverse url) "")))
7815 (when gnus-article-mouse-face
7816 (gnus-overlay-put overlay 'mouse-face gnus-article-mouse-face)))
7817 t)
7818 (goto-char opoint))))
eec82323
LMI		 7819
7820;; Add buttons to the head of an article.
7821(defun gnus-article-add-buttons-to-head ()
7822 "Add buttons to the head of the article."
7823 (interactive)
01c52d31
MB		 7824 (gnus-with-article-headers
7825 (let (beg end)
7826 (dolist (entry gnus-header-button-alist)
7827 ;; Each alist entry.
7828 (goto-char (point-min))
7829 (while (re-search-forward (car entry) nil t)
7830 ;; Each header matching the entry.
7831 (setq beg (match-beginning 0))
7832 (setq end (or (and (re-search-forward "^[^ \t]" nil t)
7833 (match-beginning 0))
7834 (point-max)))
7835 (goto-char beg)
7836 (while (re-search-forward (eval (nth 1 entry)) end t)
7837 ;; Each match within a header.
7838 (let* ((entry (cdr entry))
7839 (start (match-beginning (nth 1 entry)))
7840 (end (match-end (nth 1 entry)))
7841 (form (nth 2 entry)))
7842 (goto-char (match-end 0))
7843 (when (eval form)
7844 (gnus-article-add-button
7845 start end (nth 3 entry)
7846 (buffer-substring (match-beginning (nth 4 entry))
7847 (match-end (nth 4 entry)))))))
7848 (goto-char end))))))
eec82323
LMI		 7849
7850;;; External functions:
7851
b1992461 7852(defun gnus-article-add-button (from to fun &optional data text)
eec82323
LMI		 7853 "Create a button between FROM and TO with callback FUN and data DATA."
7854 (when gnus-article-button-face
01c52d31 7855 (gnus-overlay-put (gnus-make-overlay from to nil t)
eec82323
LMI		 7856 'face gnus-article-button-face))
7857 (gnus-add-text-properties
7858 from to
7859 (nconc (and gnus-article-mouse-face
7860 (list gnus-mouse-face-prop gnus-article-mouse-face))
7861 (list 'gnus-callback fun)
16409b0b
GM		 7862 (and data (list 'gnus-data data))))
7863 (widget-convert-button 'link from to :action 'gnus-widget-press-button
b1992461 7864 :help-echo (or text "Follow the link")
7426b4f7 7865 :keymap gnus-url-button-map
16409b0b 7866 :button-keymap gnus-widget-button-keymap))
eec82323 7867
7426b4f7
LMI		 7868(defun gnus-article-copy-string ()
7869 "Copy the string in the button to the kill ring."
7870 (interactive)
7871 (gnus-article-check-buffer)
10e91ca9 7872 (let ((data (get-text-property (point) 'gnus-string)))
7426b4f7
LMI		 7873 (when data
7874 (with-temp-buffer
7875 (insert data)
c25d60ab
LMI		 7876 (copy-region-as-kill (point-min) (point-max))
7877 (message "Copied %s" data)))))
7426b4f7 7878
eec82323
LMI		 7879;;; Internal functions:
7880
a8151ef7 7881(defun gnus-article-set-globals ()
01c52d31 7882 (with-current-buffer gnus-summary-buffer
a8151ef7
LMI		 7883 (gnus-set-global-variables)))
7884
eec82323 7885(defun gnus-signature-toggle (end)
01c52d31
MB		 7886 (gnus-with-article-buffer
7887 (let ((inhibit-point-motion-hooks t))
520aa572 7888 (if (text-property-any end (point-max) 'article-type 'signature)
23f87bed
MB		 7889 (progn
7890 (gnus-delete-wash-type 'signature)
7891 (gnus-remove-text-properties-when
7892 'article-type 'signature end (point-max)
7893 (cons 'article-type (cons 'signature
7894 gnus-hidden-properties))))
7895 (gnus-add-wash-type 'signature)
520aa572
SZ		 7896 (gnus-add-text-properties-when
7897 'article-type nil end (point-max)
7898 (cons 'article-type (cons 'signature
23f87bed
MB		 7899 gnus-hidden-properties)))))
7900 (let ((gnus-article-mime-handle-alist-1 gnus-article-mime-handle-alist))
7901 (gnus-set-mode-line 'article))))
eec82323 7902
672022e7 7903(defun gnus-button-push (marker-and-entry)
eec82323
LMI		 7904 ;; Push button starting at MARKER.
7905 (save-excursion
672022e7
G		 7906 (let* ((marker (car marker-and-entry))
7907 (entry (cadr marker-and-entry))
7908 (regexp (car entry))
7909 (inhibit-point-motion-hooks t))
7910 (goto-char marker)
7911 ;; This is obviously true, or something bad is happening :)
7912 ;; But we need it to have the match-data
7913 (when (looking-at (or (if (symbolp regexp)
7914 (symbol-value regexp)
7915 regexp)))
7916 (let ((fun (nth 3 entry))
7917 (args (or (and (eq (car entry) 'gnus-button-url-regexp)
7918 (get-char-property marker 'gnus-button-url))
7919 (mapcar (lambda (group)
7920 (let ((string (match-string group)))
7921 (set-text-properties
7922 0 (length string) nil string)
7923 string))
7924 (nthcdr 4 entry)))))
7925
7926 (cond
7927 ((fboundp fun)
7928 (apply fun args))
7929 ((and (boundp fun)
7930 (fboundp (symbol-value fun)))
7931 (apply (symbol-value fun) args))
7932 (t
7933 (gnus-message 1 "You must define `%S' to use this button"
7934 (cons fun args)))))))))
eec82323 7935
23f87bed 7936(defun gnus-parse-news-url (url)
82a8ad04 7937 (let (scheme server port group message-id articles)
23f87bed
MB		 7938 (with-temp-buffer
7939 (insert url)
7940 (goto-char (point-min))
7941 (when (looking-at "\\([A-Za-z]+\\):")
7942 (setq scheme (match-string 1))
7943 (goto-char (match-end 0)))
82a8ad04 7944 (when (looking-at "//\\([^:/]+\\)\\(:?\\)\\([0-9]+\\)?/")
23f87bed 7945 (setq server (match-string 1))
82a8ad04
MB		 7946 (setq port (if (stringp (match-string 3))
7947 (string-to-number (match-string 3))
7948 (match-string 3)))
23f87bed
MB		 7949 (goto-char (match-end 0)))
7950
7951 (cond
7952 ((looking-at "\\(.*@.*\\)")
7953 (setq message-id (match-string 1)))
7954 ((looking-at "\\([^/]+\\)/\\([-0-9]+\\)")
7955 (setq group (match-string 1)
7956 articles (split-string (match-string 2) "-")))
7957 ((looking-at "\\([^/]+\\)/?")
7958 (setq group (match-string 1)))
7959 (t
7960 (error "Unknown news URL syntax"))))
82a8ad04 7961 (list scheme server port group message-id articles)))
23f87bed
MB		 7962
7963(defun gnus-button-handle-news (url)
7964 "Fetch a news URL."
82a8ad04 7965 (destructuring-bind (scheme server port group message-id articles)
23f87bed
MB		 7966 (gnus-parse-news-url url)
7967 (cond
7968 (message-id
80de1778 7969 (with-current-buffer gnus-summary-buffer
23f87bed 7970 (if server
ff4d3926
MB		 7971 (let ((gnus-refer-article-method
7972 (nconc (list (list 'nntp server))
7973 gnus-refer-article-method))
82a8ad04 7974 (nntp-port-number (or port "nntp")))
ff4d3926
MB		 7975 (gnus-message 7 "Fetching %s with %s"
7976 message-id gnus-refer-article-method)
23f87bed
MB		 7977 (gnus-summary-refer-article message-id))
7978 (gnus-summary-refer-article message-id))))
7979 (group
7980 (gnus-button-fetch-group url)))))
7981
01c52d31
MB		 7982(defun gnus-button-patch (library line)
7983 "Visit an Emacs Lisp library LIBRARY on line LINE."
7984 (interactive)
7985 (let ((file (locate-library (file-name-nondirectory library))))
7986 (unless file
7987 (error "Couldn't find library %s" library))
7988 (find-file file)
5dcc825f
GM		 7989 (goto-char (point-min))
7990 (forward-line (1- (string-to-number line)))))
01c52d31 7991
23f87bed
MB		 7992(defun gnus-button-handle-man (url)
7993 "Fetch a man page."
531e5812
MB		 7994 (gnus-message 9 "`%s' `%s'" gnus-button-man-handler url)
7995 (when (eq gnus-button-man-handler 'woman)
7996 (setq url (gnus-replace-in-string url "([1-9][X1a-z]*).*\\'" "")))
7997 (gnus-message 9 "`%s' `%s'" gnus-button-man-handler url)
23f87bed
MB		 7998 (funcall gnus-button-man-handler url))
7999
8000(defun gnus-button-handle-info-url (url)
8001 "Fetch an info URL."
8002 (setq url (mm-subst-char-in-string ?+ ?\ url))
8003 (cond
8004 ((string-match "^\\([^:/]+\\)?/\\(.*\\)" url)
8005 (gnus-info-find-node
8006 (concat "(" (or (gnus-url-unhex-string (match-string 1 url))
8007 "Gnus")
8008 ")" (gnus-url-unhex-string (match-string 2 url)))))
8009 ((string-match "([^)\"]+)[^\"]+" url)
8010 (setq url
8011 (gnus-replace-in-string
8012 (gnus-replace-in-string url "[\n\t ]+" " ") "\"" ""))
8013 (gnus-info-find-node url))
8014 (t (error "Can't parse %s" url))))
8015
8016(defun gnus-button-handle-info-url-gnome (url)
8017 "Fetch GNOME style info URL."
8018 (setq url (mm-subst-char-in-string ?_ ?\ url))
8019 (if (string-match "\\([^#]+\\)#?\\(.*\\)" url)
8020 (gnus-info-find-node
8021 (concat "("
bf247b6e 8022 (gnus-url-unhex-string
23f87bed
MB		 8023 (match-string 1 url))
8024 ")"
bf247b6e 8025 (or (gnus-url-unhex-string
23f87bed
MB		 8026 (match-string 2 url))
8027 "Top")))
8028 (error "Can't parse %s" url)))
8029
8030(defun gnus-button-handle-info-url-kde (url)
8031 "Fetch KDE style info URL."
8032 (gnus-info-find-node (gnus-url-unhex-string url)))
8033
9640c3bc
GM		 8034;; (info) will autoload info.el
8035(declare-function Info-menu "info" (menu-item &optional fork))
9b3ebcb6 8036(declare-function Info-index-next "info" (num))
9640c3bc 8037
23f87bed
MB		 8038(defun gnus-button-handle-info-keystrokes (url)
8039 "Call `info' when pushing the corresponding URL button."
9b3ebcb6
MB		 8040 ;; For links like `C-h i d m gnus RET part RET , ,', `C-h i d m CC Mode RET'.
8041 (let (node indx comma)
8042 (if (string-match
8043 (concat "\\b\\(C-h\\|<?[Ff]1>?\\)[ \t\n]+i[ \t\n]+d?[ \t\n]?m[ \t\n]+"
8044 "\\([^ ]+ ?[^ ]+\\)[ \t\n]+RET"
e425f18b 8045 "\\([ \t\n]+i[ \t\n]+[^ ]+ ?[^ ]+[ \t\n]+RET\\>"
9b3ebcb6
MB		 8046 "\\(?:[ \t\n,]*\\)\\)?")
8047 url)
8048 (setq node (match-string 2 url)
8049 indx (match-string 3 url))
8050 (error "Can't parse %s" url))
8051 (info)
8052 (Info-directory)
8053 (Info-menu node)
8054 (when (> (length indx) 0)
e425f18b 8055 (string-match (concat "[ \t\n]+i[ \t\n]+\\([^ ]+ ?[^ ]+\\)[ \t\n]+RET\\>"
9b3ebcb6
MB		 8056 "\\([ \t\n,]*\\)")
8057 indx)
8058 (setq comma (match-string 2 indx))
8059 (setq indx (match-string 1 indx))
8060 (Info-index indx)
8061 (when comma
8062 (dotimes (i (with-temp-buffer
8063 (insert comma)
8064 ;; Note: the XEmacs version of `how-many' takes
8065 ;; no optional argument.
8066 (goto-char (point-min))
8067 (how-many ",")))
8068 (Info-index-next 1)))
8069 nil)))
1888e568 8070
9d9cfd53 8071(autoload 'pgg-snarf-keys-region "pgg")
1888e568
GM		 8072;; Called after pgg-snarf-keys-region, which autoloads pgg.el.
8073(declare-function pgg-display-output-buffer "pgg" (start end status))
23f87bed 8074
01c52d31
MB		 8075(defun gnus-button-openpgp (url)
8076 "Retrieve and add an OpenPGP key given URL from an OpenPGP header."
8077 (with-temp-buffer
8078 (mm-url-insert-file-contents-external url)
8079 (pgg-snarf-keys-region (point-min) (point-max))
8080 (pgg-display-output-buffer nil nil nil)))
8081
eec82323
LMI		 8082(defun gnus-button-message-id (message-id)
8083 "Fetch MESSAGE-ID."
01c52d31 8084 (with-current-buffer gnus-summary-buffer
eec82323
LMI		 8085 (gnus-summary-refer-article message-id)))
8086
01c52d31 8087(defun gnus-button-fetch-group (address &rest ignore)
eec82323 8088 "Fetch GROUP specified by ADDRESS."
01c52d31
MB		 8089 (when (string-match "\\`\\(nntp\\|news\\):\\(//\\)?\\(.*\\)\\'"
8090 address)
8091 ;; Allow to use `gnus-button-fetch-group' in `browse-url-browser-function'
8092 ;; for nntp:// and news://
8093 (setq address (match-string 3 address)))
eec82323
LMI		 8094 (if (not (string-match "[:/]" address))
8095 ;; This is just a simple group url.
8096 (gnus-group-read-ephemeral-group address gnus-select-method)
23f87bed
MB		 8097 (if (not
8098 (string-match
8099 "^\\([^:/]+\\)\\(:\\([^/]+\\)\\)?/\\([^/]+\\)\\(/\\([0-9]+\\)\\)?"
8100 address))
eec82323
LMI		 8101 (error "Can't parse %s" address)
8102 (gnus-group-read-ephemeral-group
8103 (match-string 4 address)
8104 `(nntp ,(match-string 1 address)
8105 (nntp-address ,(match-string 1 address))
8106 (nntp-port-number ,(if (match-end 3)
8107 (match-string 3 address)
23f87bed
MB		 8108 "nntp")))
8109 nil nil nil
e9bd5782 8110 (and (match-end 6) (list (string-to-number (match-string 6 address))))))))
eec82323 8111
eec82323
LMI		 8112(defun gnus-url-parse-query-string (query &optional downcase)
8113 (let (retval pairs cur key val)
16409b0b 8114 (setq pairs (split-string query "&"))
eec82323
LMI		 8115 (while pairs
8116 (setq cur (car pairs)
23f87bed 8117 pairs (cdr pairs))
eec82323 8118 (if (not (string-match "=" cur))
23f87bed
MB		 8119 nil ; Grace
8120 (setq key (gnus-url-unhex-string (substring cur 0 (match-beginning 0)))
8121 val (gnus-url-unhex-string (substring cur (match-end 0) nil) t))
8122 (if downcase
8123 (setq key (downcase key)))
8124 (setq cur (assoc key retval))
8125 (if cur
8126 (setcdr cur (cons val (cdr cur)))
8127 (setq retval (cons (list key val) retval)))))
eec82323
LMI		 8128 retval))
8129
eec82323
LMI		 8130(defun gnus-url-mailto (url)
8131 ;; Send mail to someone
1e91d0eb 8132 (setq url (replace-regexp-in-string "\n" " " url))
eec82323
LMI		 8133 (when (string-match "mailto:/*\\(.*\\)" url)
8134 (setq url (substring url (match-beginning 1) nil)))
6748645f 8135 (let (to args subject func)
23f87bed
MB		 8136 (setq args (gnus-url-parse-query-string
8137 (if (string-match "^\\?" url)
8138 (substring url 1)
8139 (if (string-match "^\\([^?]+\\)\\?\\(.*\\)" url)
8140 (concat "to=" (match-string 1 url) "&"
8141 (match-string 2 url))
440b1345 8142 (concat "to=" url))))
23f87bed
MB		 8143 subject (cdr-safe (assoc "subject" args)))
8144 (gnus-msg-mail)
eec82323
LMI		 8145 (while args
8146 (setq func (intern-soft (concat "message-goto-" (downcase (caar args)))))
8147 (if (fboundp func)
23f87bed
MB		 8148 (funcall func)
8149 (message-position-on-field (caar args)))
8150 (insert (gnus-replace-in-string
8151 (mapconcat 'identity (reverse (cdar args)) ", ")
8152 "\r\n" "\n" t))
eec82323
LMI		 8153 (setq args (cdr args)))
8154 (if subject
23f87bed 8155 (message-goto-body)
eec82323
LMI		 8156 (message-goto-subject))))
8157
eec82323 8158(defun gnus-button-embedded-url (address)
e0bad764 8159 "Activate ADDRESS with `browse-url'."
1b978bfc 8160 (browse-url (gnus-strip-whitespace address)))
eec82323
LMI		 8161
8162;;; Next/prev buttons in the article buffer.
8163
8164(defvar gnus-next-page-line-format "%{%(Next page...%)%}\n")
8165(defvar gnus-prev-page-line-format "%{%(Previous page...%)%}\n")
8166
23f87bed
MB		 8167(defvar gnus-prev-page-map
8168 (let ((map (make-sparse-keymap)))
23f87bed
MB		 8169 (define-key map gnus-mouse-2 'gnus-button-prev-page)
8170 (define-key map "\r" 'gnus-button-prev-page)
8171 map))
8172
8173(defvar gnus-next-page-map
8174 (let ((map (make-sparse-keymap)))
23f87bed
MB		 8175 (define-key map gnus-mouse-2 'gnus-button-next-page)
8176 (define-key map "\r" 'gnus-button-next-page)
8177 map))
eec82323
LMI		 8178
8179(defun gnus-insert-prev-page-button ()
01c52d31 8180 (let ((b (point)) e
23f87bed 8181 (inhibit-read-only t))
eec82323
LMI		 8182 (gnus-eval-format
8183 gnus-prev-page-line-format nil
01c52d31
MB		 8184 `(keymap ,gnus-prev-page-map
8185 gnus-prev t
8186 gnus-callback gnus-article-button-prev-page
8187 article-type annotation))
8188 (setq e (if (bolp)
8189 ;; Exclude a newline.
8190 (1- (point))
8191 (point)))
8192 (when gnus-article-button-face
8193 (gnus-overlay-put (gnus-make-overlay b e nil t)
8194 'face gnus-article-button-face))
23f87bed 8195 (widget-convert-button
01c52d31 8196 'link b e
23f87bed
MB		 8197 :action 'gnus-button-prev-page
8198 :button-keymap gnus-prev-page-map)))
8199
8200(defun gnus-button-next-page (&optional args more-args)
eec82323
LMI		 8201 "Go to the next page."
8202 (interactive)
8203 (let ((win (selected-window)))
23f87bed 8204 (select-window (gnus-get-buffer-window gnus-article-buffer t))
eec82323
LMI		 8205 (gnus-article-next-page)
8206 (select-window win)))
8207
23f87bed 8208(defun gnus-button-prev-page (&optional args more-args)
eec82323
LMI		 8209 "Go to the prev page."
8210 (interactive)
8211 (let ((win (selected-window)))
23f87bed 8212 (select-window (gnus-get-buffer-window gnus-article-buffer t))
eec82323
LMI		 8213 (gnus-article-prev-page)
8214 (select-window win)))
8215
8216(defun gnus-insert-next-page-button ()
01c52d31 8217 (let ((b (point)) e
23f87bed 8218 (inhibit-read-only t))
eec82323 8219 (gnus-eval-format gnus-next-page-line-format nil
01c52d31
MB		 8220 `(keymap ,gnus-next-page-map
8221 gnus-next t
8222 gnus-callback gnus-article-button-next-page
8223 article-type annotation))
8224 (setq e (if (bolp)
8225 ;; Exclude a newline.
8226 (1- (point))
8227 (point)))
8228 (when gnus-article-button-face
8229 (gnus-overlay-put (gnus-make-overlay b e nil t)
8230 'face gnus-article-button-face))
23f87bed 8231 (widget-convert-button
01c52d31 8232 'link b e
23f87bed
MB		 8233 :action 'gnus-button-next-page
8234 :button-keymap gnus-next-page-map)))
eec82323
LMI		 8235
8236(defun gnus-article-button-next-page (arg)
8237 "Go to the next page."
8238 (interactive "P")
8239 (let ((win (selected-window)))
23f87bed 8240 (select-window (gnus-get-buffer-window gnus-article-buffer t))
eec82323
LMI		 8241 (gnus-article-next-page)
8242 (select-window win)))
8243
8244(defun gnus-article-button-prev-page (arg)
8245 "Go to the prev page."
8246 (interactive "P")
8247 (let ((win (selected-window)))
23f87bed 8248 (select-window (gnus-get-buffer-window gnus-article-buffer t))
eec82323
LMI		 8249 (gnus-article-prev-page)
8250 (select-window win)))
8251
16409b0b
GM		 8252(defvar gnus-decode-header-methods
8253 '(mail-decode-encoded-word-region)
8254 "List of methods used to decode headers.
8255
8256This variable is a list of FUNCTION or (REGEXP . FUNCTION). If item
4e7d0221 8257is FUNCTION, FUNCTION will be applied to all newsgroups. If item is a
23f87bed 8258\(REGEXP . FUNCTION), FUNCTION will be only apply to the newsgroups
16409b0b
GM		 8259whose names match REGEXP.
8260
8261For example:
8f688cb0 8262\((\"chinese\" . gnus-decode-encoded-word-region-by-guess)
16409b0b
GM		 8263 mail-decode-encoded-word-region
8264 (\"chinese\" . rfc1843-decode-region))
8265")
8266
8267(defvar gnus-decode-header-methods-cache nil)
8268
8269(defun gnus-multi-decode-header (start end)
8270 "Apply the functions from `gnus-encoded-word-methods' that match."
8271 (unless (and gnus-decode-header-methods-cache
8272 (eq gnus-newsgroup-name
8273 (car gnus-decode-header-methods-cache)))
8274 (setq gnus-decode-header-methods-cache (list gnus-newsgroup-name))
01c52d31
MB		 8275 (dolist (x gnus-decode-header-methods)
8276 (if (symbolp x)
8277 (nconc gnus-decode-header-methods-cache (list x))
8278 (if (and gnus-newsgroup-name
8279 (string-match (car x) gnus-newsgroup-name))
8280 (nconc gnus-decode-header-methods-cache
8281 (list (cdr x)))))))
16409b0b
GM		 8282 (let ((xlist gnus-decode-header-methods-cache))
8283 (pop xlist)
8284 (save-restriction
8285 (narrow-to-region start end)
8286 (while xlist
8287 (funcall (pop xlist) (point-min) (point-max))))))
8288
8289;;;
8290;;; Treatment top-level handling.
8291;;;
8292
389b76fa
G		 8293(defvar gnus-inhibit-article-treatments nil)
8294
c497474b
GM		 8295(defun gnus-treat-article (gnus-treat-condition
8296 &optional part-number total-parts gnus-treat-type)
8297 (let ((gnus-treat-length (- (point-max) (point-min)))
16409b0b
GM		 8298 (alist gnus-treatment-function-alist)
8299 (article-goto-body-goes-to-point-min-p t)
8300 (treated-type
c497474b 8301 (or (not gnus-treat-type)
16409b0b
GM		 8302 (catch 'found
8303 (let ((list gnus-article-treat-types))
8304 (while list
c497474b 8305 (when (string-match (pop list) gnus-treat-type)
16409b0b
GM		 8306 (throw 'found t)))))))
8307 (highlightp (gnus-visual-p 'article-highlight 'highlight))
8308 val elem)
8309 (gnus-run-hooks 'gnus-part-display-hook)
23f87bed 8310 (dolist (elem alist)
16409b0b
GM		 8311 (setq val
8312 (save-excursion
23f87bed
MB		 8313 (when (gnus-buffer-live-p gnus-summary-buffer)
8314 (set-buffer gnus-summary-buffer))
16409b0b
GM		 8315 (symbol-value (car elem))))
8316 (when (and (or (consp val)
8317 treated-type)
389b76fa 8318 (or (not gnus-inhibit-article-treatments)
c497474b 8319 (eq gnus-treat-condition 'head))
16409b0b
GM		 8320 (gnus-treat-predicate val)
8321 (or (not (get (car elem) 'highlight))
8322 highlightp))
8323 (save-restriction
8324 (funcall (cadr elem)))))))
8325
8326;; Dynamic variables.
9efa445f
DN		 8327(defvar part-number)
8328(defvar total-parts)
c497474b
GM		 8329(defvar gnus-treat-type)
8330(defvar gnus-treat-condition)
8331(defvar gnus-treat-length)
e0bad764 8332
16409b0b
GM		 8333(defun gnus-treat-predicate (val)
8334 (cond
8335 ((null val)
8336 nil)
c497474b
GM		 8337 (gnus-treat-condition
8338 (eq gnus-treat-condition val))
16409b0b
GM		 8339 ((and (listp val)
8340 (stringp (car val)))
8341 (apply 'gnus-or (mapcar `(lambda (s)
8342 (string-match s ,(or gnus-newsgroup-name "")))
8343 val)))
8344 ((listp val)
8345 (let ((pred (pop val)))
8346 (cond
8347 ((eq pred 'or)
8348 (apply 'gnus-or (mapcar 'gnus-treat-predicate val)))
8349 ((eq pred 'and)
8350 (apply 'gnus-and (mapcar 'gnus-treat-predicate val)))
8351 ((eq pred 'not)
8352 (not (gnus-treat-predicate (car val))))
8353 ((eq pred 'typep)
c497474b 8354 (equal (car val) gnus-treat-type))
16409b0b
GM		 8355 (t
8356 (error "%S is not a valid predicate" pred)))))
16409b0b
GM		 8357 ((eq val t)
8358 t)
8359 ((eq val 'head)
8360 nil)
01c52d31
MB		 8361 ((eq val 'first)
8362 (eq part-number 1))
16409b0b
GM		 8363 ((eq val 'last)
8364 (eq part-number total-parts))
8365 ((numberp val)
c497474b 8366 (< gnus-treat-length val))
16409b0b
GM		 8367 (t
8368 (error "%S is not a valid value" val))))
8369
23f87bed
MB		 8370(defun gnus-article-encrypt-body (protocol &optional n)
8371 "Encrypt the article body."
8372 (interactive
8373 (list
8374 (or gnus-article-encrypt-protocol
229b59da
G		 8375 (gnus-completing-read "Encrypt protocol"
8376 (mapcar 'car gnus-article-encrypt-protocol-alist)
8377 t))
23f87bed 8378 current-prefix-arg))
bbbe940b
MB		 8379 ;; User might hit `K E' instead of `K e', so prompt once.
8380 (when (and gnus-article-encrypt-protocol
8381 gnus-novice-user)
8382 (unless (gnus-y-or-n-p "Really encrypt article(s)? ")
d93ec753 8383 (error "Encrypt aborted")))
23f87bed
MB		 8384 (let ((func (cdr (assoc protocol gnus-article-encrypt-protocol-alist))))
8385 (unless func
998a5a95 8386 (error "Can't find the encrypt protocol %s" protocol))
23f87bed
MB		 8387 (if (member gnus-newsgroup-name '("nndraft:delayed"
8388 "nndraft:drafts"
8389 "nndraft:queue"))
8390 (error "Can't encrypt the article in group %s"
8391 gnus-newsgroup-name))
8392 (gnus-summary-iterate n
80de1778 8393 (with-current-buffer gnus-summary-buffer
23f87bed
MB		 8394 (let ((mail-parse-charset gnus-newsgroup-charset)
8395 (mail-parse-ignored-charsets gnus-newsgroup-ignored-charsets)
8396 (summary-buffer gnus-summary-buffer)
8397 references point)
8398 (gnus-set-global-variables)
8399 (when (gnus-group-read-only-p)
8400 (error "The current newsgroup does not support article encrypt"))
8401 (gnus-summary-show-article t)
8402 (setq references
8403 (or (mail-header-references gnus-current-headers) ""))
8404 (set-buffer gnus-article-buffer)
8405 (let* ((inhibit-read-only t)
8406 (headers
8407 (mapcar (lambda (field)
8408 (and (save-restriction
8409 (message-narrow-to-head)
8410 (goto-char (point-min))
8411 (search-forward field nil t))
8412 (prog2
8413 (message-narrow-to-field)
8414 (buffer-string)
8415 (delete-region (point-min) (point-max))
8416 (widen))))
8417 '("Content-Type:" "Content-Transfer-Encoding:"
8418 "Content-Disposition:"))))
8419 (message-narrow-to-head)
8420 (message-remove-header "MIME-Version")
8421 (goto-char (point-max))
8422 (setq point (point))
8423 (insert (apply 'concat headers))
8424 (widen)
8425 (narrow-to-region point (point-max))
8426 (let ((message-options message-options))
8427 (message-options-set 'message-sender user-mail-address)
8428 (message-options-set 'message-recipients user-mail-address)
8429 (message-options-set 'message-sign-encrypt 'not)
8430 (funcall func))
8431 (goto-char (point-min))
8432 (insert "MIME-Version: 1.0\n")
8433 (widen)
8434 (gnus-summary-edit-article-done
8435 references nil summary-buffer t))
8436 (when gnus-keep-backlog
8437 (gnus-backlog-remove-article
8438 (car gnus-article-current) (cdr gnus-article-current)))
8ccbef23 8439 (gnus-flush-original-article-buffer)
23f87bed
MB		 8440 (when gnus-use-cache
8441 (gnus-cache-update-article
8442 (car gnus-article-current) (cdr gnus-article-current))))))))
8443
8444(defvar gnus-mime-security-button-line-format "%{%([[%t:%i]%D]%)%}\n"
8445 "The following specs can be used:
8446%t The security MIME type
8447%i Additional info
8448%d Details
8449%D Details if button is pressed")
8450
8451(defvar gnus-mime-security-button-end-line-format "%{%([[End of %t]%D]%)%}\n"
8452 "The following specs can be used:
8453%t The security MIME type
8454%i Additional info
8455%d Details
8456%D Details if button is pressed")
8457
8458(defvar gnus-mime-security-button-line-format-alist
8459 '((?t gnus-tmp-type ?s)
8460 (?i gnus-tmp-info ?s)
8461 (?d gnus-tmp-details ?s)
8462 (?D gnus-tmp-pressed-details ?s)))
8463
01c52d31
MB		 8464(defvar gnus-mime-security-button-commands
8465 '((gnus-article-press-button "\r" "Show Detail")
8466 (undefined "v")
8467 (undefined "t")
8468 (undefined "C")
8469 (gnus-mime-security-save-part "o" "Save...")
8470 (undefined "\C-o")
8471 (undefined "r")
8472 (undefined "d")
8473 (undefined "c")
8474 (undefined "i")
8475 (undefined "E")
8476 (undefined "e")
8477 (undefined "p")
8478 (gnus-mime-security-pipe-part "|" "Pipe To Command...")
8479 (undefined ".")))
8480
23f87bed
MB		 8481(defvar gnus-mime-security-button-map
8482 (let ((map (make-sparse-keymap)))
23f87bed 8483 (define-key map gnus-mouse-2 'gnus-article-push-button)
01c52d31
MB		 8484 (define-key map gnus-down-mouse-3 'gnus-mime-security-button-menu)
8485 (dolist (c gnus-mime-security-button-commands)
8486 (define-key map (cadr c) (car c)))
23f87bed
MB		 8487 map))
8488
01c52d31
MB		 8489(easy-menu-define
8490 gnus-mime-security-button-menu gnus-mime-security-button-map
8491 "Security button menu."
8492 `("Security Part"
8493 ,@(delq nil
8494 (mapcar (lambda (c)
8495 (unless (eq (car c) 'undefined)
8496 (vector (caddr c) (car c) :active t)))
8497 gnus-mime-security-button-commands))))
8498
8499(defun gnus-mime-security-button-menu (event prefix)
8500 "Construct a context-sensitive menu of security commands."
8501 (interactive "e\nP")
8502 (save-window-excursion
8503 (let ((pos (event-start event)))
8504 (select-window (posn-window pos))
8505 (goto-char (posn-point pos))
8506 (gnus-article-check-buffer)
8507 (popup-menu gnus-mime-security-button-menu nil prefix))))
8508
23f87bed
MB		 8509(defvar gnus-mime-security-details-buffer nil)
8510
8511(defvar gnus-mime-security-button-pressed nil)
8512
8513(defvar gnus-mime-security-show-details-inline t
8514 "If non-nil, show details in the article buffer.")
8515
8516(defun gnus-mime-security-verify-or-decrypt (handle)
8517 (mm-remove-parts (cdr handle))
8518 (let ((region (mm-handle-multipart-ctl-parameter handle 'gnus-region))
8519 point (inhibit-read-only t))
8520 (if region
8521 (goto-char (car region)))
01c52d31
MB		 8522 (setq point (point))
8523 (with-current-buffer (mm-handle-multipart-original-buffer handle)
8524 (let* ((mm-verify-option 'known)
8525 (mm-decrypt-option 'known)
8526 (nparts (mm-possibly-verify-or-decrypt (cdr handle) handle)))
8527 (unless (eq nparts (cdr handle))
8528 (mm-destroy-parts (cdr handle))
8529 (setcdr handle nparts))))
8530 (gnus-mime-display-security handle)
23f87bed
MB		 8531 (when region
8532 (delete-region (point) (cdr region))
8533 (set-marker (car region) nil)
8534 (set-marker (cdr region) nil))
8535 (goto-char point)))
8536
8537(defun gnus-mime-security-show-details (handle)
8538 (let ((details (mm-handle-multipart-ctl-parameter handle 'gnus-details)))
8539 (if (not details)
8540 (gnus-message 5 "No details.")
8541 (if gnus-mime-security-show-details-inline
8542 (let ((gnus-mime-security-button-pressed
8543 (not (get-text-property (point) 'gnus-mime-details)))
8544 (gnus-mime-security-button-line-format
8545 (get-text-property (point) 'gnus-line-format))
8546 (inhibit-read-only t))
8547 (forward-char -1)
8548 (while (eq (get-text-property (point) 'gnus-line-format)
8549 gnus-mime-security-button-line-format)
8550 (forward-char -1))
8551 (forward-char)
8552 (save-restriction
8553 (narrow-to-region (point) (point))
8554 (gnus-insert-mime-security-button handle))
8555 (delete-region (point)
8556 (or (text-property-not-all
8557 (point) (point-max)
8558 'gnus-line-format
8559 gnus-mime-security-button-line-format)
8560 (point-max))))
8561 ;; Not inlined.
8562 (if (gnus-buffer-live-p gnus-mime-security-details-buffer)
8563 (with-current-buffer gnus-mime-security-details-buffer
8564 (erase-buffer)
8565 t)
8566 (setq gnus-mime-security-details-buffer
8567 (gnus-get-buffer-create "*MIME Security Details*")))
8568 (with-current-buffer gnus-mime-security-details-buffer
8569 (insert details)
8570 (goto-char (point-min)))
8571 (pop-to-buffer gnus-mime-security-details-buffer)))))
8572
8573(defun gnus-mime-security-press-button (handle)
8574 (save-excursion
8575 (if (mm-handle-multipart-ctl-parameter handle 'gnus-info)
8576 (gnus-mime-security-show-details handle)
8577 (gnus-mime-security-verify-or-decrypt handle))))
8578
8579(defun gnus-insert-mime-security-button (handle &optional displayed)
8580 (let* ((protocol (mm-handle-multipart-ctl-parameter handle 'protocol))
8581 (gnus-tmp-type
8582 (concat
8583 (or (nth 2 (assoc protocol mm-verify-function-alist))
8584 (nth 2 (assoc protocol mm-decrypt-function-alist))
8585 "Unknown")
8586 (if (equal (car handle) "multipart/signed")
8587 " Signed" " Encrypted")
8588 " Part"))
8589 (gnus-tmp-info
8590 (or (mm-handle-multipart-ctl-parameter handle 'gnus-info)
8591 "Undecided"))
8592 (gnus-tmp-details
8593 (mm-handle-multipart-ctl-parameter handle 'gnus-details))
8594 gnus-tmp-pressed-details
8595 b e)
8596 (setq gnus-tmp-details
8597 (if gnus-tmp-details
8598 (concat "\n" gnus-tmp-details)
8599 ""))
8600 (setq gnus-tmp-pressed-details
8601 (if gnus-mime-security-button-pressed gnus-tmp-details ""))
8602 (unless (bolp)
8603 (insert "\n"))
8604 (setq b (point))
8605 (gnus-eval-format
8606 gnus-mime-security-button-line-format
8607 gnus-mime-security-button-line-format-alist
01c52d31 8608 `(keymap ,gnus-mime-security-button-map
23f87bed
MB		 8609 gnus-callback gnus-mime-security-press-button
8610 gnus-line-format ,gnus-mime-security-button-line-format
8611 gnus-mime-details ,gnus-mime-security-button-pressed
8612 article-type annotation
8613 gnus-data ,handle))
8614 (setq e (if (bolp)
8615 ;; Exclude a newline.
8616 (1- (point))
8617 (point)))
01c52d31
MB		 8618 (when gnus-article-button-face
8619 (gnus-overlay-put (gnus-make-overlay b e nil t)
8620 'face gnus-article-button-face))
23f87bed
MB		 8621 (widget-convert-button
8622 'link b e
8623 :mime-handle handle
8624 :action 'gnus-widget-press-button
8625 :button-keymap gnus-mime-security-button-map
8626 :help-echo
5843126b 8627 (lambda (widget)
23f87bed
MB		 8628 ;; Needed to properly clear the message due to a bug in
8629 ;; wid-edit (XEmacs only).
8630 (when (boundp 'help-echo-owns-message)
8631 (setq help-echo-owns-message t))
8632 (format
01c52d31
MB		 8633 "%S: show detail; %S: more options"
8634 (aref gnus-mouse-2 0)
8635 (aref gnus-down-mouse-3 0))))))
23f87bed
MB		 8636
8637(defun gnus-mime-display-security (handle)
8638 (save-restriction
8639 (narrow-to-region (point) (point))
8640 (unless (gnus-unbuttonized-mime-type-p (car handle))
8641 (gnus-insert-mime-security-button handle))
01c52d31 8642 (gnus-mime-display-part (cadr handle))
23f87bed
MB		 8643 (unless (bolp)
8644 (insert "\n"))
8645 (unless (gnus-unbuttonized-mime-type-p (car handle))
8646 (let ((gnus-mime-security-button-line-format
8647 gnus-mime-security-button-end-line-format))
8648 (gnus-insert-mime-security-button handle)))
8649 (mm-set-handle-multipart-parameter
8650 handle 'gnus-region
8651 (cons (set-marker (make-marker) (point-min))
01c52d31
MB		 8652 (set-marker (make-marker) (point-max))))
8653 (goto-char (point-max))))
8654
8655(defun gnus-mime-security-run-function (function)
8656 "Run FUNCTION with the security part under point."
8657 (gnus-article-check-buffer)
8658 (let ((data (get-text-property (point) 'gnus-data))
8659 buffer handle)
8660 (when (and (stringp (car-safe data))
8661 (setq buffer (mm-handle-multipart-original-buffer data))
8662 (setq handle (cadr data)))
8663 (if (bufferp (mm-handle-buffer handle))
8664 (progn
8665 (setq handle (cons buffer (copy-sequence (cdr handle))))
8666 (mm-handle-set-undisplayer handle nil))
8667 (setq handle (mm-make-handle
8668 buffer
8669 (mm-handle-multipart-ctl-parameter handle 'protocol)
8670 nil nil nil nil nil nil)))
8671 (funcall function handle))))
8672
8673(defun gnus-mime-security-save-part ()
8674 "Save the security part under point."
8675 (interactive)
8676 (gnus-mime-security-run-function 'mm-save-part))
8677
8678(defun gnus-mime-security-pipe-part ()
8679 "Pipe the security part under point to a process."
8680 (interactive)
8681 (gnus-mime-security-run-function 'mm-pipe-part))
23f87bed 8682
eec82323
LMI		 8683(gnus-ems-redefine)
8684
8685(provide 'gnus-art)
8686
8687(run-hooks 'gnus-art-load-hook)
8688
8689;;; gnus-art.el ends here
Unnamed repository; edit this file 'description' to name the repository.