Mercurial > emacs
comparison lisp/gnus/gnus-art.el @ 82951:0fde48feb604
Import Gnus 5.10 from the v5_10 branch of the Gnus repository.
author | Andreas Schwab <schwab@suse.de> |
---|---|
date | Thu, 22 Jul 2004 16:45:51 +0000 |
parents | 75c387f0b055 |
children | 28d9e552d178 |
comparison
equal
deleted
inserted
replaced
56503:8bbd2323fbf2 | 82951:0fde48feb604 |
---|---|
1 ;;; gnus-art.el --- article mode commands for Gnus | 1 ;;; gnus-art.el --- article mode commands for Gnus |
2 | 2 ;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003 |
3 ;; Copyright (C) 1996, 97, 98, 1999, 2000, 01, 02, 2004 | 3 ;; Free Software Foundation, Inc. |
4 ;; Free Software Foundation, Inc. | |
5 | 4 |
6 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> | 5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> |
7 ;; Keywords: news | 6 ;; Keywords: news |
8 | 7 |
9 ;; This file is part of GNU Emacs. | 8 ;; This file is part of GNU Emacs. |
25 | 24 |
26 ;;; Commentary: | 25 ;;; Commentary: |
27 | 26 |
28 ;;; Code: | 27 ;;; Code: |
29 | 28 |
30 (eval-when-compile (require 'cl)) | 29 (eval-when-compile |
30 (require 'cl) | |
31 (defvar tool-bar-map)) | |
31 | 32 |
32 (require 'gnus) | 33 (require 'gnus) |
33 (require 'gnus-sum) | 34 (require 'gnus-sum) |
34 (require 'gnus-spec) | 35 (require 'gnus-spec) |
35 (require 'gnus-int) | 36 (require 'gnus-int) |
37 (require 'gnus-win) | |
36 (require 'mm-bodies) | 38 (require 'mm-bodies) |
37 (require 'mail-parse) | 39 (require 'mail-parse) |
38 (require 'mm-decode) | 40 (require 'mm-decode) |
39 (require 'mm-view) | 41 (require 'mm-view) |
40 (require 'wid-edit) | 42 (require 'wid-edit) |
41 (require 'mm-uu) | 43 (require 'mm-uu) |
44 (require 'message) | |
45 | |
46 (autoload 'gnus-msg-mail "gnus-msg" nil t) | |
47 (autoload 'gnus-button-mailto "gnus-msg") | |
48 (autoload 'gnus-button-reply "gnus-msg" nil t) | |
42 | 49 |
43 (defgroup gnus-article nil | 50 (defgroup gnus-article nil |
44 "Article display." | 51 "Article display." |
45 :link '(custom-manual "(gnus)The Article Buffer") | 52 :link '(custom-manual "(gnus)The Article Buffer") |
46 :group 'gnus) | 53 :group 'gnus) |
100 "Other article options." | 107 "Other article options." |
101 :link '(custom-manual "(gnus)Misc Article") | 108 :link '(custom-manual "(gnus)Misc Article") |
102 :group 'gnus-article) | 109 :group 'gnus-article) |
103 | 110 |
104 (defcustom gnus-ignored-headers | 111 (defcustom gnus-ignored-headers |
105 '("^Path:" "^Expires:" "^Date-Received:" "^References:" "^Xref:" "^Lines:" | 112 (mapcar |
106 "^Relay-Version:" "^Message-ID:" "^Approved:" "^Sender:" "^Received:" | 113 (lambda (header) |
107 "^X-UIDL:" "^MIME-Version:" "^Return-Path:" "^In-Reply-To:" | 114 (concat "^" header ":")) |
108 "^Content-Type:" "^Content-Transfer-Encoding:" "^X-WebTV-Signature:" | 115 '("Path" "Expires" "Date-Received" "References" "Xref" "Lines" |
109 "^X-MimeOLE:" "^X-MSMail-Priority:" "^X-Priority:" "^X-Loop:" | 116 "Relay-Version" "Message-ID" "Approved" "Sender" "Received" |
110 "^X-Authentication-Warning:" "^X-MIME-Autoconverted:" "^X-Face:" | 117 "X-UIDL" "MIME-Version" "Return-Path" "In-Reply-To" |
111 "^X-Attribution:" "^X-Originating-IP:" "^Delivered-To:" | 118 "Content-Type" "Content-Transfer-Encoding" "X-WebTV-Signature" |
112 "^NNTP-[-A-Za-z]+:" "^Distribution:" "^X-no-archive:" "^X-Trace:" | 119 "X-MimeOLE" "X-MSMail-Priority" "X-Priority" "X-Loop" |
113 "^X-Complaints-To:" "^X-NNTP-Posting-Host:" "^X-Orig.*:" | 120 "X-Authentication-Warning" "X-MIME-Autoconverted" "X-Face" |
114 "^Abuse-Reports-To:" "^Cache-Post-Path:" "^X-Article-Creation-Date:" | 121 "X-Attribution" "X-Originating-IP" "Delivered-To" |
115 "^X-Poster:" "^X-Mail2News-Path:" "^X-Server-Date:" "^X-Cache:" | 122 "NNTP-[-A-Za-z]+" "Distribution" "X-no-archive" "X-Trace" |
116 "^Originator:" "^X-Problems-To:" "^X-Auth-User:" "^X-Post-Time:" | 123 "X-Complaints-To" "X-NNTP-Posting-Host" "X-Orig.*" |
117 "^X-Admin:" "^X-UID:" "^Resent-[-A-Za-z]+:" "^X-Mailing-List:" | 124 "Abuse-Reports-To" "Cache-Post-Path" "X-Article-Creation-Date" |
118 "^Precedence:" "^Original-[-A-Za-z]+:" "^X-filename:" "^X-Orcpt:" | 125 "X-Poster" "X-Mail2News-Path" "X-Server-Date" "X-Cache" |
119 "^Old-Received:" "^X-Pgp" "^X-Auth:" "^X-From-Line:" | 126 "Originator" "X-Problems-To" "X-Auth-User" "X-Post-Time" |
120 "^X-Gnus-Article-Number:" "^X-Majordomo:" "^X-Url:" "^X-Sender:" | 127 "X-Admin" "X-UID" "Resent-[-A-Za-z]+" "X-Mailing-List" |
121 "^MBOX-Line" "^Priority:" "^X-Pgp" "^X400-[-A-Za-z]+:" | 128 "Precedence" "Original-[-A-Za-z]+" "X-filename" "X-Orcpt" |
122 "^Status:" "^X-Gnus-Mail-Source:" "^Cancel-Lock:" | 129 "Old-Received" "X-Pgp" "X-Auth" "X-From-Line" |
123 "^X-FTN" "^X-EXP32-SerialNo:" "^Encoding:" "^Importance:" | 130 "X-Gnus-Article-Number" "X-Majordomo" "X-Url" "X-Sender" |
124 "^Autoforwarded:" "^Original-Encoded-Information-Types:" "^X-Ya-Pop3:" | 131 "MBOX-Line" "Priority" "X400-[-A-Za-z]+" |
125 "^X-Face-Version:" "^X-Vms-To:" "^X-ML-NAME:" "^X-ML-COUNT:" | 132 "Status" "X-Gnus-Mail-Source" "Cancel-Lock" |
126 "^Mailing-List:" "^X-finfo:" "^X-md5sum:" "^X-md5sum-Origin:" | 133 "X-FTN" "X-EXP32-SerialNo" "Encoding" "Importance" |
127 "^X-Sun-Charset:" "^X-Accept-Language:" "^X-Envelope-Sender:" | 134 "Autoforwarded" "Original-Encoded-Information-Types" "X-Ya-Pop3" |
128 "^List-[A-Za-z]+:" "^X-Listprocessor-Version:" | 135 "X-Face-Version" "X-Vms-To" "X-ML-NAME" "X-ML-COUNT" |
129 "^X-Received:" "^X-Distribute:" "^X-Sequence:" "^X-Juno-Line-Breaks:" | 136 "Mailing-List" "X-finfo" "X-md5sum" "X-md5sum-Origin" |
130 "^X-Notes-Item:" "^X-MS-TNEF-Correlator:" "^x-uunet-gateway:" | 137 "X-Sun-Charset" "X-Accept-Language" "X-Envelope-Sender" |
131 "^X-Received:" "^Content-length:" "X-precedence:") | 138 "List-[A-Za-z]+" "X-Listprocessor-Version" |
139 "X-Received" "X-Distribute" "X-Sequence" "X-Juno-Line-Breaks" | |
140 "X-Notes-Item" "X-MS-TNEF-Correlator" "x-uunet-gateway" | |
141 "X-Received" "Content-length" "X-precedence" | |
142 "X-Authenticated-User" "X-Comment" "X-Report" "X-Abuse-Info" | |
143 "X-HTTP-Proxy" "X-Mydeja-Info" "X-Copyright" "X-No-Markup" | |
144 "X-Abuse-Info" "X-From_" "X-Accept-Language" "Errors-To" | |
145 "X-BeenThere" "X-Mailman-Version" "List-Help" "List-Post" | |
146 "List-Subscribe" "List-Id" "List-Unsubscribe" "List-Archive" | |
147 "X-Content-length" "X-Posting-Agent" "Original-Received" | |
148 "X-Request-PGP" "X-Fingerprint" "X-WRIEnvto" "X-WRIEnvfrom" | |
149 "X-Virus-Scanned" "X-Delivery-Agent" "Posted-Date" "X-Gateway" | |
150 "X-Local-Origin" "X-Local-Destination" "X-UserInfo1" | |
151 "X-Received-Date" "X-Hashcash" "Face" "X-DMCA-Notifications" | |
152 "X-Abuse-and-DMCA-Info" "X-Postfilter" "X-Gpg-.*" "X-Disclaimer")) | |
132 "*All headers that start with this regexp will be hidden. | 153 "*All headers that start with this regexp will be hidden. |
133 This variable can also be a list of regexps of headers to be ignored. | 154 This variable can also be a list of regexps of headers to be ignored. |
134 If `gnus-visible-headers' is non-nil, this variable will be ignored." | 155 If `gnus-visible-headers' is non-nil, this variable will be ignored." |
135 :type '(choice :custom-show nil | 156 :type '(choice :custom-show nil |
136 regexp | 157 regexp |
137 (repeat regexp)) | 158 (repeat regexp)) |
138 :group 'gnus-article-hiding) | 159 :group 'gnus-article-hiding) |
139 | 160 |
140 (defcustom gnus-visible-headers | 161 (defcustom gnus-visible-headers |
141 "^From:\\|^Newsgroups:\\|^Subject:\\|^Date:\\|^Followup-To:\\|^Reply-To:\\|^Organization:\\|^Summary:\\|^Keywords:\\|^To:\\|^[BGF]?Cc:\\|^Posted-To:\\|^Mail-Copies-To:\\|^Apparently-To:\\|^Gnus-Warning:\\|^Resent-From:\\|^X-Sent:" | 162 "^From:\\|^Newsgroups:\\|^Subject:\\|^Date:\\|^Followup-To:\\|^Reply-To:\\|^Organization:\\|^Summary:\\|^Keywords:\\|^To:\\|^[BGF]?Cc:\\|^Posted-To:\\|^Mail-Copies-To:\\|^Mail-Followup-To:\\|^Apparently-To:\\|^Gnus-Warning:\\|^Resent-From:\\|^X-Sent:" |
142 "*All headers that do not match this regexp will be hidden. | 163 "*All headers that do not match this regexp will be hidden. |
143 This variable can also be a list of regexp of headers to remain visible. | 164 This variable can also be a list of regexp of headers to remain visible. |
144 If this variable is non-nil, `gnus-ignored-headers' will be ignored." | 165 If this variable is non-nil, `gnus-ignored-headers' will be ignored." |
145 :type '(repeat :value-to-internal (lambda (widget value) | 166 :type '(repeat :value-to-internal (lambda (widget value) |
146 (custom-split-regexp-maybe value)) | 167 (custom-split-regexp-maybe value)) |
160 :type '(repeat regexp) | 181 :type '(repeat regexp) |
161 :group 'gnus-article-hiding) | 182 :group 'gnus-article-hiding) |
162 | 183 |
163 (defcustom gnus-boring-article-headers '(empty followup-to reply-to) | 184 (defcustom gnus-boring-article-headers '(empty followup-to reply-to) |
164 "Headers that are only to be displayed if they have interesting data. | 185 "Headers that are only to be displayed if they have interesting data. |
165 Possible values in this list are `empty', `newsgroups', `followup-to', | 186 Possible values in this list are: |
166 `reply-to', `date', `long-to', and `many-to'." | 187 |
188 'empty Headers with no content. | |
189 'newsgroups Newsgroup identical to Gnus group. | |
190 'to-address To identical to To-address. | |
191 'to-list To identical to To-list. | |
192 'cc-list CC identical to To-list. | |
193 'followup-to Followup-to identical to Newsgroups. | |
194 'reply-to Reply-to identical to From. | |
195 'date Date less than four days old. | |
196 'long-to To and/or Cc longer than 1024 characters. | |
197 'many-to Multiple To and/or Cc." | |
167 :type '(set (const :tag "Headers with no content." empty) | 198 :type '(set (const :tag "Headers with no content." empty) |
168 (const :tag "Newsgroups with only one group." newsgroups) | 199 (const :tag "Newsgroups identical to Gnus group." newsgroups) |
169 (const :tag "Followup-to identical to newsgroups." followup-to) | 200 (const :tag "To identical to To-address." to-address) |
170 (const :tag "Reply-to identical to from." reply-to) | 201 (const :tag "To identical to To-list." to-list) |
202 (const :tag "CC identical to To-list." cc-list) | |
203 (const :tag "Followup-to identical to Newsgroups." followup-to) | |
204 (const :tag "Reply-to identical to From." reply-to) | |
171 (const :tag "Date less than four days old." date) | 205 (const :tag "Date less than four days old." date) |
172 (const :tag "Very long To and/or Cc header." long-to) | 206 (const :tag "To and/or Cc longer than 1024 characters." long-to) |
173 (const :tag "Multiple To and/or Cc headers." many-to)) | 207 (const :tag "Multiple To and/or Cc headers." many-to)) |
208 :group 'gnus-article-hiding) | |
209 | |
210 (defcustom gnus-article-skip-boring nil | |
211 "Skip over text that is not worth reading. | |
212 By default, if you set this t, then Gnus will display citations and | |
213 signatures, but will never scroll down to show you a page consisting | |
214 only of boring text. Boring text is controlled by | |
215 `gnus-article-boring-faces'." | |
216 :type 'boolean | |
174 :group 'gnus-article-hiding) | 217 :group 'gnus-article-hiding) |
175 | 218 |
176 (defcustom gnus-signature-separator '("^-- $" "^-- *$") | 219 (defcustom gnus-signature-separator '("^-- $" "^-- *$") |
177 "Regexp matching signature separator. | 220 "Regexp matching signature separator. |
178 This can also be a list of regexps. In that case, it will be checked | 221 This can also be a list of regexps. In that case, it will be checked |
198 (defcustom gnus-hidden-properties '(invisible t intangible t) | 241 (defcustom gnus-hidden-properties '(invisible t intangible t) |
199 "Property list to use for hiding text." | 242 "Property list to use for hiding text." |
200 :type 'sexp | 243 :type 'sexp |
201 :group 'gnus-article-hiding) | 244 :group 'gnus-article-hiding) |
202 | 245 |
203 ;; Fixme: This isn't the right thing for mixed graphical and and | 246 ;; Fixme: This isn't the right thing for mixed graphical and non-graphical |
204 ;; non-graphical frames in a session. | 247 ;; frames in a session. |
205 ;; gnus-xmas.el overrides this for XEmacs. | |
206 (defcustom gnus-article-x-face-command | 248 (defcustom gnus-article-x-face-command |
207 (if (and (fboundp 'image-type-available-p) | 249 (if (featurep 'xemacs) |
208 (image-type-available-p 'xbm)) | 250 (if (or (gnus-image-type-available-p 'xface) |
209 'gnus-article-display-xface | 251 (gnus-image-type-available-p 'pbm)) |
210 (if (or (and (boundp 'gnus-article-compface-xbm) | 252 'gnus-display-x-face-in-from |
211 gnus-article-compface-xbm) | 253 "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | ee -") |
212 (eq 0 (string-match "#define" | 254 (if (gnus-image-type-available-p 'pbm) |
213 (shell-command-to-string "uncompface -X")))) | 255 'gnus-display-x-face-in-from |
214 "{ echo '/* Width=48, Height=48 */'; uncompface; } | display -" | |
215 "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | \ | 256 "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | \ |
216 display -")) | 257 display -")) |
217 "*String or function to be executed to display an X-Face header. | 258 "*String or function to be executed to display an X-Face header. |
218 If it is a string, the command will be executed in a sub-shell | 259 If it is a string, the command will be executed in a sub-shell |
219 asynchronously. The compressed face will be piped to this command." | 260 asynchronously. The compressed face will be piped to this command." |
220 :type '(choice string | 261 :type `(choice string |
221 (function-item gnus-article-display-xface) | 262 (function-item gnus-display-x-face-in-from) |
222 function) | 263 function) |
223 :version "21.1" | 264 :version "21.1" |
265 :group 'gnus-picon | |
224 :group 'gnus-article-washing) | 266 :group 'gnus-article-washing) |
225 | 267 |
226 (defcustom gnus-article-x-face-too-ugly nil | 268 (defcustom gnus-article-x-face-too-ugly nil |
227 "Regexp matching posters whose face shouldn't be shown automatically." | 269 "Regexp matching posters whose face shouldn't be shown automatically." |
228 :type '(choice regexp (const nil)) | 270 :type '(choice regexp (const nil)) |
229 :group 'gnus-article-washing) | 271 :group 'gnus-article-washing) |
230 | 272 |
231 (defcustom gnus-article-banner-alist nil | 273 (defcustom gnus-article-banner-alist nil |
232 "Banner alist for stripping. | 274 "Banner alist for stripping. |
233 For example, | 275 For example, |
234 ((egroups . \"^[ \\t\\n]*-------------------+\\\\( eGroups Sponsor -+\\\\)?....\\n\\\\(.+\\n\\\\)+\"))" | 276 ((egroups . \"^[ \\t\\n]*-------------------+\\\\( \\\\(e\\\\|Yahoo! \\\\)Groups Sponsor -+\\\\)?....\\n\\\\(.+\\n\\\\)+\"))" |
235 :version "21.1" | 277 :version "21.1" |
236 :type '(repeat (cons symbol regexp)) | 278 :type '(repeat (cons symbol regexp)) |
237 :group 'gnus-article-washing) | 279 :group 'gnus-article-washing) |
238 | 280 |
281 (gnus-define-group-parameter | |
282 banner | |
283 :variable-document | |
284 "Alist of regexps (to match group names) and banner." | |
285 :variable-group gnus-article-washing | |
286 :parameter-type | |
287 '(choice :tag "Banner" | |
288 :value nil | |
289 (const :tag "Remove signature" signature) | |
290 (symbol :tag "Item in `gnus-article-banner-alist'" none) | |
291 regexp | |
292 (const :tag "None" nil)) | |
293 :parameter-document | |
294 "If non-nil, specify how to remove `banners' from articles. | |
295 | |
296 Symbol `signature' means to remove signatures delimited by | |
297 `gnus-signature-separator'. Any other symbol is used to look up a | |
298 regular expression to match the banner in `gnus-article-banner-alist'. | |
299 A string is used as a regular expression to match the banner | |
300 directly.") | |
301 | |
302 (defcustom gnus-article-address-banner-alist nil | |
303 "Alist of mail addresses and banners. | |
304 Each element has the form (ADDRESS . BANNER), where ADDRESS is a regexp | |
305 to match a mail address in the From: header, BANNER is one of a symbol | |
306 `signature', an item in `gnus-article-banner-alist', a regexp and nil. | |
307 If ADDRESS matches author's mail address, it will remove things like | |
308 advertisements. For example: | |
309 | |
310 \((\"@yoo-hoo\\\\.co\\\\.jp\\\\'\" . \"\\n_+\\nDo You Yoo-hoo!\\\\?\\n.*\\n.*\\n\")) | |
311 " | |
312 :type '(repeat | |
313 (cons | |
314 (regexp :tag "Address") | |
315 (choice :tag "Banner" :value nil | |
316 (const :tag "Remove signature" signature) | |
317 (symbol :tag "Item in `gnus-article-banner-alist'" none) | |
318 regexp | |
319 (const :tag "None" nil)))) | |
320 :group 'gnus-article-washing) | |
321 | |
239 (defcustom gnus-emphasis-alist | 322 (defcustom gnus-emphasis-alist |
240 (let ((format | 323 (let ((format |
241 "\\(\\s-\\|^\\|[-\"]\\|\\s(\\)\\(%s\\(\\w+\\(\\s-+\\w+\\)*[.,]?\\)%s\\)\\(\\s-\\|[-,;:\"]\\s-\\|[?!.]+\\s-\\|\\s)\\)") | 324 "\\(\\s-\\|^\\|\\=\\|[-\"]\\|\\s(\\)\\(%s\\(\\w+\\(\\s-+\\w+\\)*[.,]?\\)%s\\)\\(\\([-,.;:!?\"]\\|\\s)\\)+\\s-\\|[?!.]\\s-\\|\\s)\\|\\s-\\)") |
242 (types | 325 (types |
243 '(("_" "_" underline) | 326 '(("\\*" "\\*" bold) |
327 ("_" "_" underline) | |
244 ("/" "/" italic) | 328 ("/" "/" italic) |
245 ("\\*" "\\*" bold) | |
246 ("_/" "/_" underline-italic) | 329 ("_/" "/_" underline-italic) |
247 ("_\\*" "\\*_" underline-bold) | 330 ("_\\*" "\\*_" underline-bold) |
248 ("\\*/" "/\\*" bold-italic) | 331 ("\\*/" "/\\*" bold-italic) |
249 ("_\\*/" "/\\*_" underline-bold-italic)))) | 332 ("_\\*/" "/\\*_" underline-bold-italic)))) |
250 `(("\\(\\s-\\|^\\)\\(_\\(\\(\\w\\|_[^_]\\)+\\)_\\)\\(\\s-\\|[?!.,;]\\)" | 333 `(,@(mapcar |
251 2 3 gnus-emphasis-underline) | |
252 ,@(mapcar | |
253 (lambda (spec) | 334 (lambda (spec) |
254 (list | 335 (list |
255 (format format (car spec) (cadr spec)) | 336 (format format (car spec) (cadr spec)) |
256 2 3 (intern (format "gnus-emphasis-%s" (nth 2 spec))))) | 337 2 3 (intern (format "gnus-emphasis-%s" (nth 2 spec))))) |
257 types))) | 338 types) |
339 ("\\(\\s-\\|^\\)\\(-\\(\\(\\w\\|-[^-]\\)+\\)-\\)\\(\\s-\\|[?!.,;]\\)" | |
340 2 3 gnus-emphasis-strikethru) | |
341 ("\\(\\s-\\|^\\)\\(_\\(\\(\\w\\|_[^_]\\)+\\)_\\)\\(\\s-\\|[?!.,;]\\)" | |
342 2 3 gnus-emphasis-underline))) | |
258 "*Alist that says how to fontify certain phrases. | 343 "*Alist that says how to fontify certain phrases. |
259 Each item looks like this: | 344 Each item looks like this: |
260 | 345 |
261 (\"_\\\\(\\\\w+\\\\)_\" 0 1 'underline) | 346 (\"_\\\\(\\\\w+\\\\)_\" 0 1 'underline) |
262 | 347 |
279 and the latter avoids underlining any whitespace at all." | 364 and the latter avoids underlining any whitespace at all." |
280 :version "21.1" | 365 :version "21.1" |
281 :group 'gnus-article-emphasis | 366 :group 'gnus-article-emphasis |
282 :type 'regexp) | 367 :type 'regexp) |
283 | 368 |
284 (defface gnus-emphasis-bold '((t (:weight bold))) | 369 (defface gnus-emphasis-bold '((t (:bold t))) |
285 "Face used for displaying strong emphasized text (*word*)." | 370 "Face used for displaying strong emphasized text (*word*)." |
286 :group 'gnus-article-emphasis) | 371 :group 'gnus-article-emphasis) |
287 | 372 |
288 (defface gnus-emphasis-italic '((t (:slant italic))) | 373 (defface gnus-emphasis-italic '((t (:italic t))) |
289 "Face used for displaying italic emphasized text (/word/)." | 374 "Face used for displaying italic emphasized text (/word/)." |
290 :group 'gnus-article-emphasis) | 375 :group 'gnus-article-emphasis) |
291 | 376 |
292 (defface gnus-emphasis-underline '((t (:underline t))) | 377 (defface gnus-emphasis-underline '((t (:underline t))) |
293 "Face used for displaying underlined emphasized text (_word_)." | 378 "Face used for displaying underlined emphasized text (_word_)." |
294 :group 'gnus-article-emphasis) | 379 :group 'gnus-article-emphasis) |
295 | 380 |
296 (defface gnus-emphasis-underline-bold '((t (:weight bold :underline t))) | 381 (defface gnus-emphasis-underline-bold '((t (:bold t :underline t))) |
297 "Face used for displaying underlined bold emphasized text (_*word*_)." | 382 "Face used for displaying underlined bold emphasized text (_*word*_)." |
298 :group 'gnus-article-emphasis) | 383 :group 'gnus-article-emphasis) |
299 | 384 |
300 (defface gnus-emphasis-underline-italic '((t (:slant italic :underline t))) | 385 (defface gnus-emphasis-underline-italic '((t (:italic t :underline t))) |
301 "Face used for displaying underlined italic emphasized text (_/word/_)." | 386 "Face used for displaying underlined italic emphasized text (_/word/_)." |
302 :group 'gnus-article-emphasis) | 387 :group 'gnus-article-emphasis) |
303 | 388 |
304 (defface gnus-emphasis-bold-italic '((t (:weight bold :slant italic))) | 389 (defface gnus-emphasis-bold-italic '((t (:bold t :italic t))) |
305 "Face used for displaying bold italic emphasized text (/*word*/)." | 390 "Face used for displaying bold italic emphasized text (/*word*/)." |
306 :group 'gnus-article-emphasis) | 391 :group 'gnus-article-emphasis) |
307 | 392 |
308 (defface gnus-emphasis-underline-bold-italic | 393 (defface gnus-emphasis-underline-bold-italic |
309 '((t (:weight bold :slant italic :underline t))) | 394 '((t (:bold t :italic t :underline t))) |
310 "Face used for displaying underlined bold italic emphasized text. | 395 "Face used for displaying underlined bold italic emphasized text. |
311 Example: (_/*word*/_)." | 396 Example: (_/*word*/_)." |
397 :group 'gnus-article-emphasis) | |
398 | |
399 (defface gnus-emphasis-strikethru (if (featurep 'xemacs) | |
400 '((t (:strikethru t))) | |
401 '((t (:strike-through t)))) | |
402 "Face used for displaying strike-through text (-word-)." | |
312 :group 'gnus-article-emphasis) | 403 :group 'gnus-article-emphasis) |
313 | 404 |
314 (defface gnus-emphasis-highlight-words | 405 (defface gnus-emphasis-highlight-words |
315 '((t (:background "black" :foreground "yellow"))) | 406 '((t (:background "black" :foreground "yellow"))) |
316 "Face used for displaying highlighted words." | 407 "Face used for displaying highlighted words." |
365 | 456 |
366 * gnus-summary-save-in-rmail (Rmail format) | 457 * gnus-summary-save-in-rmail (Rmail format) |
367 * gnus-summary-save-in-mail (Unix mail format) | 458 * gnus-summary-save-in-mail (Unix mail format) |
368 * gnus-summary-save-in-folder (MH folder) | 459 * gnus-summary-save-in-folder (MH folder) |
369 * gnus-summary-save-in-file (article format) | 460 * gnus-summary-save-in-file (article format) |
461 * gnus-summary-save-body-in-file (article body) | |
370 * gnus-summary-save-in-vm (use VM's folder format) | 462 * gnus-summary-save-in-vm (use VM's folder format) |
371 * gnus-summary-write-to-file (article format -- overwrite)." | 463 * gnus-summary-write-to-file (article format -- overwrite)." |
372 :group 'gnus-article-saving | 464 :group 'gnus-article-saving |
373 :type '(radio (function-item gnus-summary-save-in-rmail) | 465 :type '(radio (function-item gnus-summary-save-in-rmail) |
374 (function-item gnus-summary-save-in-mail) | 466 (function-item gnus-summary-save-in-mail) |
375 (function-item gnus-summary-save-in-folder) | 467 (function-item gnus-summary-save-in-folder) |
376 (function-item gnus-summary-save-in-file) | 468 (function-item gnus-summary-save-in-file) |
469 (function-item gnus-summary-save-body-in-file) | |
377 (function-item gnus-summary-save-in-vm) | 470 (function-item gnus-summary-save-in-vm) |
378 (function-item gnus-summary-write-to-file))) | 471 (function-item gnus-summary-write-to-file))) |
379 | 472 |
380 (defcustom gnus-rmail-save-name 'gnus-plain-save-name | 473 (defcustom gnus-rmail-save-name 'gnus-plain-save-name |
381 "A function generating a file name to save articles in Rmail format. | 474 "A function generating a file name to save articles in Rmail format. |
450 (defcustom gnus-article-mode-hook nil | 543 (defcustom gnus-article-mode-hook nil |
451 "*A hook for Gnus article mode." | 544 "*A hook for Gnus article mode." |
452 :type 'hook | 545 :type 'hook |
453 :group 'gnus-article-various) | 546 :group 'gnus-article-various) |
454 | 547 |
548 (when (featurep 'xemacs) | |
549 ;; Extracted from gnus-xmas-define in order to preserve user settings | |
550 (when (fboundp 'turn-off-scroll-in-place) | |
551 (add-hook 'gnus-article-mode-hook 'turn-off-scroll-in-place)) | |
552 ;; Extracted from gnus-xmas-redefine in order to preserve user settings | |
553 (add-hook 'gnus-article-mode-hook 'gnus-xmas-article-menu-add)) | |
554 | |
455 (defcustom gnus-article-menu-hook nil | 555 (defcustom gnus-article-menu-hook nil |
456 "*Hook run after the creation of the article mode menu." | 556 "*Hook run after the creation of the article mode menu." |
457 :type 'hook | 557 :type 'hook |
458 :group 'gnus-article-various) | 558 :group 'gnus-article-various) |
459 | 559 |
460 (defcustom gnus-article-prepare-hook nil | 560 (defcustom gnus-article-prepare-hook nil |
461 "*A hook called after an article has been prepared in the article buffer." | 561 "*A hook called after an article has been prepared in the article buffer." |
462 :type 'hook | 562 :type 'hook |
463 :group 'gnus-article-various) | 563 :group 'gnus-article-various) |
464 | 564 |
465 (defcustom gnus-article-hide-pgp-hook nil | 565 (make-obsolete-variable 'gnus-article-hide-pgp-hook |
466 "*A hook called after successfully hiding a PGP signature." | 566 "This variable is obsolete in Gnus 5.10.") |
467 :type 'hook | |
468 :group 'gnus-article-various) | |
469 | 567 |
470 (defcustom gnus-article-button-face 'bold | 568 (defcustom gnus-article-button-face 'bold |
471 "Face used for highlighting buttons in the article buffer. | 569 "Face used for highlighting buttons in the article buffer. |
472 | 570 |
473 An article button is a piece of text that you can activate by pressing | 571 An article button is a piece of text that you can activate by pressing |
490 :group 'gnus-article-highlight | 588 :group 'gnus-article-highlight |
491 :group 'gnus-article-signature) | 589 :group 'gnus-article-signature) |
492 | 590 |
493 (defface gnus-signature-face | 591 (defface gnus-signature-face |
494 '((t | 592 '((t |
495 (:slant italic))) | 593 (:italic t))) |
496 "Face used for highlighting a signature in the article buffer." | 594 "Face used for highlighting a signature in the article buffer." |
497 :group 'gnus-article-highlight | 595 :group 'gnus-article-highlight |
498 :group 'gnus-article-signature) | 596 :group 'gnus-article-signature) |
499 | 597 |
500 (defface gnus-header-from-face | 598 (defface gnus-header-from-face |
503 (:foreground "spring green")) | 601 (:foreground "spring green")) |
504 (((class color) | 602 (((class color) |
505 (background light)) | 603 (background light)) |
506 (:foreground "red3")) | 604 (:foreground "red3")) |
507 (t | 605 (t |
508 (:slant italic))) | 606 (:italic t))) |
509 "Face used for displaying from headers." | 607 "Face used for displaying from headers." |
510 :group 'gnus-article-headers | 608 :group 'gnus-article-headers |
511 :group 'gnus-article-highlight) | 609 :group 'gnus-article-highlight) |
512 | 610 |
513 (defface gnus-header-subject-face | 611 (defface gnus-header-subject-face |
516 (:foreground "SeaGreen3")) | 614 (:foreground "SeaGreen3")) |
517 (((class color) | 615 (((class color) |
518 (background light)) | 616 (background light)) |
519 (:foreground "red4")) | 617 (:foreground "red4")) |
520 (t | 618 (t |
521 (:weight bold :slant italic))) | 619 (:bold t :italic t))) |
522 "Face used for displaying subject headers." | 620 "Face used for displaying subject headers." |
523 :group 'gnus-article-headers | 621 :group 'gnus-article-headers |
524 :group 'gnus-article-highlight) | 622 :group 'gnus-article-highlight) |
525 | 623 |
526 (defface gnus-header-newsgroups-face | 624 (defface gnus-header-newsgroups-face |
527 '((((class color) | 625 '((((class color) |
528 (background dark)) | 626 (background dark)) |
529 (:foreground "yellow" :slant italic)) | 627 (:foreground "yellow" :italic t)) |
530 (((class color) | 628 (((class color) |
531 (background light)) | 629 (background light)) |
532 (:foreground "MidnightBlue" :slant italic)) | 630 (:foreground "MidnightBlue" :italic t)) |
533 (t | 631 (t |
534 (:slant italic))) | 632 (:italic t))) |
535 "Face used for displaying newsgroups headers." | 633 "Face used for displaying newsgroups headers. |
634 In the default setup this face is only used for crossposted | |
635 articles." | |
536 :group 'gnus-article-headers | 636 :group 'gnus-article-headers |
537 :group 'gnus-article-highlight) | 637 :group 'gnus-article-highlight) |
538 | 638 |
539 (defface gnus-header-name-face | 639 (defface gnus-header-name-face |
540 '((((class color) | 640 '((((class color) |
542 (:foreground "SeaGreen")) | 642 (:foreground "SeaGreen")) |
543 (((class color) | 643 (((class color) |
544 (background light)) | 644 (background light)) |
545 (:foreground "maroon")) | 645 (:foreground "maroon")) |
546 (t | 646 (t |
547 (:weight bold))) | 647 (:bold t))) |
548 "Face used for displaying header names." | 648 "Face used for displaying header names." |
549 :group 'gnus-article-headers | 649 :group 'gnus-article-headers |
550 :group 'gnus-article-highlight) | 650 :group 'gnus-article-highlight) |
551 | 651 |
552 (defface gnus-header-content-face | 652 (defface gnus-header-content-face |
553 '((((class color) | 653 '((((class color) |
554 (background dark)) | 654 (background dark)) |
555 (:foreground "forest green" :slant italic)) | 655 (:foreground "forest green" :italic t)) |
556 (((class color) | 656 (((class color) |
557 (background light)) | 657 (background light)) |
558 (:foreground "indianred4" :slant italic)) | 658 (:foreground "indianred4" :italic t)) |
559 (t | 659 (t |
560 (:slant italic))) "Face used for displaying header content." | 660 (:italic t))) "Face used for displaying header content." |
561 :group 'gnus-article-headers | 661 :group 'gnus-article-headers |
562 :group 'gnus-article-highlight) | 662 :group 'gnus-article-highlight) |
563 | 663 |
564 (defcustom gnus-header-face-alist | 664 (defcustom gnus-header-face-alist |
565 '(("From" nil gnus-header-from-face) | 665 '(("From" nil gnus-header-from-face) |
566 ("Subject" nil gnus-header-subject-face) | 666 ("Subject" nil gnus-header-subject-face) |
567 ("Newsgroups:.*," nil gnus-header-newsgroups-face) | 667 ("Newsgroups:.*," nil gnus-header-newsgroups-face) |
568 ("" gnus-header-name-face gnus-header-content-face)) | 668 ("" gnus-header-name-face gnus-header-content-face)) |
569 "*Controls highlighting of article header. | 669 "*Controls highlighting of article headers. |
570 | 670 |
571 An alist of the form (HEADER NAME CONTENT). | 671 An alist of the form (HEADER NAME CONTENT). |
572 | 672 |
573 HEADER is a regular expression which should match the name of an | 673 HEADER is a regular expression which should match the name of a |
574 header header and NAME and CONTENT are either face names or nil. | 674 header and NAME and CONTENT are either face names or nil. |
575 | 675 |
576 The name of each header field will be displayed using the face | 676 The name of each header field will be displayed using the face |
577 specified by the first element in the list where HEADER match the | 677 specified by the first element in the list where HEADER matches |
578 header name and NAME is non-nil. Similarly, the content will be | 678 the header name and NAME is non-nil. Similarly, the content will |
579 displayed by the first non-nil matching CONTENT face." | 679 be displayed by the first non-nil matching CONTENT face." |
580 :group 'gnus-article-headers | 680 :group 'gnus-article-headers |
581 :group 'gnus-article-highlight | 681 :group 'gnus-article-highlight |
582 :type '(repeat (list (regexp :tag "Header") | 682 :type '(repeat (list (regexp :tag "Header") |
583 (choice :tag "Name" | 683 (choice :tag "Name" |
584 (item :tag "skip" nil) | 684 (item :tag "skip" nil) |
586 (choice :tag "Content" | 686 (choice :tag "Content" |
587 (item :tag "skip" nil) | 687 (item :tag "skip" nil) |
588 (face :value default))))) | 688 (face :value default))))) |
589 | 689 |
590 (defcustom gnus-article-decode-hook | 690 (defcustom gnus-article-decode-hook |
591 '(article-decode-charset article-decode-encoded-words) | 691 '(article-decode-charset article-decode-encoded-words |
692 article-decode-group-name article-decode-idna-rhs) | |
592 "*Hook run to decode charsets in articles." | 693 "*Hook run to decode charsets in articles." |
593 :group 'gnus-article-headers | 694 :group 'gnus-article-headers |
594 :type 'hook) | 695 :type 'hook) |
595 | 696 |
596 (defcustom gnus-display-mime-function 'gnus-display-mime | 697 (defcustom gnus-display-mime-function 'gnus-display-mime |
600 | 701 |
601 (defvar gnus-decode-header-function 'mail-decode-encoded-word-region | 702 (defvar gnus-decode-header-function 'mail-decode-encoded-word-region |
602 "Function used to decode headers.") | 703 "Function used to decode headers.") |
603 | 704 |
604 (defvar gnus-article-dumbquotes-map | 705 (defvar gnus-article-dumbquotes-map |
605 '(("\202" ",") | 706 '(("\200" "EUR") |
707 ("\202" ",") | |
606 ("\203" "f") | 708 ("\203" "f") |
607 ("\204" ",,") | 709 ("\204" ",,") |
608 ("\205" "...") | 710 ("\205" "...") |
609 ("\213" "<") | 711 ("\213" "<") |
610 ("\214" "OE") | 712 ("\214" "OE") |
613 ("\223" "``") | 715 ("\223" "``") |
614 ("\224" "\"") | 716 ("\224" "\"") |
615 ("\225" "*") | 717 ("\225" "*") |
616 ("\226" "-") | 718 ("\226" "-") |
617 ("\227" "--") | 719 ("\227" "--") |
720 ("\230" "~") | |
618 ("\231" "(TM)") | 721 ("\231" "(TM)") |
619 ("\233" ">") | 722 ("\233" ">") |
620 ("\234" "oe") | 723 ("\234" "oe") |
621 ("\264" "'")) | 724 ("\264" "'")) |
622 "Table for MS-to-Latin1 translation.") | 725 "Table for MS-to-Latin1 translation.") |
626 :version "21.1" | 729 :version "21.1" |
627 :group 'gnus-article-mime | 730 :group 'gnus-article-mime |
628 :type '(repeat regexp)) | 731 :type '(repeat regexp)) |
629 | 732 |
630 (defcustom gnus-unbuttonized-mime-types '(".*/.*") | 733 (defcustom gnus-unbuttonized-mime-types '(".*/.*") |
631 "List of MIME types that should not be given buttons when rendered inline." | 734 "List of MIME types that should not be given buttons when rendered inline. |
735 See also `gnus-buttonized-mime-types' which may override this variable. | |
736 This variable is only used when `gnus-inhibit-mime-unbuttonizing' is nil." | |
632 :version "21.1" | 737 :version "21.1" |
633 :group 'gnus-article-mime | 738 :group 'gnus-article-mime |
634 :type '(repeat regexp)) | 739 :type '(repeat regexp)) |
740 | |
741 (defcustom gnus-buttonized-mime-types nil | |
742 "List of MIME types that should be given buttons when rendered inline. | |
743 If set, this variable overrides `gnus-unbuttonized-mime-types'. | |
744 To see e.g. security buttons you could set this to | |
745 `(\"multipart/signed\")'. | |
746 This variable is only used when `gnus-inhibit-mime-unbuttonizing' is nil." | |
747 :version "21.1" | |
748 :group 'gnus-article-mime | |
749 :type '(repeat regexp)) | |
750 | |
751 (defcustom gnus-inhibit-mime-unbuttonizing nil | |
752 "If non-nil, all MIME parts get buttons. | |
753 When nil (the default value), then some MIME parts do not get buttons, | |
754 as described by the variables `gnus-buttonized-mime-types' and | |
755 `gnus-unbuttonized-mime-types'." | |
756 :version "21.3" | |
757 :type 'boolean) | |
758 | |
759 (defcustom gnus-body-boundary-delimiter "_" | |
760 "String used to delimit header and body. | |
761 This variable is used by `gnus-article-treat-body-boundary' which can | |
762 be controlled by `gnus-treat-body-boundary'." | |
763 :group 'gnus-article-various | |
764 :type '(choice (item :tag "None" :value nil) | |
765 string)) | |
766 | |
767 (defcustom gnus-picon-databases '("/usr/lib/picon" "/usr/local/faces") | |
768 "Defines the location of the faces database. | |
769 For information on obtaining this database of pretty pictures, please | |
770 see http://www.cs.indiana.edu/picons/ftp/index.html" | |
771 :type '(repeat directory) | |
772 :link '(url-link :tag "download" | |
773 "http://www.cs.indiana.edu/picons/ftp/index.html") | |
774 :link '(custom-manual "(gnus)Picons") | |
775 :group 'gnus-picon) | |
776 | |
777 (defun gnus-picons-installed-p () | |
778 "Say whether picons are installed on your machine." | |
779 (let ((installed nil)) | |
780 (dolist (database gnus-picon-databases) | |
781 (when (file-exists-p database) | |
782 (setq installed t))) | |
783 installed)) | |
635 | 784 |
636 (defcustom gnus-article-mime-part-function nil | 785 (defcustom gnus-article-mime-part-function nil |
637 "Function called with a MIME handle as the argument. | 786 "Function called with a MIME handle as the argument. |
638 This is meant for people who want to do something automatic based | 787 This is meant for people who want to do something automatic based |
639 on parts -- for instance, adding Vcard info to a database." | 788 on parts -- for instance, adding Vcard info to a database." |
672 :value undisplayed-alternative) | 821 :value undisplayed-alternative) |
673 (function))) | 822 (function))) |
674 | 823 |
675 (defcustom gnus-mime-action-alist | 824 (defcustom gnus-mime-action-alist |
676 '(("save to file" . gnus-mime-save-part) | 825 '(("save to file" . gnus-mime-save-part) |
826 ("save and strip" . gnus-mime-save-part-and-strip) | |
827 ("delete part" . gnus-mime-delete-part) | |
677 ("display as text" . gnus-mime-inline-part) | 828 ("display as text" . gnus-mime-inline-part) |
678 ("view the part" . gnus-mime-view-part) | 829 ("view the part" . gnus-mime-view-part) |
679 ("pipe to command" . gnus-mime-pipe-part) | 830 ("pipe to command" . gnus-mime-pipe-part) |
680 ("toggle display" . gnus-article-press-button) | 831 ("toggle display" . gnus-article-press-button) |
832 ("toggle display" . gnus-article-view-part-as-charset) | |
681 ("view as type" . gnus-mime-view-part-as-type) | 833 ("view as type" . gnus-mime-view-part-as-type) |
682 ("internalize type" . gnus-mime-internalize-part) | 834 ("view internally" . gnus-mime-view-part-internally) |
683 ("externalize type" . gnus-mime-externalize-part)) | 835 ("view externally" . gnus-mime-view-part-externally)) |
684 "An alist of actions that run on the MIME attachment." | 836 "An alist of actions that run on the MIME attachment." |
685 :version "21.1" | |
686 :group 'gnus-article-mime | 837 :group 'gnus-article-mime |
687 :type '(repeat (cons (string :tag "name") | 838 :type '(repeat (cons (string :tag "name") |
688 (function)))) | 839 (function)))) |
689 | 840 |
690 ;;; | 841 ;;; |
711 "Parts to treat.") | 862 "Parts to treat.") |
712 | 863 |
713 (defvar gnus-inhibit-treatment nil | 864 (defvar gnus-inhibit-treatment nil |
714 "Whether to inhibit treatment.") | 865 "Whether to inhibit treatment.") |
715 | 866 |
716 (defcustom gnus-treat-highlight-signature '(or last (typep "text/x-vcard")) | 867 (defcustom gnus-treat-highlight-signature '(or t (typep "text/x-vcard")) |
717 "Highlight the signature. | 868 "Highlight the signature. |
718 Valid values are nil, t, `head', `last', an integer or a predicate. | 869 Valid values are nil, t, `head', `last', an integer or a predicate. |
719 See the manual for details." | 870 See Info node `(gnus)Customizing Articles'." |
720 :group 'gnus-article-treat | 871 :group 'gnus-article-treat |
872 :link '(custom-manual "(gnus)Customizing Articles") | |
721 :type gnus-article-treat-custom) | 873 :type gnus-article-treat-custom) |
722 (put 'gnus-treat-highlight-signature 'highlight t) | 874 (put 'gnus-treat-highlight-signature 'highlight t) |
723 | 875 |
724 (defcustom gnus-treat-buttonize 100000 | 876 (defcustom gnus-treat-buttonize 100000 |
725 "Add buttons. | 877 "Add buttons. |
726 Valid values are nil, t, `head', `last', an integer or a predicate. | 878 Valid values are nil, t, `head', `last', an integer or a predicate. |
727 See the manual for details." | 879 See Info node `(gnus)Customizing Articles'." |
728 :group 'gnus-article-treat | 880 :group 'gnus-article-treat |
881 :link '(custom-manual "(gnus)Customizing Articles") | |
729 :type gnus-article-treat-custom) | 882 :type gnus-article-treat-custom) |
730 (put 'gnus-treat-buttonize 'highlight t) | 883 (put 'gnus-treat-buttonize 'highlight t) |
731 | 884 |
732 (defcustom gnus-treat-buttonize-head 'head | 885 (defcustom gnus-treat-buttonize-head 'head |
733 "Add buttons to the head. | 886 "Add buttons to the head. |
734 Valid values are nil, t, `head', `last', an integer or a predicate. | 887 Valid values are nil, t, `head', `last', an integer or a predicate. |
735 See the manual for details." | 888 See Info node `(gnus)Customizing Articles' for details." |
736 :group 'gnus-article-treat | 889 :group 'gnus-article-treat |
890 :link '(custom-manual "(gnus)Customizing Articles") | |
737 :type gnus-article-treat-head-custom) | 891 :type gnus-article-treat-head-custom) |
738 (put 'gnus-treat-buttonize-head 'highlight t) | 892 (put 'gnus-treat-buttonize-head 'highlight t) |
739 | 893 |
740 (defcustom gnus-treat-emphasize | 894 (defcustom gnus-treat-emphasize |
741 (and (or window-system | 895 (and (or window-system |
742 (featurep 'xemacs) | 896 (featurep 'xemacs) |
743 (>= (string-to-number emacs-version) 21)) | 897 (>= (string-to-number emacs-version) 21)) |
744 50000) | 898 50000) |
745 "Emphasize text. | 899 "Emphasize text. |
746 Valid values are nil, t, `head', `last', an integer or a predicate. | 900 Valid values are nil, t, `head', `last', an integer or a predicate. |
747 See the manual for details." | 901 See Info node `(gnus)Customizing Articles' for details." |
748 :group 'gnus-article-treat | 902 :group 'gnus-article-treat |
903 :link '(custom-manual "(gnus)Customizing Articles") | |
749 :type gnus-article-treat-custom) | 904 :type gnus-article-treat-custom) |
750 (put 'gnus-treat-emphasize 'highlight t) | 905 (put 'gnus-treat-emphasize 'highlight t) |
751 | 906 |
752 (defcustom gnus-treat-strip-cr nil | 907 (defcustom gnus-treat-strip-cr nil |
753 "Remove carriage returns. | 908 "Remove carriage returns. |
754 Valid values are nil, t, `head', `last', an integer or a predicate. | 909 Valid values are nil, t, `head', `last', an integer or a predicate. |
755 See the manual for details." | 910 See Info node `(gnus)Customizing Articles' for details." |
756 :group 'gnus-article-treat | 911 :group 'gnus-article-treat |
912 :link '(custom-manual "(gnus)Customizing Articles") | |
913 :type gnus-article-treat-custom) | |
914 | |
915 (defcustom gnus-treat-unsplit-urls nil | |
916 "Remove newlines from within URLs. | |
917 Valid values are nil, t, `head', `last', an integer or a predicate. | |
918 See Info node `(gnus)Customizing Articles' for details." | |
919 :group 'gnus-article-treat | |
920 :link '(custom-manual "(gnus)Customizing Articles") | |
921 :type gnus-article-treat-custom) | |
922 | |
923 (defcustom gnus-treat-leading-whitespace nil | |
924 "Remove leading whitespace in headers. | |
925 Valid values are nil, t, `head', `last', an integer or a predicate. | |
926 See Info node `(gnus)Customizing Articles' for details." | |
927 :group 'gnus-article-treat | |
928 :link '(custom-manual "(gnus)Customizing Articles") | |
757 :type gnus-article-treat-custom) | 929 :type gnus-article-treat-custom) |
758 | 930 |
759 (defcustom gnus-treat-hide-headers 'head | 931 (defcustom gnus-treat-hide-headers 'head |
760 "Hide headers. | 932 "Hide headers. |
761 Valid values are nil, t, `head', `last', an integer or a predicate. | 933 Valid values are nil, t, `head', `last', an integer or a predicate. |
762 See the manual for details." | 934 See Info node `(gnus)Customizing Articles' for details." |
763 :group 'gnus-article-treat | 935 :group 'gnus-article-treat |
936 :link '(custom-manual "(gnus)Customizing Articles") | |
764 :type gnus-article-treat-head-custom) | 937 :type gnus-article-treat-head-custom) |
765 | 938 |
766 (defcustom gnus-treat-hide-boring-headers nil | 939 (defcustom gnus-treat-hide-boring-headers nil |
767 "Hide boring headers. | 940 "Hide boring headers. |
768 Valid values are nil, t, `head', `last', an integer or a predicate. | 941 Valid values are nil, t, `head', `last', an integer or a predicate. |
769 See the manual for details." | 942 See Info node `(gnus)Customizing Articles' for details." |
770 :group 'gnus-article-treat | 943 :group 'gnus-article-treat |
944 :link '(custom-manual "(gnus)Customizing Articles") | |
771 :type gnus-article-treat-head-custom) | 945 :type gnus-article-treat-head-custom) |
772 | 946 |
773 (defcustom gnus-treat-hide-signature nil | 947 (defcustom gnus-treat-hide-signature nil |
774 "Hide the signature. | 948 "Hide the signature. |
775 Valid values are nil, t, `head', `last', an integer or a predicate. | 949 Valid values are nil, t, `head', `last', an integer or a predicate. |
776 See the manual for details." | 950 See Info node `(gnus)Customizing Articles' for details." |
777 :group 'gnus-article-treat | 951 :group 'gnus-article-treat |
952 :link '(custom-manual "(gnus)Customizing Articles") | |
778 :type gnus-article-treat-custom) | 953 :type gnus-article-treat-custom) |
779 | 954 |
780 (defcustom gnus-treat-fill-article nil | 955 (defcustom gnus-treat-fill-article nil |
781 "Fill the article. | 956 "Fill the article. |
782 Valid values are nil, t, `head', `last', an integer or a predicate. | 957 Valid values are nil, t, `head', `last', an integer or a predicate. |
783 See the manual for details." | 958 See Info node `(gnus)Customizing Articles' for details." |
784 :group 'gnus-article-treat | 959 :group 'gnus-article-treat |
960 :link '(custom-manual "(gnus)Customizing Articles") | |
785 :type gnus-article-treat-custom) | 961 :type gnus-article-treat-custom) |
786 | 962 |
787 (defcustom gnus-treat-hide-citation nil | 963 (defcustom gnus-treat-hide-citation nil |
788 "Hide cited text. | 964 "Hide cited text. |
789 Valid values are nil, t, `head', `last', an integer or a predicate. | 965 Valid values are nil, t, `head', `last', an integer or a predicate. |
790 See the manual for details." | 966 See Info node `(gnus)Customizing Articles' for details." |
791 :group 'gnus-article-treat | 967 :group 'gnus-article-treat |
968 :link '(custom-manual "(gnus)Customizing Articles") | |
792 :type gnus-article-treat-custom) | 969 :type gnus-article-treat-custom) |
793 | 970 |
794 (defcustom gnus-treat-hide-citation-maybe nil | 971 (defcustom gnus-treat-hide-citation-maybe nil |
795 "Hide cited text. | 972 "Hide cited text. |
796 Valid values are nil, t, `head', `last', an integer or a predicate. | 973 Valid values are nil, t, `head', `last', an integer or a predicate. |
797 See the manual for details." | 974 See Info node `(gnus)Customizing Articles' for details." |
798 :group 'gnus-article-treat | 975 :group 'gnus-article-treat |
976 :link '(custom-manual "(gnus)Customizing Articles") | |
799 :type gnus-article-treat-custom) | 977 :type gnus-article-treat-custom) |
800 | 978 |
801 (defcustom gnus-treat-strip-list-identifiers 'head | 979 (defcustom gnus-treat-strip-list-identifiers 'head |
802 "Strip list identifiers from `gnus-list-identifiers`. | 980 "Strip list identifiers from `gnus-list-identifiers`. |
803 Valid values are nil, t, `head', `last', an integer or a predicate. | 981 Valid values are nil, t, `head', `last', an integer or a predicate. |
804 See the manual for details." | 982 See Info node `(gnus)Customizing Articles' for details." |
805 :version "21.1" | 983 :version "21.1" |
806 :group 'gnus-article-treat | 984 :group 'gnus-article-treat |
985 :link '(custom-manual "(gnus)Customizing Articles") | |
807 :type gnus-article-treat-custom) | 986 :type gnus-article-treat-custom) |
808 | 987 |
809 (defcustom gnus-treat-strip-pgp t | 988 (make-obsolete-variable 'gnus-treat-strip-pgp |
810 "Strip PGP signatures. | 989 "This option is obsolete in Gnus 5.10.") |
811 Valid values are nil, t, `head', `last', an integer or a predicate. | |
812 See the manual for details." | |
813 :group 'gnus-article-treat | |
814 :type gnus-article-treat-custom) | |
815 | 990 |
816 (defcustom gnus-treat-strip-pem nil | 991 (defcustom gnus-treat-strip-pem nil |
817 "Strip PEM signatures. | 992 "Strip PEM signatures. |
818 Valid values are nil, t, `head', `last', an integer or a predicate. | 993 Valid values are nil, t, `head', `last', an integer or a predicate. |
819 See the manual for details." | 994 See Info node `(gnus)Customizing Articles' for details." |
820 :group 'gnus-article-treat | 995 :group 'gnus-article-treat |
996 :link '(custom-manual "(gnus)Customizing Articles") | |
821 :type gnus-article-treat-custom) | 997 :type gnus-article-treat-custom) |
822 | 998 |
823 (defcustom gnus-treat-strip-banner t | 999 (defcustom gnus-treat-strip-banner t |
824 "Strip banners from articles. | 1000 "Strip banners from articles. |
825 The banner to be stripped is specified in the `banner' group parameter. | 1001 The banner to be stripped is specified in the `banner' group parameter. |
826 Valid values are nil, t, `head', `last', an integer or a predicate. | 1002 Valid values are nil, t, `head', `last', an integer or a predicate. |
827 See the manual for details." | 1003 See Info node `(gnus)Customizing Articles' for details." |
828 :group 'gnus-article-treat | 1004 :group 'gnus-article-treat |
1005 :link '(custom-manual "(gnus)Customizing Articles") | |
829 :type gnus-article-treat-custom) | 1006 :type gnus-article-treat-custom) |
830 | 1007 |
831 (defcustom gnus-treat-highlight-headers 'head | 1008 (defcustom gnus-treat-highlight-headers 'head |
832 "Highlight the headers. | 1009 "Highlight the headers. |
833 Valid values are nil, t, `head', `last', an integer or a predicate. | 1010 Valid values are nil, t, `head', `last', an integer or a predicate. |
834 See the manual for details." | 1011 See Info node `(gnus)Customizing Articles' for details." |
835 :group 'gnus-article-treat | 1012 :group 'gnus-article-treat |
1013 :link '(custom-manual "(gnus)Customizing Articles") | |
836 :type gnus-article-treat-head-custom) | 1014 :type gnus-article-treat-head-custom) |
837 (put 'gnus-treat-highlight-headers 'highlight t) | 1015 (put 'gnus-treat-highlight-headers 'highlight t) |
838 | 1016 |
839 (defcustom gnus-treat-highlight-citation t | 1017 (defcustom gnus-treat-highlight-citation t |
840 "Highlight cited text. | 1018 "Highlight cited text. |
841 Valid values are nil, t, `head', `last', an integer or a predicate. | 1019 Valid values are nil, t, `head', `last', an integer or a predicate. |
842 See the manual for details." | 1020 See Info node `(gnus)Customizing Articles' for details." |
843 :group 'gnus-article-treat | 1021 :group 'gnus-article-treat |
1022 :link '(custom-manual "(gnus)Customizing Articles") | |
844 :type gnus-article-treat-custom) | 1023 :type gnus-article-treat-custom) |
845 (put 'gnus-treat-highlight-citation 'highlight t) | 1024 (put 'gnus-treat-highlight-citation 'highlight t) |
846 | 1025 |
847 (defcustom gnus-treat-date-ut nil | 1026 (defcustom gnus-treat-date-ut nil |
848 "Display the Date in UT (GMT). | 1027 "Display the Date in UT (GMT). |
849 Valid values are nil, t, `head', `last', an integer or a predicate. | 1028 Valid values are nil, t, `head', `last', an integer or a predicate. |
850 See the manual for details." | 1029 See Info node `(gnus)Customizing Articles' for details." |
851 :group 'gnus-article-treat | 1030 :group 'gnus-article-treat |
1031 :link '(custom-manual "(gnus)Customizing Articles") | |
852 :type gnus-article-treat-head-custom) | 1032 :type gnus-article-treat-head-custom) |
853 | 1033 |
854 (defcustom gnus-treat-date-local nil | 1034 (defcustom gnus-treat-date-local nil |
855 "Display the Date in the local timezone. | 1035 "Display the Date in the local timezone. |
856 Valid values are nil, t, `head', `last', an integer or a predicate. | 1036 Valid values are nil, t, `head', `last', an integer or a predicate. |
857 See the manual for details." | 1037 See Info node `(gnus)Customizing Articles' for details." |
858 :group 'gnus-article-treat | 1038 :group 'gnus-article-treat |
1039 :link '(custom-manual "(gnus)Customizing Articles") | |
1040 :type gnus-article-treat-head-custom) | |
1041 | |
1042 (defcustom gnus-treat-date-english nil | |
1043 "Display the Date in a format that can be read aloud in English. | |
1044 Valid values are nil, t, `head', `last', an integer or a predicate. | |
1045 See Info node `(gnus)Customizing Articles' for details." | |
1046 :group 'gnus-article-treat | |
1047 :link '(custom-manual "(gnus)Customizing Articles") | |
859 :type gnus-article-treat-head-custom) | 1048 :type gnus-article-treat-head-custom) |
860 | 1049 |
861 (defcustom gnus-treat-date-lapsed nil | 1050 (defcustom gnus-treat-date-lapsed nil |
862 "Display the Date header in a way that says how much time has elapsed. | 1051 "Display the Date header in a way that says how much time has elapsed. |
863 Valid values are nil, t, `head', `last', an integer or a predicate. | 1052 Valid values are nil, t, `head', `last', an integer or a predicate. |
864 See the manual for details." | 1053 See Info node `(gnus)Customizing Articles' for details." |
865 :group 'gnus-article-treat | 1054 :group 'gnus-article-treat |
1055 :link '(custom-manual "(gnus)Customizing Articles") | |
866 :type gnus-article-treat-head-custom) | 1056 :type gnus-article-treat-head-custom) |
867 | 1057 |
868 (defcustom gnus-treat-date-original nil | 1058 (defcustom gnus-treat-date-original nil |
869 "Display the date in the original timezone. | 1059 "Display the date in the original timezone. |
870 Valid values are nil, t, `head', `last', an integer or a predicate. | 1060 Valid values are nil, t, `head', `last', an integer or a predicate. |
871 See the manual for details." | 1061 See Info node `(gnus)Customizing Articles' for details." |
872 :group 'gnus-article-treat | 1062 :group 'gnus-article-treat |
1063 :link '(custom-manual "(gnus)Customizing Articles") | |
873 :type gnus-article-treat-head-custom) | 1064 :type gnus-article-treat-head-custom) |
874 | 1065 |
875 (defcustom gnus-treat-date-iso8601 nil | 1066 (defcustom gnus-treat-date-iso8601 nil |
876 "Display the date in the ISO8601 format. | 1067 "Display the date in the ISO8601 format. |
877 Valid values are nil, t, `head', `last', an integer or a predicate. | 1068 Valid values are nil, t, `head', `last', an integer or a predicate. |
878 See the manual for details." | 1069 See Info node `(gnus)Customizing Articles' for details." |
879 :version "21.1" | 1070 :version "21.1" |
880 :group 'gnus-article-treat | 1071 :group 'gnus-article-treat |
1072 :link '(custom-manual "(gnus)Customizing Articles") | |
881 :type gnus-article-treat-head-custom) | 1073 :type gnus-article-treat-head-custom) |
882 | 1074 |
883 (defcustom gnus-treat-date-user-defined nil | 1075 (defcustom gnus-treat-date-user-defined nil |
884 "Display the date in a user-defined format. | 1076 "Display the date in a user-defined format. |
885 The format is defined by the `gnus-article-time-format' variable. | 1077 The format is defined by the `gnus-article-time-format' variable. |
886 Valid values are nil, t, `head', `last', an integer or a predicate. | 1078 Valid values are nil, t, `head', `last', an integer or a predicate. |
887 See the manual for details." | 1079 See Info node `(gnus)Customizing Articles' for details." |
888 :group 'gnus-article-treat | 1080 :group 'gnus-article-treat |
1081 :link '(custom-manual "(gnus)Customizing Articles") | |
889 :type gnus-article-treat-head-custom) | 1082 :type gnus-article-treat-head-custom) |
890 | 1083 |
891 (defcustom gnus-treat-strip-headers-in-body t | 1084 (defcustom gnus-treat-strip-headers-in-body t |
892 "Strip the X-No-Archive header line from the beginning of the body. | 1085 "Strip the X-No-Archive header line from the beginning of the body. |
893 Valid values are nil, t, `head', `last', an integer or a predicate. | 1086 Valid values are nil, t, `head', `last', an integer or a predicate. |
894 See the manual for details." | 1087 See Info node `(gnus)Customizing Articles' for details." |
895 :version "21.1" | 1088 :version "21.1" |
896 :group 'gnus-article-treat | 1089 :group 'gnus-article-treat |
1090 :link '(custom-manual "(gnus)Customizing Articles") | |
897 :type gnus-article-treat-custom) | 1091 :type gnus-article-treat-custom) |
898 | 1092 |
899 (defcustom gnus-treat-strip-trailing-blank-lines nil | 1093 (defcustom gnus-treat-strip-trailing-blank-lines nil |
900 "Strip trailing blank lines. | 1094 "Strip trailing blank lines. |
901 Valid values are nil, t, `head', `last', an integer or a predicate. | 1095 Valid values are nil, t, `head', `last', an integer or a predicate. |
902 See the manual for details." | 1096 See Info node `(gnus)Customizing Articles' for details." |
903 :group 'gnus-article-treat | 1097 :group 'gnus-article-treat |
1098 :link '(custom-manual "(gnus)Customizing Articles") | |
904 :type gnus-article-treat-custom) | 1099 :type gnus-article-treat-custom) |
905 | 1100 |
906 (defcustom gnus-treat-strip-leading-blank-lines nil | 1101 (defcustom gnus-treat-strip-leading-blank-lines nil |
907 "Strip leading blank lines. | 1102 "Strip leading blank lines. |
908 Valid values are nil, t, `head', `last', an integer or a predicate. | 1103 Valid values are nil, t, `head', `last', an integer or a predicate. |
909 See the manual for details." | 1104 See Info node `(gnus)Customizing Articles' for details." |
910 :group 'gnus-article-treat | 1105 :group 'gnus-article-treat |
1106 :link '(custom-manual "(gnus)Customizing Articles") | |
911 :type gnus-article-treat-custom) | 1107 :type gnus-article-treat-custom) |
912 | 1108 |
913 (defcustom gnus-treat-strip-multiple-blank-lines nil | 1109 (defcustom gnus-treat-strip-multiple-blank-lines nil |
914 "Strip multiple blank lines. | 1110 "Strip multiple blank lines. |
915 Valid values are nil, t, `head', `last', an integer or a predicate. | 1111 Valid values are nil, t, `head', `last', an integer or a predicate. |
916 See the manual for details." | 1112 See Info node `(gnus)Customizing Articles' for details." |
917 :group 'gnus-article-treat | 1113 :group 'gnus-article-treat |
1114 :link '(custom-manual "(gnus)Customizing Articles") | |
1115 :type gnus-article-treat-custom) | |
1116 | |
1117 (defcustom gnus-treat-unfold-headers 'head | |
1118 "Unfold folded header lines. | |
1119 Valid values are nil, t, `head', `last', an integer or a predicate. | |
1120 See Info node `(gnus)Customizing Articles' for details." | |
1121 :group 'gnus-article-treat | |
1122 :link '(custom-manual "(gnus)Customizing Articles") | |
1123 :type gnus-article-treat-custom) | |
1124 | |
1125 (defcustom gnus-treat-fold-headers nil | |
1126 "Fold headers. | |
1127 Valid values are nil, t, `head', `last', an integer or a predicate. | |
1128 See Info node `(gnus)Customizing Articles' for details." | |
1129 :group 'gnus-article-treat | |
1130 :link '(custom-manual "(gnus)Customizing Articles") | |
1131 :type gnus-article-treat-custom) | |
1132 | |
1133 (defcustom gnus-treat-fold-newsgroups 'head | |
1134 "Fold the Newsgroups and Followup-To headers. | |
1135 Valid values are nil, t, `head', `last', an integer or a predicate. | |
1136 See Info node `(gnus)Customizing Articles' for details." | |
1137 :group 'gnus-article-treat | |
1138 :link '(custom-manual "(gnus)Customizing Articles") | |
918 :type gnus-article-treat-custom) | 1139 :type gnus-article-treat-custom) |
919 | 1140 |
920 (defcustom gnus-treat-overstrike t | 1141 (defcustom gnus-treat-overstrike t |
921 "Treat overstrike highlighting. | 1142 "Treat overstrike highlighting. |
922 Valid values are nil, t, `head', `last', an integer or a predicate. | 1143 Valid values are nil, t, `head', `last', an integer or a predicate. |
923 See the manual for details." | 1144 See Info node `(gnus)Customizing Articles' for details." |
924 :group 'gnus-article-treat | 1145 :group 'gnus-article-treat |
1146 :link '(custom-manual "(gnus)Customizing Articles") | |
925 :type gnus-article-treat-custom) | 1147 :type gnus-article-treat-custom) |
926 (put 'gnus-treat-overstrike 'highlight t) | 1148 (put 'gnus-treat-overstrike 'highlight t) |
927 | 1149 |
928 (defcustom gnus-treat-display-xface | 1150 (make-obsolete-variable 'gnus-treat-display-xface |
929 (and (or (and (fboundp 'image-type-available-p) | 1151 'gnus-treat-display-x-face) |
1152 | |
1153 (defcustom gnus-treat-display-x-face | |
1154 (and (not noninteractive) | |
1155 (or (and (fboundp 'image-type-available-p) | |
930 (image-type-available-p 'xbm) | 1156 (image-type-available-p 'xbm) |
931 (string-match "^0x" (shell-command-to-string "uncompface"))) | 1157 (string-match "^0x" (shell-command-to-string "uncompface")) |
932 (and (featurep 'xemacs) (featurep 'xface))) | 1158 (executable-find "icontopbm")) |
1159 (and (featurep 'xemacs) | |
1160 (featurep 'xface))) | |
933 'head) | 1161 'head) |
934 "Display X-Face headers. | 1162 "Display X-Face headers. |
935 Valid values are nil, t, `head', `last', an integer or a predicate. | 1163 Valid values are nil, t, `head', `last', an integer or a predicate. |
936 See the manual for details." | 1164 See Info node `(gnus)Customizing Articles' and Info node |
1165 `(gnus)X-Face' for details." | |
937 :group 'gnus-article-treat | 1166 :group 'gnus-article-treat |
938 :version "21.1" | 1167 :version "21.1" |
1168 :link '(custom-manual "(gnus)Customizing Articles") | |
1169 :link '(custom-manual "(gnus)X-Face") | |
1170 :type gnus-article-treat-head-custom | |
1171 :set (lambda (symbol value) | |
1172 (set-default | |
1173 symbol | |
1174 (cond ((or (boundp symbol) (get symbol 'saved-value)) | |
1175 value) | |
1176 ((boundp 'gnus-treat-display-xface) | |
1177 (message "\ | |
1178 ** gnus-treat-display-xface is an obsolete variable;\ | |
1179 use gnus-treat-display-x-face instead") | |
1180 (default-value 'gnus-treat-display-xface)) | |
1181 ((get 'gnus-treat-display-xface 'saved-value) | |
1182 (message "\ | |
1183 ** gnus-treat-display-xface is an obsolete variable;\ | |
1184 use gnus-treat-display-x-face instead") | |
1185 (eval (car (get 'gnus-treat-display-xface 'saved-value)))) | |
1186 (t | |
1187 value))))) | |
1188 (put 'gnus-treat-display-x-face 'highlight t) | |
1189 | |
1190 (defcustom gnus-treat-display-face | |
1191 (and (not noninteractive) | |
1192 (or (and (fboundp 'image-type-available-p) | |
1193 (image-type-available-p 'png)) | |
1194 (and (featurep 'xemacs) | |
1195 (featurep 'png))) | |
1196 'head) | |
1197 "Display Face headers. | |
1198 Valid values are nil, t, `head', `last', an integer or a predicate. | |
1199 See Info node `(gnus)Customizing Articles' and Info node | |
1200 `(gnus)X-Face' for details." | |
1201 :group 'gnus-article-treat | |
1202 :version "21.1" | |
1203 :link '(custom-manual "(gnus)Customizing Articles") | |
1204 :link '(custom-manual "(gnus)X-Face") | |
939 :type gnus-article-treat-head-custom) | 1205 :type gnus-article-treat-head-custom) |
940 (put 'gnus-treat-display-xface 'highlight t) | 1206 (put 'gnus-treat-display-face 'highlight t) |
941 | 1207 |
942 (defcustom gnus-treat-display-smileys | 1208 (defcustom gnus-treat-display-smileys |
943 (if (or (and (featurep 'xemacs) | 1209 (if (or (and (featurep 'xemacs) |
944 (featurep 'xpm)) | 1210 (featurep 'xpm)) |
945 (and (fboundp 'image-type-available-p) | 1211 (and (fboundp 'image-type-available-p) |
946 (image-type-available-p 'pbm))) | 1212 (image-type-available-p 'pbm))) |
947 t nil) | 1213 t nil) |
948 "Display smileys. | 1214 "Display smileys. |
949 Valid values are nil, t, `head', `last', an integer or a predicate. | 1215 Valid values are nil, t, `head', `last', an integer or a predicate. |
950 See the manual for details." | 1216 See Info node `(gnus)Customizing Articles' and Info node |
1217 `(gnus)Smileys' for details." | |
951 :group 'gnus-article-treat | 1218 :group 'gnus-article-treat |
952 :version "21.1" | 1219 :version "21.1" |
1220 :link '(custom-manual "(gnus)Customizing Articles") | |
1221 :link '(custom-manual "(gnus)Smileys") | |
953 :type gnus-article-treat-custom) | 1222 :type gnus-article-treat-custom) |
954 (put 'gnus-treat-display-smileys 'highlight t) | 1223 (put 'gnus-treat-display-smileys 'highlight t) |
955 | 1224 |
956 (defcustom gnus-treat-display-picons (if (featurep 'xemacs) 'head nil) | 1225 (defcustom gnus-treat-from-picon |
957 "Display picons. | 1226 (if (and (gnus-image-type-available-p 'xpm) |
1227 (gnus-picons-installed-p)) | |
1228 'head nil) | |
1229 "Display picons in the From header. | |
958 Valid values are nil, t, `head', `last', an integer or a predicate. | 1230 Valid values are nil, t, `head', `last', an integer or a predicate. |
959 See the manual for details." | 1231 See Info node `(gnus)Customizing Articles' and Info node |
1232 `(gnus)Picons' for details." | |
960 :group 'gnus-article-treat | 1233 :group 'gnus-article-treat |
1234 :group 'gnus-picon | |
1235 :link '(custom-manual "(gnus)Customizing Articles") | |
1236 :link '(custom-manual "(gnus)Picons") | |
961 :type gnus-article-treat-head-custom) | 1237 :type gnus-article-treat-head-custom) |
962 (put 'gnus-treat-display-picons 'highlight t) | 1238 (put 'gnus-treat-from-picon 'highlight t) |
1239 | |
1240 (defcustom gnus-treat-mail-picon | |
1241 (if (and (gnus-image-type-available-p 'xpm) | |
1242 (gnus-picons-installed-p)) | |
1243 'head nil) | |
1244 "Display picons in To and Cc headers. | |
1245 Valid values are nil, t, `head', `last', an integer or a predicate. | |
1246 See Info node `(gnus)Customizing Articles' and Info node | |
1247 `(gnus)Picons' for details." | |
1248 :group 'gnus-article-treat | |
1249 :group 'gnus-picon | |
1250 :link '(custom-manual "(gnus)Customizing Articles") | |
1251 :link '(custom-manual "(gnus)Picons") | |
1252 :type gnus-article-treat-head-custom) | |
1253 (put 'gnus-treat-mail-picon 'highlight t) | |
1254 | |
1255 (defcustom gnus-treat-newsgroups-picon | |
1256 (if (and (gnus-image-type-available-p 'xpm) | |
1257 (gnus-picons-installed-p)) | |
1258 'head nil) | |
1259 "Display picons in the Newsgroups and Followup-To headers. | |
1260 Valid values are nil, t, `head', `last', an integer or a predicate. | |
1261 See Info node `(gnus)Customizing Articles' and Info node | |
1262 `(gnus)Picons' for details." | |
1263 :group 'gnus-article-treat | |
1264 :group 'gnus-picon | |
1265 :link '(custom-manual "(gnus)Customizing Articles") | |
1266 :link '(custom-manual "(gnus)Picons") | |
1267 :type gnus-article-treat-head-custom) | |
1268 (put 'gnus-treat-newsgroups-picon 'highlight t) | |
1269 | |
1270 (defcustom gnus-treat-body-boundary | |
1271 (if (or gnus-treat-newsgroups-picon | |
1272 gnus-treat-mail-picon | |
1273 gnus-treat-from-picon) | |
1274 'head nil) | |
1275 "Draw a boundary at the end of the headers. | |
1276 Valid values are nil and `head'. | |
1277 See Info node `(gnus)Customizing Articles' for details." | |
1278 :version "21.1" | |
1279 :group 'gnus-article-treat | |
1280 :link '(custom-manual "(gnus)Customizing Articles") | |
1281 :type gnus-article-treat-head-custom) | |
963 | 1282 |
964 (defcustom gnus-treat-capitalize-sentences nil | 1283 (defcustom gnus-treat-capitalize-sentences nil |
965 "Capitalize sentence-starting words. | 1284 "Capitalize sentence-starting words. |
966 Valid values are nil, t, `head', `last', an integer or a predicate. | 1285 Valid values are nil, t, `head', `last', an integer or a predicate. |
967 See the manual for details." | 1286 See Info node `(gnus)Customizing Articles' for details." |
968 :version "21.1" | 1287 :version "21.1" |
969 :group 'gnus-article-treat | 1288 :group 'gnus-article-treat |
1289 :link '(custom-manual "(gnus)Customizing Articles") | |
1290 :type gnus-article-treat-custom) | |
1291 | |
1292 (defcustom gnus-treat-wash-html nil | |
1293 "Format as HTML. | |
1294 Valid values are nil, t, `head', `last', an integer or a predicate. | |
1295 See Info node `(gnus)Customizing Articles' for details." | |
1296 :group 'gnus-article-treat | |
1297 :link '(custom-manual "(gnus)Customizing Articles") | |
970 :type gnus-article-treat-custom) | 1298 :type gnus-article-treat-custom) |
971 | 1299 |
972 (defcustom gnus-treat-fill-long-lines nil | 1300 (defcustom gnus-treat-fill-long-lines nil |
973 "Fill long lines. | 1301 "Fill long lines. |
974 Valid values are nil, t, `head', `last', an integer or a predicate. | 1302 Valid values are nil, t, `head', `last', an integer or a predicate. |
975 See the manual for details." | 1303 See Info node `(gnus)Customizing Articles' for details." |
976 :group 'gnus-article-treat | 1304 :group 'gnus-article-treat |
1305 :link '(custom-manual "(gnus)Customizing Articles") | |
977 :type gnus-article-treat-custom) | 1306 :type gnus-article-treat-custom) |
978 | 1307 |
979 (defcustom gnus-treat-play-sounds nil | 1308 (defcustom gnus-treat-play-sounds nil |
980 "Play sounds. | 1309 "Play sounds. |
981 Valid values are nil, t, `head', `last', an integer or a predicate. | 1310 Valid values are nil, t, `head', `last', an integer or a predicate. |
982 See the manual for details." | 1311 See Info node `(gnus)Customizing Articles' for details." |
983 :version "21.1" | 1312 :version "21.1" |
984 :group 'gnus-article-treat | 1313 :group 'gnus-article-treat |
1314 :link '(custom-manual "(gnus)Customizing Articles") | |
985 :type gnus-article-treat-custom) | 1315 :type gnus-article-treat-custom) |
986 | 1316 |
987 (defcustom gnus-treat-translate nil | 1317 (defcustom gnus-treat-translate nil |
988 "Translate articles from one language to another. | 1318 "Translate articles from one language to another. |
989 Valid values are nil, t, `head', `last', an integer or a predicate. | 1319 Valid values are nil, t, `head', `last', an integer or a predicate. |
990 See the manual for details." | 1320 See Info node `(gnus)Customizing Articles' for details." |
991 :version "21.1" | 1321 :version "21.1" |
992 :group 'gnus-article-treat | 1322 :group 'gnus-article-treat |
1323 :link '(custom-manual "(gnus)Customizing Articles") | |
993 :type gnus-article-treat-custom) | 1324 :type gnus-article-treat-custom) |
994 | 1325 |
1326 (defcustom gnus-treat-x-pgp-sig nil | |
1327 "Verify X-PGP-Sig. | |
1328 To automatically treat X-PGP-Sig, set it to head. | |
1329 Valid values are nil, t, `head', `last', an integer or a predicate. | |
1330 See Info node `(gnus)Customizing Articles' for details." | |
1331 :group 'gnus-article-treat | |
1332 :group 'mime-security | |
1333 :link '(custom-manual "(gnus)Customizing Articles") | |
1334 :type gnus-article-treat-custom) | |
1335 | |
1336 (defvar gnus-article-encrypt-protocol-alist | |
1337 '(("PGP" . mml2015-self-encrypt))) | |
1338 | |
1339 ;; Set to nil if more than one protocol added to | |
1340 ;; gnus-article-encrypt-protocol-alist. | |
1341 (defcustom gnus-article-encrypt-protocol "PGP" | |
1342 "The protocol used for encrypt articles. | |
1343 It is a string, such as \"PGP\". If nil, ask user." | |
1344 :type 'string | |
1345 :group 'mime-security) | |
1346 | |
1347 (defvar gnus-article-wash-function nil | |
1348 "Function used for converting HTML into text.") | |
1349 | |
1350 (defcustom gnus-use-idna (and (condition-case nil (require 'idna) (file-error)) | |
1351 (mm-coding-system-p 'utf-8) | |
1352 (executable-find idna-program)) | |
1353 "Whether IDNA decoding of headers is used when viewing messages. | |
1354 This requires GNU Libidn, and by default only enabled if it is found." | |
1355 :group 'gnus-article-headers | |
1356 :type 'boolean) | |
1357 | |
1358 (defcustom gnus-article-over-scroll nil | |
1359 "If non-nil, allow scrolling the article buffer even when there no more text." | |
1360 :group 'gnus-article | |
1361 :type 'boolean) | |
1362 | |
995 ;;; Internal variables | 1363 ;;; Internal variables |
1364 | |
1365 (defvar gnus-english-month-names | |
1366 '("January" "February" "March" "April" "May" "June" "July" "August" | |
1367 "September" "October" "November" "December")) | |
996 | 1368 |
997 (defvar article-goto-body-goes-to-point-min-p nil) | 1369 (defvar article-goto-body-goes-to-point-min-p nil) |
998 (defvar gnus-article-wash-types nil) | 1370 (defvar gnus-article-wash-types nil) |
999 (defvar gnus-article-emphasis-alist nil) | 1371 (defvar gnus-article-emphasis-alist nil) |
1372 (defvar gnus-article-image-alist nil) | |
1000 | 1373 |
1001 (defvar gnus-article-mime-handle-alist-1 nil) | 1374 (defvar gnus-article-mime-handle-alist-1 nil) |
1002 (defvar gnus-treatment-function-alist | 1375 (defvar gnus-treatment-function-alist |
1003 '((gnus-treat-strip-banner gnus-article-strip-banner) | 1376 '((gnus-treat-x-pgp-sig gnus-article-verify-x-pgp-sig) |
1377 (gnus-treat-strip-banner gnus-article-strip-banner) | |
1004 (gnus-treat-strip-headers-in-body gnus-article-strip-headers-in-body) | 1378 (gnus-treat-strip-headers-in-body gnus-article-strip-headers-in-body) |
1005 (gnus-treat-highlight-signature gnus-article-highlight-signature) | 1379 (gnus-treat-highlight-signature gnus-article-highlight-signature) |
1006 (gnus-treat-buttonize gnus-article-add-buttons) | 1380 (gnus-treat-buttonize gnus-article-add-buttons) |
1007 (gnus-treat-fill-article gnus-article-fill-cited-article) | 1381 (gnus-treat-fill-article gnus-article-fill-cited-article) |
1008 (gnus-treat-fill-long-lines gnus-article-fill-long-lines) | 1382 (gnus-treat-fill-long-lines gnus-article-fill-long-lines) |
1009 (gnus-treat-strip-cr gnus-article-remove-cr) | 1383 (gnus-treat-strip-cr gnus-article-remove-cr) |
1010 (gnus-treat-emphasize gnus-article-emphasize) | 1384 (gnus-treat-unsplit-urls gnus-article-unsplit-urls) |
1011 (gnus-treat-display-xface gnus-article-display-x-face) | |
1012 (gnus-treat-hide-headers gnus-article-maybe-hide-headers) | |
1013 (gnus-treat-hide-boring-headers gnus-article-hide-boring-headers) | |
1014 (gnus-treat-hide-signature gnus-article-hide-signature) | |
1015 (gnus-treat-hide-citation gnus-article-hide-citation) | |
1016 (gnus-treat-hide-citation-maybe gnus-article-hide-citation-maybe) | |
1017 (gnus-treat-strip-list-identifiers gnus-article-hide-list-identifiers) | |
1018 (gnus-treat-strip-pgp gnus-article-hide-pgp) | |
1019 (gnus-treat-strip-pem gnus-article-hide-pem) | |
1020 (gnus-treat-highlight-headers gnus-article-highlight-headers) | |
1021 (gnus-treat-highlight-citation gnus-article-highlight-citation) | |
1022 (gnus-treat-highlight-signature gnus-article-highlight-signature) | |
1023 (gnus-treat-date-ut gnus-article-date-ut) | 1385 (gnus-treat-date-ut gnus-article-date-ut) |
1024 (gnus-treat-date-local gnus-article-date-local) | 1386 (gnus-treat-date-local gnus-article-date-local) |
1387 (gnus-treat-date-english gnus-article-date-english) | |
1025 (gnus-treat-date-lapsed gnus-article-date-lapsed) | 1388 (gnus-treat-date-lapsed gnus-article-date-lapsed) |
1026 (gnus-treat-date-original gnus-article-date-original) | 1389 (gnus-treat-date-original gnus-article-date-original) |
1027 (gnus-treat-date-user-defined gnus-article-date-user) | 1390 (gnus-treat-date-user-defined gnus-article-date-user) |
1028 (gnus-treat-date-iso8601 gnus-article-date-iso8601) | 1391 (gnus-treat-date-iso8601 gnus-article-date-iso8601) |
1392 (gnus-treat-display-x-face gnus-article-display-x-face) | |
1393 (gnus-treat-display-face gnus-article-display-face) | |
1394 (gnus-treat-hide-headers gnus-article-maybe-hide-headers) | |
1395 (gnus-treat-hide-boring-headers gnus-article-hide-boring-headers) | |
1396 (gnus-treat-hide-signature gnus-article-hide-signature) | |
1397 (gnus-treat-strip-list-identifiers gnus-article-hide-list-identifiers) | |
1398 (gnus-treat-leading-whitespace gnus-article-remove-leading-whitespace) | |
1399 (gnus-treat-strip-pem gnus-article-hide-pem) | |
1400 (gnus-treat-from-picon gnus-treat-from-picon) | |
1401 (gnus-treat-mail-picon gnus-treat-mail-picon) | |
1402 (gnus-treat-newsgroups-picon gnus-treat-newsgroups-picon) | |
1403 (gnus-treat-highlight-headers gnus-article-highlight-headers) | |
1404 (gnus-treat-highlight-signature gnus-article-highlight-signature) | |
1029 (gnus-treat-strip-trailing-blank-lines | 1405 (gnus-treat-strip-trailing-blank-lines |
1030 gnus-article-remove-trailing-blank-lines) | 1406 gnus-article-remove-trailing-blank-lines) |
1031 (gnus-treat-strip-leading-blank-lines | 1407 (gnus-treat-strip-leading-blank-lines |
1032 gnus-article-strip-leading-blank-lines) | 1408 gnus-article-strip-leading-blank-lines) |
1033 (gnus-treat-strip-multiple-blank-lines | 1409 (gnus-treat-strip-multiple-blank-lines |
1034 gnus-article-strip-multiple-blank-lines) | 1410 gnus-article-strip-multiple-blank-lines) |
1035 (gnus-treat-overstrike gnus-article-treat-overstrike) | 1411 (gnus-treat-overstrike gnus-article-treat-overstrike) |
1412 (gnus-treat-unfold-headers gnus-article-treat-unfold-headers) | |
1413 (gnus-treat-fold-headers gnus-article-treat-fold-headers) | |
1414 (gnus-treat-fold-newsgroups gnus-article-treat-fold-newsgroups) | |
1036 (gnus-treat-buttonize-head gnus-article-add-buttons-to-head) | 1415 (gnus-treat-buttonize-head gnus-article-add-buttons-to-head) |
1037 (gnus-treat-display-smileys gnus-smiley-display) | 1416 (gnus-treat-display-smileys gnus-treat-smiley) |
1038 (gnus-treat-capitalize-sentences gnus-article-capitalize-sentences) | 1417 (gnus-treat-capitalize-sentences gnus-article-capitalize-sentences) |
1039 (gnus-treat-display-picons gnus-article-display-picons) | 1418 (gnus-treat-wash-html gnus-article-wash-html) |
1419 (gnus-treat-emphasize gnus-article-emphasize) | |
1420 (gnus-treat-hide-citation gnus-article-hide-citation) | |
1421 (gnus-treat-hide-citation-maybe gnus-article-hide-citation-maybe) | |
1422 (gnus-treat-highlight-citation gnus-article-highlight-citation) | |
1423 (gnus-treat-body-boundary gnus-article-treat-body-boundary) | |
1040 (gnus-treat-play-sounds gnus-earcon-display))) | 1424 (gnus-treat-play-sounds gnus-earcon-display))) |
1041 | 1425 |
1042 (defvar gnus-article-mime-handle-alist nil) | 1426 (defvar gnus-article-mime-handle-alist nil) |
1043 (defvar article-lapsed-timer nil) | 1427 (defvar article-lapsed-timer nil) |
1044 (defvar gnus-article-current-summary nil) | 1428 (defvar gnus-article-current-summary nil) |
1045 | 1429 |
1046 (defvar gnus-article-mode-syntax-table | 1430 (defvar gnus-article-mode-syntax-table |
1047 (let ((table (copy-syntax-table text-mode-syntax-table))) | 1431 (let ((table (copy-syntax-table text-mode-syntax-table))) |
1048 (modify-syntax-entry ?- "w" table) | 1432 ;; This causes the citation match run O(2^n). |
1049 (modify-syntax-entry ?> ")" table) | 1433 ;; (modify-syntax-entry ?- "w" table) |
1050 (modify-syntax-entry ?< "(" table) | 1434 (modify-syntax-entry ?> ")<" table) |
1435 (modify-syntax-entry ?< "(>" table) | |
1436 ;; make M-. in article buffers work for `foo' strings | |
1437 (modify-syntax-entry ?' " " table) | |
1438 (modify-syntax-entry ?` " " table) | |
1051 table) | 1439 table) |
1052 "Syntax table used in article mode buffers. | 1440 "Syntax table used in article mode buffers. |
1053 Initialized from `text-mode-syntax-table.") | 1441 Initialized from `text-mode-syntax-table.") |
1054 | 1442 |
1055 (defvar gnus-save-article-buffer nil) | 1443 (defvar gnus-save-article-buffer nil) |
1060 gnus-summary-mode-line-format-alist)) | 1448 gnus-summary-mode-line-format-alist)) |
1061 | 1449 |
1062 (defvar gnus-number-of-articles-to-be-saved nil) | 1450 (defvar gnus-number-of-articles-to-be-saved nil) |
1063 | 1451 |
1064 (defvar gnus-inhibit-hiding nil) | 1452 (defvar gnus-inhibit-hiding nil) |
1453 | |
1454 ;;; Macros for dealing with the article buffer. | |
1455 | |
1456 (defmacro gnus-with-article-headers (&rest forms) | |
1457 `(save-excursion | |
1458 (set-buffer gnus-article-buffer) | |
1459 (save-restriction | |
1460 (let ((buffer-read-only nil) | |
1461 (inhibit-point-motion-hooks t) | |
1462 (case-fold-search t)) | |
1463 (article-narrow-to-head) | |
1464 ,@forms)))) | |
1465 | |
1466 (put 'gnus-with-article-headers 'lisp-indent-function 0) | |
1467 (put 'gnus-with-article-headers 'edebug-form-spec '(body)) | |
1468 | |
1469 (defmacro gnus-with-article-buffer (&rest forms) | |
1470 `(save-excursion | |
1471 (set-buffer gnus-article-buffer) | |
1472 (let ((buffer-read-only nil)) | |
1473 ,@forms))) | |
1474 | |
1475 (put 'gnus-with-article-buffer 'lisp-indent-function 0) | |
1476 (put 'gnus-with-article-buffer 'edebug-form-spec '(body)) | |
1477 | |
1478 (defun gnus-article-goto-header (header) | |
1479 "Go to HEADER, which is a regular expression." | |
1480 (re-search-forward (concat "^\\(" header "\\):") nil t)) | |
1065 | 1481 |
1066 (defsubst gnus-article-hide-text (b e props) | 1482 (defsubst gnus-article-hide-text (b e props) |
1067 "Set text PROPS on the B to E region, extending `intangible' 1 past B." | 1483 "Set text PROPS on the B to E region, extending `intangible' 1 past B." |
1068 (gnus-add-text-properties-when 'article-type nil b e props) | 1484 (gnus-add-text-properties-when 'article-type nil b e props) |
1069 (when (memq 'intangible props) | 1485 (when (memq 'intangible props) |
1078 (put-text-property (max (1- b) (point-min)) | 1494 (put-text-property (max (1- b) (point-min)) |
1079 b 'intangible nil))) | 1495 b 'intangible nil))) |
1080 | 1496 |
1081 (defun gnus-article-hide-text-type (b e type) | 1497 (defun gnus-article-hide-text-type (b e type) |
1082 "Hide text of TYPE between B and E." | 1498 "Hide text of TYPE between B and E." |
1083 (push type gnus-article-wash-types) | 1499 (gnus-add-wash-type type) |
1084 (gnus-article-hide-text | 1500 (gnus-article-hide-text |
1085 b e (cons 'article-type (cons type gnus-hidden-properties)))) | 1501 b e (cons 'article-type (cons type gnus-hidden-properties)))) |
1086 | 1502 |
1087 (defun gnus-article-unhide-text-type (b e type) | 1503 (defun gnus-article-unhide-text-type (b e type) |
1088 "Unhide text of TYPE between B and E." | 1504 "Unhide text of TYPE between B and E." |
1089 (setq gnus-article-wash-types | 1505 (gnus-delete-wash-type type) |
1090 (delq type gnus-article-wash-types)) | |
1091 (remove-text-properties | 1506 (remove-text-properties |
1092 b e (cons 'article-type (cons type gnus-hidden-properties))) | 1507 b e (cons 'article-type (cons type gnus-hidden-properties))) |
1093 (when (memq 'intangible gnus-hidden-properties) | 1508 (when (memq 'intangible gnus-hidden-properties) |
1094 (put-text-property (max (1- b) (point-min)) | 1509 (put-text-property (max (1- b) (point-min)) |
1095 b 'intangible nil))) | 1510 b 'intangible nil))) |
1125 (text-property-any (point-min) (point-max) 'article-type type)) | 1540 (text-property-any (point-min) (point-max) 'article-type type)) |
1126 | 1541 |
1127 (defsubst gnus-article-header-rank () | 1542 (defsubst gnus-article-header-rank () |
1128 "Give the rank of the string HEADER as given by `gnus-sorted-header-list'." | 1543 "Give the rank of the string HEADER as given by `gnus-sorted-header-list'." |
1129 (let ((list gnus-sorted-header-list) | 1544 (let ((list gnus-sorted-header-list) |
1130 (i 0)) | 1545 (i 1)) |
1131 (while list | 1546 (while list |
1132 (when (looking-at (car list)) | 1547 (if (looking-at (car list)) |
1133 (setq list nil)) | 1548 (setq list nil) |
1134 (setq list (cdr list)) | 1549 (setq list (cdr list)) |
1135 (incf i)) | 1550 (incf i))) |
1136 i)) | 1551 i)) |
1137 | 1552 |
1138 (defun article-hide-headers (&optional arg delete) | 1553 (defun article-hide-headers (&optional arg delete) |
1139 "Hide unwanted headers and possibly sort them as well." | 1554 "Hide unwanted headers and possibly sort them as well." |
1140 (interactive) | 1555 (interactive) |
1141 ;; This function might be inhibited. | 1556 ;; This function might be inhibited. |
1142 (unless gnus-inhibit-hiding | 1557 (unless gnus-inhibit-hiding |
1143 (save-excursion | 1558 (save-excursion |
1144 (save-restriction | 1559 (save-restriction |
1145 (let ((inhibit-read-only t) | 1560 (let ((buffer-read-only nil) |
1146 (case-fold-search t) | 1561 (case-fold-search t) |
1147 (max (1+ (length gnus-sorted-header-list))) | 1562 (max (1+ (length gnus-sorted-header-list))) |
1148 (ignored (when (not gnus-visible-headers) | 1563 (ignored (when (not gnus-visible-headers) |
1149 (cond ((stringp gnus-ignored-headers) | 1564 (cond ((stringp gnus-ignored-headers) |
1150 gnus-ignored-headers) | 1565 gnus-ignored-headers) |
1169 ;; Then treat the rest of the header lines. | 1584 ;; Then treat the rest of the header lines. |
1170 ;; Then we use the two regular expressions | 1585 ;; Then we use the two regular expressions |
1171 ;; `gnus-ignored-headers' and `gnus-visible-headers' to | 1586 ;; `gnus-ignored-headers' and `gnus-visible-headers' to |
1172 ;; select which header lines is to remain visible in the | 1587 ;; select which header lines is to remain visible in the |
1173 ;; article buffer. | 1588 ;; article buffer. |
1174 (while (re-search-forward "^[^ \t]*:" nil t) | 1589 (while (re-search-forward "^[^ \t:]*:" nil t) |
1175 (beginning-of-line) | 1590 (beginning-of-line) |
1176 ;; Mark the rank of the header. | 1591 ;; Mark the rank of the header. |
1177 (put-text-property | 1592 (put-text-property |
1178 (point) (1+ (point)) 'message-rank | 1593 (point) (1+ (point)) 'message-rank |
1179 (if (or (and visible (looking-at visible)) | 1594 (if (or (and visible (looking-at visible)) |
1184 (forward-line 1)) | 1599 (forward-line 1)) |
1185 (message-sort-headers-1) | 1600 (message-sort-headers-1) |
1186 (when (setq beg (text-property-any | 1601 (when (setq beg (text-property-any |
1187 (point-min) (point-max) 'message-rank (+ 2 max))) | 1602 (point-min) (point-max) 'message-rank (+ 2 max))) |
1188 ;; We delete the unwanted headers. | 1603 ;; We delete the unwanted headers. |
1189 (push 'headers gnus-article-wash-types) | 1604 (gnus-add-wash-type 'headers) |
1190 (add-text-properties (point-min) (+ 5 (point-min)) | 1605 (add-text-properties (point-min) (+ 5 (point-min)) |
1191 '(article-type headers dummy-invisible t)) | 1606 '(article-type headers dummy-invisible t)) |
1192 (delete-region beg (point-max)))))))) | 1607 (delete-region beg (point-max)))))))) |
1193 | 1608 |
1194 (defun article-hide-boring-headers (&optional arg) | 1609 (defun article-hide-boring-headers (&optional arg) |
1198 (interactive (gnus-article-hidden-arg)) | 1613 (interactive (gnus-article-hidden-arg)) |
1199 (when (and (not (gnus-article-check-hidden-text 'boring-headers arg)) | 1614 (when (and (not (gnus-article-check-hidden-text 'boring-headers arg)) |
1200 (not gnus-show-all-headers)) | 1615 (not gnus-show-all-headers)) |
1201 (save-excursion | 1616 (save-excursion |
1202 (save-restriction | 1617 (save-restriction |
1203 (let ((inhibit-read-only t) | 1618 (let ((buffer-read-only nil) |
1204 (list gnus-boring-article-headers) | 1619 (list gnus-boring-article-headers) |
1205 (inhibit-point-motion-hooks t) | 1620 (inhibit-point-motion-hooks t) |
1206 elem) | 1621 elem) |
1207 (article-narrow-to-head) | 1622 (article-narrow-to-head) |
1208 (while list | 1623 (while list |
1212 ;; Hide empty headers. | 1627 ;; Hide empty headers. |
1213 ((eq elem 'empty) | 1628 ((eq elem 'empty) |
1214 (while (re-search-forward "^[^: \t]+:[ \t]*\n[^ \t]" nil t) | 1629 (while (re-search-forward "^[^: \t]+:[ \t]*\n[^ \t]" nil t) |
1215 (forward-line -1) | 1630 (forward-line -1) |
1216 (gnus-article-hide-text-type | 1631 (gnus-article-hide-text-type |
1217 (progn (beginning-of-line) (point)) | 1632 (gnus-point-at-bol) |
1218 (progn | 1633 (progn |
1219 (end-of-line) | 1634 (end-of-line) |
1220 (if (re-search-forward "^[^ \t]" nil t) | 1635 (if (re-search-forward "^[^ \t]" nil t) |
1221 (match-beginning 0) | 1636 (match-beginning 0) |
1222 (point-max))) | 1637 (point-max))) |
1223 'boring-headers))) | 1638 'boring-headers))) |
1224 ;; Hide boring Newsgroups header. | 1639 ;; Hide boring Newsgroups header. |
1225 ((eq elem 'newsgroups) | 1640 ((eq elem 'newsgroups) |
1226 (when (equal (gnus-fetch-field "newsgroups") | 1641 (when (gnus-string-equal |
1227 (gnus-group-real-name | 1642 (gnus-fetch-field "newsgroups") |
1228 (if (boundp 'gnus-newsgroup-name) | 1643 (gnus-group-real-name |
1229 gnus-newsgroup-name | 1644 (if (boundp 'gnus-newsgroup-name) |
1230 ""))) | 1645 gnus-newsgroup-name |
1646 ""))) | |
1231 (gnus-article-hide-header "newsgroups"))) | 1647 (gnus-article-hide-header "newsgroups"))) |
1648 ((eq elem 'to-address) | |
1649 (let ((to (message-fetch-field "to")) | |
1650 (to-address | |
1651 (gnus-parameter-to-address | |
1652 (if (boundp 'gnus-newsgroup-name) | |
1653 gnus-newsgroup-name "")))) | |
1654 (when (and to to-address | |
1655 (ignore-errors | |
1656 (gnus-string-equal | |
1657 ;; only one address in To | |
1658 (nth 1 (mail-extract-address-components to)) | |
1659 to-address))) | |
1660 (gnus-article-hide-header "to")))) | |
1661 ((eq elem 'to-list) | |
1662 (let ((to (message-fetch-field "to")) | |
1663 (to-list | |
1664 (gnus-parameter-to-list | |
1665 (if (boundp 'gnus-newsgroup-name) | |
1666 gnus-newsgroup-name "")))) | |
1667 (when (and to to-list | |
1668 (ignore-errors | |
1669 (gnus-string-equal | |
1670 ;; only one address in To | |
1671 (nth 1 (mail-extract-address-components to)) | |
1672 to-list))) | |
1673 (gnus-article-hide-header "to")))) | |
1674 ((eq elem 'cc-list) | |
1675 (let ((cc (message-fetch-field "cc")) | |
1676 (to-list | |
1677 (gnus-parameter-to-list | |
1678 (if (boundp 'gnus-newsgroup-name) | |
1679 gnus-newsgroup-name "")))) | |
1680 (when (and cc to-list | |
1681 (ignore-errors | |
1682 (gnus-string-equal | |
1683 ;; only one address in CC | |
1684 (nth 1 (mail-extract-address-components cc)) | |
1685 to-list))) | |
1686 (gnus-article-hide-header "cc")))) | |
1232 ((eq elem 'followup-to) | 1687 ((eq elem 'followup-to) |
1233 (when (equal (message-fetch-field "followup-to") | 1688 (when (gnus-string-equal |
1234 (message-fetch-field "newsgroups")) | 1689 (message-fetch-field "followup-to") |
1690 (message-fetch-field "newsgroups")) | |
1235 (gnus-article-hide-header "followup-to"))) | 1691 (gnus-article-hide-header "followup-to"))) |
1236 ((eq elem 'reply-to) | 1692 ((eq elem 'reply-to) |
1237 (let ((from (message-fetch-field "from")) | 1693 (if (gnus-group-find-parameter |
1238 (reply-to (message-fetch-field "reply-to"))) | 1694 gnus-newsgroup-name 'broken-reply-to) |
1239 (when (and | 1695 (gnus-article-hide-header "reply-to") |
1696 (let ((from (message-fetch-field "from")) | |
1697 (reply-to (message-fetch-field "reply-to"))) | |
1698 (when | |
1699 (and | |
1240 from reply-to | 1700 from reply-to |
1241 (ignore-errors | 1701 (ignore-errors |
1242 (equal | 1702 (equal |
1243 (nth 1 (mail-extract-address-components from)) | 1703 (sort (mapcar |
1244 (nth 1 (mail-extract-address-components reply-to))))) | 1704 (lambda (x) (downcase (cadr x))) |
1245 (gnus-article-hide-header "reply-to")))) | 1705 (mail-extract-address-components from t)) |
1706 'string<) | |
1707 (sort (mapcar | |
1708 (lambda (x) (downcase (cadr x))) | |
1709 (mail-extract-address-components reply-to t)) | |
1710 'string<)))) | |
1711 (gnus-article-hide-header "reply-to"))))) | |
1246 ((eq elem 'date) | 1712 ((eq elem 'date) |
1247 (let ((date (message-fetch-field "date"))) | 1713 (let ((date (message-fetch-field "date"))) |
1248 (when (and date | 1714 (when (and date |
1249 (< (days-between (current-time-string) date) | 1715 (< (days-between (current-time-string) date) |
1250 4)) | 1716 4)) |
1287 (defun gnus-article-hide-header (header) | 1753 (defun gnus-article-hide-header (header) |
1288 (save-excursion | 1754 (save-excursion |
1289 (goto-char (point-min)) | 1755 (goto-char (point-min)) |
1290 (when (re-search-forward (concat "^" header ":") nil t) | 1756 (when (re-search-forward (concat "^" header ":") nil t) |
1291 (gnus-article-hide-text-type | 1757 (gnus-article-hide-text-type |
1292 (progn (beginning-of-line) (point)) | 1758 (gnus-point-at-bol) |
1293 (progn | 1759 (progn |
1294 (end-of-line) | 1760 (end-of-line) |
1295 (if (re-search-forward "^[^ \t]" nil t) | 1761 (if (re-search-forward "^[^ \t]" nil t) |
1296 (match-beginning 0) | 1762 (match-beginning 0) |
1297 (point-max))) | 1763 (point-max))) |
1301 "Length of normalized headers.") | 1767 "Length of normalized headers.") |
1302 | 1768 |
1303 (defun article-normalize-headers () | 1769 (defun article-normalize-headers () |
1304 "Make all header lines 40 characters long." | 1770 "Make all header lines 40 characters long." |
1305 (interactive) | 1771 (interactive) |
1306 (let ((inhibit-read-only t) | 1772 (let ((buffer-read-only nil) |
1307 column) | 1773 column) |
1308 (save-excursion | 1774 (save-excursion |
1309 (save-restriction | 1775 (save-restriction |
1310 (article-narrow-to-head) | 1776 (article-narrow-to-head) |
1311 (while (not (eobp)) | 1777 (while (not (eobp)) |
1327 ;; Do nothing. | 1793 ;; Do nothing. |
1328 )) | 1794 )) |
1329 (forward-line 1)))))) | 1795 (forward-line 1)))))) |
1330 | 1796 |
1331 (defun article-treat-dumbquotes () | 1797 (defun article-treat-dumbquotes () |
1332 "Translate M****s*** sm*rtq**t*s into proper text. | 1798 "Translate M****s*** sm*rtq**t*s and other symbols into proper text. |
1333 Note that this function guesses whether a character is a sm*rtq**t* or | 1799 Note that this function guesses whether a character is a sm*rtq**t* or |
1334 not, so it should only be used interactively. | 1800 not, so it should only be used interactively. |
1335 | 1801 |
1336 Sm*rtq**t*s are M****s***'s unilateral extension to the character map | 1802 Sm*rtq**t*s are M****s***'s unilateral extension to the |
1337 in an attempt to provide more quoting characters. If you see | 1803 iso-8859-1 character map in an attempt to provide more quoting |
1338 something like \\222 or \\264 where you're expecting some kind of | 1804 characters. If you see something like \\222 or \\264 where |
1339 apostrophe or quotation mark, then try this wash." | 1805 you're expecting some kind of apostrophe or quotation mark, then |
1806 try this wash." | |
1340 (interactive) | 1807 (interactive) |
1341 (article-translate-strings gnus-article-dumbquotes-map)) | 1808 (article-translate-strings gnus-article-dumbquotes-map)) |
1342 | 1809 |
1343 (defun article-translate-characters (from to) | 1810 (defun article-translate-characters (from to) |
1344 "Translate all characters in the body of the article according to FROM and TO. | 1811 "Translate all characters in the body of the article according to FROM and TO. |
1345 FROM is a string of characters to translate from; to is a string of | 1812 FROM is a string of characters to translate from; to is a string of |
1346 characters to translate to." | 1813 characters to translate to." |
1347 (save-excursion | 1814 (save-excursion |
1348 (when (article-goto-body) | 1815 (when (article-goto-body) |
1349 (let ((inhibit-read-only t) | 1816 (let ((buffer-read-only nil) |
1350 (x (make-string 225 ?x)) | 1817 (x (make-string 225 ?x)) |
1351 (i -1)) | 1818 (i -1)) |
1352 (while (< (incf i) (length x)) | 1819 (while (< (incf i) (length x)) |
1353 (aset x i i)) | 1820 (aset x i i)) |
1354 (setq i 0) | 1821 (setq i 0) |
1360 (defun article-translate-strings (map) | 1827 (defun article-translate-strings (map) |
1361 "Translate all string in the body of the article according to MAP. | 1828 "Translate all string in the body of the article according to MAP. |
1362 MAP is an alist where the elements are on the form (\"from\" \"to\")." | 1829 MAP is an alist where the elements are on the form (\"from\" \"to\")." |
1363 (save-excursion | 1830 (save-excursion |
1364 (when (article-goto-body) | 1831 (when (article-goto-body) |
1365 (let ((inhibit-read-only t) | 1832 (let ((buffer-read-only nil) |
1366 elem) | 1833 elem) |
1367 (while (setq elem (pop map)) | 1834 (while (setq elem (pop map)) |
1368 (save-excursion | 1835 (save-excursion |
1369 (while (search-forward (car elem) nil t) | 1836 (while (search-forward (car elem) nil t) |
1370 (replace-match (cadr elem))))))))) | 1837 (replace-match (cadr elem))))))))) |
1372 (defun article-treat-overstrike () | 1839 (defun article-treat-overstrike () |
1373 "Translate overstrikes into bold text." | 1840 "Translate overstrikes into bold text." |
1374 (interactive) | 1841 (interactive) |
1375 (save-excursion | 1842 (save-excursion |
1376 (when (article-goto-body) | 1843 (when (article-goto-body) |
1377 (let ((inhibit-read-only t)) | 1844 (let ((buffer-read-only nil)) |
1378 (while (search-forward "\b" nil t) | 1845 (while (search-forward "\b" nil t) |
1379 (let ((next (char-after)) | 1846 (let ((next (char-after)) |
1380 (previous (char-after (- (point) 2)))) | 1847 (previous (char-after (- (point) 2)))) |
1381 ;; We do the boldification/underlining by hiding the | 1848 ;; We do the boldification/underlining by hiding the |
1382 ;; overstrikes and putting the proper text property | 1849 ;; overstrikes and putting the proper text property |
1393 ((eq previous ?_) | 1860 ((eq previous ?_) |
1394 (gnus-article-hide-text-type (- (point) 2) (point) 'overstrike) | 1861 (gnus-article-hide-text-type (- (point) 2) (point) 'overstrike) |
1395 (put-text-property | 1862 (put-text-property |
1396 (point) (1+ (point)) 'face 'underline))))))))) | 1863 (point) (1+ (point)) 'face 'underline))))))))) |
1397 | 1864 |
1865 (defun gnus-article-treat-unfold-headers () | |
1866 "Unfold folded message headers. | |
1867 Only the headers that fit into the current window width will be | |
1868 unfolded." | |
1869 (interactive) | |
1870 (gnus-with-article-headers | |
1871 (let (length) | |
1872 (while (not (eobp)) | |
1873 (save-restriction | |
1874 (mail-header-narrow-to-field) | |
1875 (let ((header (buffer-string))) | |
1876 (with-temp-buffer | |
1877 (insert header) | |
1878 (goto-char (point-min)) | |
1879 (while (re-search-forward "\n[\t ]" nil t) | |
1880 (replace-match " " t t))) | |
1881 (setq length (- (point-max) (point-min) 1))) | |
1882 (when (< length (window-width)) | |
1883 (while (re-search-forward "\n[\t ]" nil t) | |
1884 (replace-match " " t t))) | |
1885 (goto-char (point-max))))))) | |
1886 | |
1887 (defun gnus-article-treat-fold-headers () | |
1888 "Fold message headers." | |
1889 (interactive) | |
1890 (gnus-with-article-headers | |
1891 (while (not (eobp)) | |
1892 (save-restriction | |
1893 (mail-header-narrow-to-field) | |
1894 (mail-header-fold-field) | |
1895 (goto-char (point-max)))))) | |
1896 | |
1897 (defun gnus-treat-smiley () | |
1898 "Toggle display of textual emoticons (\"smileys\") as small graphical icons." | |
1899 (interactive) | |
1900 (gnus-with-article-buffer | |
1901 (if (memq 'smiley gnus-article-wash-types) | |
1902 (gnus-delete-images 'smiley) | |
1903 (article-goto-body) | |
1904 (let ((images (smiley-region (point) (point-max)))) | |
1905 (when images | |
1906 (gnus-add-wash-type 'smiley) | |
1907 (dolist (image images) | |
1908 (gnus-add-image 'smiley image))))))) | |
1909 | |
1910 (defun gnus-article-remove-images () | |
1911 "Remove all images from the article buffer." | |
1912 (interactive) | |
1913 (gnus-with-article-buffer | |
1914 (dolist (elem gnus-article-image-alist) | |
1915 (gnus-delete-images (car elem))))) | |
1916 | |
1917 (defun gnus-article-treat-fold-newsgroups () | |
1918 "Unfold folded message headers. | |
1919 Only the headers that fit into the current window width will be | |
1920 unfolded." | |
1921 (interactive) | |
1922 (gnus-with-article-headers | |
1923 (while (gnus-article-goto-header "newsgroups\\|followup-to") | |
1924 (save-restriction | |
1925 (mail-header-narrow-to-field) | |
1926 (while (re-search-forward ", *" nil t) | |
1927 (replace-match ", " t t)) | |
1928 (mail-header-fold-field) | |
1929 (goto-char (point-max)))))) | |
1930 | |
1931 (defun gnus-article-treat-body-boundary () | |
1932 "Place a boundary line at the end of the headers." | |
1933 (interactive) | |
1934 (when (and gnus-body-boundary-delimiter | |
1935 (> (length gnus-body-boundary-delimiter) 0)) | |
1936 (gnus-with-article-headers | |
1937 (goto-char (point-max)) | |
1938 (let ((start (point))) | |
1939 (insert "X-Boundary: ") | |
1940 (gnus-add-text-properties start (point) '(invisible t intangible t)) | |
1941 (insert (let (str) | |
1942 (while (>= (1- (window-width)) (length str)) | |
1943 (setq str (concat str gnus-body-boundary-delimiter))) | |
1944 (substring str 0 (1- (window-width)))) | |
1945 "\n") | |
1946 (gnus-put-text-property start (point) 'gnus-decoration 'header))))) | |
1947 | |
1398 (defun article-fill-long-lines () | 1948 (defun article-fill-long-lines () |
1399 "Fill lines that are wider than the window width." | 1949 "Fill lines that are wider than the window width." |
1400 (interactive) | 1950 (interactive) |
1401 (save-excursion | 1951 (save-excursion |
1402 (let ((inhibit-read-only t) | 1952 (let ((buffer-read-only nil) |
1403 (width (window-width (get-buffer-window (current-buffer))))) | 1953 (width (window-width (get-buffer-window (current-buffer))))) |
1404 (save-restriction | 1954 (save-restriction |
1405 (article-goto-body) | 1955 (article-goto-body) |
1406 (let ((adaptive-fill-mode nil)) ;Why? -sm | 1956 (let ((adaptive-fill-mode nil)) ;Why? -sm |
1407 (while (not (eobp)) | 1957 (while (not (eobp)) |
1408 (end-of-line) | 1958 (end-of-line) |
1409 (when (>= (current-column) (min fill-column width)) | 1959 (when (>= (current-column) (min fill-column width)) |
1410 (narrow-to-region (point) (gnus-point-at-bol)) | 1960 (narrow-to-region (min (1+ (point)) (point-max)) |
1411 (fill-paragraph nil) | 1961 (gnus-point-at-bol)) |
1412 (goto-char (point-max)) | 1962 (let ((goback (point-marker))) |
1963 (fill-paragraph nil) | |
1964 (goto-char (marker-position goback))) | |
1413 (widen)) | 1965 (widen)) |
1414 (forward-line 1))))))) | 1966 (forward-line 1))))))) |
1415 | 1967 |
1416 (defun article-capitalize-sentences () | 1968 (defun article-capitalize-sentences () |
1417 "Capitalize the first word in each sentence." | 1969 "Capitalize the first word in each sentence." |
1418 (interactive) | 1970 (interactive) |
1419 (save-excursion | 1971 (save-excursion |
1420 (let ((inhibit-read-only t) | 1972 (let ((buffer-read-only nil) |
1421 (paragraph-start "^[\n\^L]")) | 1973 (paragraph-start "^[\n\^L]")) |
1422 (article-goto-body) | 1974 (article-goto-body) |
1423 (while (not (eobp)) | 1975 (while (not (eobp)) |
1424 (capitalize-word 1) | 1976 (capitalize-word 1) |
1425 (forward-sentence))))) | 1977 (forward-sentence))))) |
1426 | 1978 |
1427 (defun article-remove-cr () | 1979 (defun article-remove-cr () |
1428 "Remove trailing CRs and then translate remaining CRs into LFs." | 1980 "Remove trailing CRs and then translate remaining CRs into LFs." |
1429 (interactive) | 1981 (interactive) |
1430 (save-excursion | 1982 (save-excursion |
1431 (let ((inhibit-read-only t)) | 1983 (let ((buffer-read-only nil)) |
1432 (goto-char (point-min)) | 1984 (goto-char (point-min)) |
1433 (while (re-search-forward "\r+$" nil t) | 1985 (while (re-search-forward "\r+$" nil t) |
1434 (replace-match "" t t)) | 1986 (replace-match "" t t)) |
1435 (goto-char (point-min)) | 1987 (goto-char (point-min)) |
1436 (while (search-forward "\r" nil t) | 1988 (while (search-forward "\r" nil t) |
1438 | 1990 |
1439 (defun article-remove-trailing-blank-lines () | 1991 (defun article-remove-trailing-blank-lines () |
1440 "Remove all trailing blank lines from the article." | 1992 "Remove all trailing blank lines from the article." |
1441 (interactive) | 1993 (interactive) |
1442 (save-excursion | 1994 (save-excursion |
1443 (let ((inhibit-read-only t)) | 1995 (let ((buffer-read-only nil)) |
1444 (goto-char (point-max)) | 1996 (goto-char (point-max)) |
1445 (delete-region | 1997 (delete-region |
1446 (point) | 1998 (point) |
1447 (progn | 1999 (progn |
1448 (while (and (not (bobp)) | 2000 (while (and (not (bobp)) |
1451 (point) (gnus-point-at-eol)))) | 2003 (point) (gnus-point-at-eol)))) |
1452 (forward-line -1)) | 2004 (forward-line -1)) |
1453 (forward-line 1) | 2005 (forward-line 1) |
1454 (point)))))) | 2006 (point)))))) |
1455 | 2007 |
2008 (defun article-display-face () | |
2009 "Display any Face headers in the header." | |
2010 (interactive) | |
2011 (let ((wash-face-p buffer-read-only)) | |
2012 (gnus-with-article-headers | |
2013 ;; When displaying parts, this function can be called several times on | |
2014 ;; the same article, without any intended toggle semantic (as typing `W | |
2015 ;; D d' would have). So face deletion must occur only when we come from | |
2016 ;; an interactive command, that is when the *Article* buffer is | |
2017 ;; read-only. | |
2018 (if (and wash-face-p (memq 'face gnus-article-wash-types)) | |
2019 (gnus-delete-images 'face) | |
2020 (let (face faces) | |
2021 (save-excursion | |
2022 (when (and wash-face-p | |
2023 (progn | |
2024 (goto-char (point-min)) | |
2025 (not (re-search-forward "^Face:[\t ]*" nil t))) | |
2026 (gnus-buffer-live-p gnus-original-article-buffer)) | |
2027 (set-buffer gnus-original-article-buffer)) | |
2028 (save-restriction | |
2029 (mail-narrow-to-head) | |
2030 (while (gnus-article-goto-header "Face") | |
2031 (push (mail-header-field-value) faces)))) | |
2032 (while (setq face (pop faces)) | |
2033 (let ((png (gnus-convert-face-to-png face)) | |
2034 image) | |
2035 (when png | |
2036 (setq image (gnus-create-image png 'png t)) | |
2037 (gnus-article-goto-header "from") | |
2038 (when (bobp) | |
2039 (insert "From: [no `from' set]\n") | |
2040 (forward-char -17)) | |
2041 (gnus-add-wash-type 'face) | |
2042 (gnus-add-image 'face image) | |
2043 (gnus-put-image image nil 'face)))))) | |
2044 ))) | |
2045 | |
1456 (defun article-display-x-face (&optional force) | 2046 (defun article-display-x-face (&optional force) |
1457 "Look for an X-Face header and display it if present." | 2047 "Look for an X-Face header and display it if present." |
1458 (interactive (list 'force)) | 2048 (interactive (list 'force)) |
1459 (save-excursion | 2049 (let ((wash-face-p buffer-read-only)) ;; When type `W f' |
1460 ;; Delete the old process, if any. | 2050 (gnus-with-article-headers |
1461 (when (process-status "article-x-face") | 2051 ;; Delete the old process, if any. |
1462 (delete-process "article-x-face")) | 2052 (when (process-status "article-x-face") |
1463 (let ((inhibit-point-motion-hooks t) | 2053 (delete-process "article-x-face")) |
1464 (case-fold-search t) | 2054 ;; See the comment in `article-display-face'. |
1465 from last) | 2055 (if (and wash-face-p (memq 'xface gnus-article-wash-types)) |
1466 (save-restriction | 2056 ;; We have already displayed X-Faces, so we remove them |
1467 (article-narrow-to-head) | 2057 ;; instead. |
1468 (goto-char (point-min)) | 2058 (gnus-delete-images 'xface) |
1469 (setq from (message-fetch-field "from")) | 2059 ;; Display X-Faces. |
1470 (goto-char (point-min)) | 2060 (let (x-faces from face) |
1471 (while (and gnus-article-x-face-command | 2061 (save-excursion |
1472 (not last) | 2062 (when (and wash-face-p |
1473 (or force | 2063 (progn |
1474 ;; Check whether this face is censored. | 2064 (goto-char (point-min)) |
1475 (not gnus-article-x-face-too-ugly) | 2065 (not (re-search-forward |
1476 (and gnus-article-x-face-too-ugly from | 2066 "^X-Face\\(-[0-9]+\\)?:[\t ]*" nil t))) |
1477 (not (string-match gnus-article-x-face-too-ugly | 2067 (gnus-buffer-live-p gnus-original-article-buffer)) |
1478 from)))) | 2068 ;; If type `W f', use gnus-original-article-buffer, |
1479 ;; Has to be present. | 2069 ;; otherwise use the current buffer because displaying |
1480 (re-search-forward "^X-Face: " nil t)) | 2070 ;; RFC822 parts calls this function too. |
1481 ;; This used to try to do multiple faces (`while' instead of | 2071 (set-buffer gnus-original-article-buffer)) |
1482 ;; `when' above), but (a) sending multiple EOFs to xv doesn't | 2072 (save-restriction |
1483 ;; work (b) it can crash some versions of Emacs (c) are | 2073 (mail-narrow-to-head) |
1484 ;; multiple faces really something to encourage? | 2074 (while (gnus-article-goto-header "X-Face") |
2075 (push (mail-header-field-value) x-faces)) | |
2076 (setq from (message-fetch-field "from")))) | |
2077 ;; Sending multiple EOFs to xv doesn't work, so we only do a | |
2078 ;; single external face. | |
1485 (when (stringp gnus-article-x-face-command) | 2079 (when (stringp gnus-article-x-face-command) |
1486 (setq last t)) | 2080 (setq x-faces (list (car x-faces)))) |
1487 ;; We now have the area of the buffer where the X-Face is stored. | 2081 (while (and (setq face (pop x-faces)) |
1488 (save-excursion | 2082 gnus-article-x-face-command |
1489 (let ((beg (point)) | 2083 (or force |
1490 (end (1- (re-search-forward "^\\($\\|[^ \t]\\)" nil t)))) | 2084 ;; Check whether this face is censored. |
1491 ;; We display the face. | 2085 (not gnus-article-x-face-too-ugly) |
1492 (if (symbolp gnus-article-x-face-command) | 2086 (and gnus-article-x-face-too-ugly from |
1493 ;; The command is a lisp function, so we call it. | 2087 (not (string-match gnus-article-x-face-too-ugly |
1494 (if (gnus-functionp gnus-article-x-face-command) | 2088 from))))) |
1495 (funcall gnus-article-x-face-command beg end) | 2089 ;; We display the face. |
1496 (error "%s is not a function" gnus-article-x-face-command)) | 2090 (cond ((stringp gnus-article-x-face-command) |
1497 ;; The command is a string, so we interpret the command | 2091 ;; The command is a string, so we interpret the command |
1498 ;; as a, well, command, and fork it off. | 2092 ;; as a, well, command, and fork it off. |
1499 (let ((process-connection-type nil)) | 2093 (let ((process-connection-type nil)) |
1500 (process-kill-without-query | 2094 (process-kill-without-query |
1501 (start-process | 2095 (start-process |
1502 "article-x-face" nil shell-file-name shell-command-switch | 2096 "article-x-face" nil shell-file-name |
1503 gnus-article-x-face-command)) | 2097 shell-command-switch gnus-article-x-face-command)) |
1504 (process-send-region "article-x-face" beg end) | 2098 (with-temp-buffer |
1505 (process-send-eof "article-x-face")))))))))) | 2099 (insert face) |
2100 (process-send-region "article-x-face" | |
2101 (point-min) (point-max))) | |
2102 (process-send-eof "article-x-face"))) | |
2103 ((functionp gnus-article-x-face-command) | |
2104 ;; The command is a lisp function, so we call it. | |
2105 (funcall gnus-article-x-face-command face)) | |
2106 (t | |
2107 (error "%s is not a function" | |
2108 gnus-article-x-face-command))))))))) | |
1506 | 2109 |
1507 (defun article-decode-mime-words () | 2110 (defun article-decode-mime-words () |
1508 "Decode all MIME-encoded words in the article." | 2111 "Decode all MIME-encoded words in the article." |
1509 (interactive) | 2112 (interactive) |
1510 (save-excursion | 2113 (save-excursion |
1575 buffer-read-only) | 2178 buffer-read-only) |
1576 (save-restriction | 2179 (save-restriction |
1577 (article-narrow-to-head) | 2180 (article-narrow-to-head) |
1578 (funcall gnus-decode-header-function (point-min) (point-max))))) | 2181 (funcall gnus-decode-header-function (point-min) (point-max))))) |
1579 | 2182 |
1580 (defun article-de-quoted-unreadable (&optional force) | 2183 (defun article-decode-group-name () |
2184 "Decode group names in `Newsgroups:'." | |
2185 (let ((inhibit-point-motion-hooks t) | |
2186 buffer-read-only | |
2187 (method (gnus-find-method-for-group gnus-newsgroup-name))) | |
2188 (when (and (or gnus-group-name-charset-method-alist | |
2189 gnus-group-name-charset-group-alist) | |
2190 (gnus-buffer-live-p gnus-original-article-buffer)) | |
2191 (save-restriction | |
2192 (article-narrow-to-head) | |
2193 (with-current-buffer gnus-original-article-buffer | |
2194 (goto-char (point-min))) | |
2195 (while (re-search-forward | |
2196 "^Newsgroups:\\(\\(.\\|\n[\t ]\\)*\\)\n[^\t ]" nil t) | |
2197 (replace-match (save-match-data | |
2198 (gnus-decode-newsgroups | |
2199 ;; XXX how to use data in article buffer? | |
2200 (with-current-buffer gnus-original-article-buffer | |
2201 (re-search-forward | |
2202 "^Newsgroups:\\(\\(.\\|\n[\t ]\\)*\\)\n[^\t ]" | |
2203 nil t) | |
2204 (match-string 1)) | |
2205 gnus-newsgroup-name method)) | |
2206 t t nil 1)) | |
2207 (goto-char (point-min)) | |
2208 (with-current-buffer gnus-original-article-buffer | |
2209 (goto-char (point-min))) | |
2210 (while (re-search-forward | |
2211 "^Followup-To:\\(\\(.\\|\n[\t ]\\)*\\)\n[^\t ]" nil t) | |
2212 (replace-match (save-match-data | |
2213 (gnus-decode-newsgroups | |
2214 ;; XXX how to use data in article buffer? | |
2215 (with-current-buffer gnus-original-article-buffer | |
2216 (re-search-forward | |
2217 "^Followup-To:\\(\\(.\\|\n[\t ]\\)*\\)\n[^\t ]" | |
2218 nil t) | |
2219 (match-string 1)) | |
2220 gnus-newsgroup-name method)) | |
2221 t t nil 1)))))) | |
2222 | |
2223 (autoload 'idna-to-unicode "idna") | |
2224 | |
2225 (defun article-decode-idna-rhs () | |
2226 "Decode IDNA strings in RHS in From:, To: and Cc: headers in current buffer." | |
2227 (when gnus-use-idna | |
2228 (save-restriction | |
2229 (let ((inhibit-point-motion-hooks t) | |
2230 buffer-read-only) | |
2231 (article-narrow-to-head) | |
2232 (goto-char (point-min)) | |
2233 (while (re-search-forward "\\(xn--[-A-Za-z0-9.]*\\)[ \t\n\r,>]" nil t) | |
2234 (let (ace unicode) | |
2235 (when (save-match-data | |
2236 (and (setq ace (match-string 1)) | |
2237 (save-excursion | |
2238 (and (re-search-backward "^[^ \t]" nil t) | |
2239 (looking-at "From\\|To\\|Cc"))) | |
2240 (save-excursion (backward-char) | |
2241 (message-idna-inside-rhs-p)) | |
2242 (setq unicode (idna-to-unicode ace)))) | |
2243 (unless (string= ace unicode) | |
2244 (replace-match unicode nil nil nil 1))))))))) | |
2245 | |
2246 (defun article-de-quoted-unreadable (&optional force read-charset) | |
1581 "Translate a quoted-printable-encoded article. | 2247 "Translate a quoted-printable-encoded article. |
1582 If FORCE, decode the article whether it is marked as quoted-printable | 2248 If FORCE, decode the article whether it is marked as quoted-printable |
1583 or not." | 2249 or not. |
1584 (interactive (list 'force)) | 2250 If READ-CHARSET, ask for a coding system." |
2251 (interactive (list 'force current-prefix-arg)) | |
1585 (save-excursion | 2252 (save-excursion |
1586 (let ((inhibit-read-only t) type charset) | 2253 (let ((buffer-read-only nil) type charset) |
1587 (if (gnus-buffer-live-p gnus-original-article-buffer) | 2254 (if (gnus-buffer-live-p gnus-original-article-buffer) |
1588 (with-current-buffer gnus-original-article-buffer | 2255 (with-current-buffer gnus-original-article-buffer |
1589 (setq type | 2256 (setq type |
1590 (gnus-fetch-field "content-transfer-encoding")) | 2257 (gnus-fetch-field "content-transfer-encoding")) |
1591 (let* ((ct (gnus-fetch-field "content-type")) | 2258 (let* ((ct (gnus-fetch-field "content-type")) |
1594 (mail-header-parse-content-type ct))))) | 2261 (mail-header-parse-content-type ct))))) |
1595 (setq charset (and ctl | 2262 (setq charset (and ctl |
1596 (mail-content-type-get ctl 'charset))) | 2263 (mail-content-type-get ctl 'charset))) |
1597 (if (stringp charset) | 2264 (if (stringp charset) |
1598 (setq charset (intern (downcase charset))))))) | 2265 (setq charset (intern (downcase charset))))))) |
2266 (if read-charset | |
2267 (setq charset (mm-read-coding-system "Charset: " charset))) | |
1599 (unless charset | 2268 (unless charset |
1600 (setq charset gnus-newsgroup-charset)) | 2269 (setq charset gnus-newsgroup-charset)) |
1601 (when (or force | 2270 (when (or force |
1602 (and type (let ((case-fold-search t)) | 2271 (and type (let ((case-fold-search t)) |
1603 (string-match "quoted-printable" type)))) | 2272 (string-match "quoted-printable" type)))) |
1604 (article-goto-body) | 2273 (article-goto-body) |
1605 (quoted-printable-decode-region | 2274 (quoted-printable-decode-region |
1606 (point) (point-max) (mm-charset-to-coding-system charset)))))) | 2275 (point) (point-max) (mm-charset-to-coding-system charset)))))) |
1607 | 2276 |
1608 (defun article-de-base64-unreadable (&optional force) | 2277 (defun article-de-base64-unreadable (&optional force read-charset) |
1609 "Translate a base64 article. | 2278 "Translate a base64 article. |
1610 If FORCE, decode the article whether it is marked as base64 not." | 2279 If FORCE, decode the article whether it is marked as base64 not. |
1611 (interactive (list 'force)) | 2280 If READ-CHARSET, ask for a coding system." |
2281 (interactive (list 'force current-prefix-arg)) | |
1612 (save-excursion | 2282 (save-excursion |
1613 (let ((inhibit-read-only t) type charset) | 2283 (let ((buffer-read-only nil) type charset) |
1614 (if (gnus-buffer-live-p gnus-original-article-buffer) | 2284 (if (gnus-buffer-live-p gnus-original-article-buffer) |
1615 (with-current-buffer gnus-original-article-buffer | 2285 (with-current-buffer gnus-original-article-buffer |
1616 (setq type | 2286 (setq type |
1617 (gnus-fetch-field "content-transfer-encoding")) | 2287 (gnus-fetch-field "content-transfer-encoding")) |
1618 (let* ((ct (gnus-fetch-field "content-type")) | 2288 (let* ((ct (gnus-fetch-field "content-type")) |
1621 (mail-header-parse-content-type ct))))) | 2291 (mail-header-parse-content-type ct))))) |
1622 (setq charset (and ctl | 2292 (setq charset (and ctl |
1623 (mail-content-type-get ctl 'charset))) | 2293 (mail-content-type-get ctl 'charset))) |
1624 (if (stringp charset) | 2294 (if (stringp charset) |
1625 (setq charset (intern (downcase charset))))))) | 2295 (setq charset (intern (downcase charset))))))) |
2296 (if read-charset | |
2297 (setq charset (mm-read-coding-system "Charset: " charset))) | |
1626 (unless charset | 2298 (unless charset |
1627 (setq charset gnus-newsgroup-charset)) | 2299 (setq charset gnus-newsgroup-charset)) |
1628 (when (or force | 2300 (when (or force |
1629 (and type (let ((case-fold-search t)) | 2301 (and type (let ((case-fold-search t)) |
1630 (string-match "base64" type)))) | 2302 (string-match "base64" type)))) |
1641 (defun article-decode-HZ () | 2313 (defun article-decode-HZ () |
1642 "Translate a HZ-encoded article." | 2314 "Translate a HZ-encoded article." |
1643 (interactive) | 2315 (interactive) |
1644 (require 'rfc1843) | 2316 (require 'rfc1843) |
1645 (save-excursion | 2317 (save-excursion |
1646 (let ((inhibit-read-only t)) | 2318 (let ((buffer-read-only nil)) |
1647 (rfc1843-decode-region (point-min) (point-max))))) | 2319 (rfc1843-decode-region (point-min) (point-max))))) |
1648 | 2320 |
1649 (defun article-wash-html () | 2321 (defun article-unsplit-urls () |
1650 "Format an html article." | 2322 "Remove the newlines that some other mailers insert into URLs." |
1651 (interactive) | 2323 (interactive) |
1652 (save-excursion | 2324 (save-excursion |
1653 (let ((inhibit-read-only t) | 2325 (let ((buffer-read-only nil)) |
2326 (goto-char (point-min)) | |
2327 (while (re-search-forward | |
2328 "^\\(\\(https?\\|ftp\\)://\\S-+\\) *\n\\(\\S-+\\)" nil t) | |
2329 (replace-match "\\1\\3" t))) | |
2330 (when (interactive-p) | |
2331 (gnus-treat-article nil)))) | |
2332 | |
2333 | |
2334 (defun article-wash-html (&optional read-charset) | |
2335 "Format an HTML article. | |
2336 If READ-CHARSET, ask for a coding system." | |
2337 (interactive "P") | |
2338 (save-excursion | |
2339 (let ((buffer-read-only nil) | |
1654 charset) | 2340 charset) |
1655 (if (gnus-buffer-live-p gnus-original-article-buffer) | 2341 (when (gnus-buffer-live-p gnus-original-article-buffer) |
1656 (with-current-buffer gnus-original-article-buffer | 2342 (with-current-buffer gnus-original-article-buffer |
1657 (let* ((ct (gnus-fetch-field "content-type")) | 2343 (let* ((ct (gnus-fetch-field "content-type")) |
1658 (ctl (and ct | 2344 (ctl (and ct |
1659 (ignore-errors | 2345 (ignore-errors |
1660 (mail-header-parse-content-type ct))))) | 2346 (mail-header-parse-content-type ct))))) |
1661 (setq charset (and ctl | 2347 (setq charset (and ctl |
1662 (mail-content-type-get ctl 'charset))) | 2348 (mail-content-type-get ctl 'charset))) |
1663 (if (stringp charset) | 2349 (when (stringp charset) |
1664 (setq charset (intern (downcase charset))))))) | 2350 (setq charset (intern (downcase charset))))))) |
2351 (when read-charset | |
2352 (setq charset (mm-read-coding-system "Charset: " charset))) | |
1665 (unless charset | 2353 (unless charset |
1666 (setq charset gnus-newsgroup-charset)) | 2354 (setq charset gnus-newsgroup-charset)) |
1667 (article-goto-body) | 2355 (article-goto-body) |
1668 (save-window-excursion | 2356 (save-window-excursion |
1669 (save-restriction | 2357 (save-restriction |
1670 (narrow-to-region (point) (point-max)) | 2358 (narrow-to-region (point) (point-max)) |
1671 (mm-setup-w3) | 2359 (let* ((func (or gnus-article-wash-function mm-text-html-renderer)) |
1672 (let ((w3-strict-width (window-width)) | 2360 (entry (assq func mm-text-html-washer-alist))) |
1673 (url-gateway-unplugged t) | 2361 (when entry |
1674 (url-standalone-mode t)) | 2362 (setq func (cdr entry))) |
1675 (condition-case var | 2363 (cond |
1676 (w3-region (point-min) (point-max)) | 2364 ((functionp func) |
1677 (error)))))))) | 2365 (funcall func)) |
2366 (t | |
2367 (apply (car func) (cdr func)))))))))) | |
2368 | |
2369 (defun gnus-article-wash-html-with-w3 () | |
2370 "Wash the current buffer with w3." | |
2371 (mm-setup-w3) | |
2372 (let ((w3-strict-width (window-width)) | |
2373 (url-standalone-mode t) | |
2374 (url-gateway-unplugged t) | |
2375 (w3-honor-stylesheets nil)) | |
2376 (condition-case () | |
2377 (w3-region (point-min) (point-max)) | |
2378 (error)))) | |
2379 | |
2380 (defun gnus-article-wash-html-with-w3m () | |
2381 "Wash the current buffer with emacs-w3m." | |
2382 (mm-setup-w3m) | |
2383 (save-restriction | |
2384 (narrow-to-region (point) (point-max)) | |
2385 (let ((w3m-safe-url-regexp (if mm-inline-text-html-with-images | |
2386 nil | |
2387 "\\`cid:")) | |
2388 w3m-force-redisplay) | |
2389 (w3m-region (point-min) (point-max))) | |
2390 (when mm-inline-text-html-with-w3m-keymap | |
2391 (add-text-properties | |
2392 (point-min) (point-max) | |
2393 (nconc (mm-w3m-local-map-property) | |
2394 '(mm-inline-text-html-with-w3m t)))))) | |
1678 | 2395 |
1679 (defun article-hide-list-identifiers () | 2396 (defun article-hide-list-identifiers () |
1680 "Remove list identifies from the Subject header. | 2397 "Remove list identifies from the Subject header. |
1681 The `gnus-list-identifiers' variable specifies what to do." | 2398 The `gnus-list-identifiers' variable specifies what to do." |
1682 (interactive) | 2399 (interactive) |
1683 (save-excursion | 2400 (let ((inhibit-point-motion-hooks t) |
1684 (save-restriction | 2401 (regexp (if (consp gnus-list-identifiers) |
1685 (let ((inhibit-point-motion-hooks t) | 2402 (mapconcat 'identity gnus-list-identifiers " *\\|") |
1686 buffer-read-only) | 2403 gnus-list-identifiers)) |
1687 (article-narrow-to-head) | 2404 buffer-read-only) |
1688 (let ((regexp (if (stringp gnus-list-identifiers) gnus-list-identifiers | 2405 (when regexp |
1689 (mapconcat 'identity gnus-list-identifiers " *\\|")))) | 2406 (save-excursion |
1690 (when regexp | 2407 (save-restriction |
1691 (goto-char (point-min)) | 2408 (article-narrow-to-head) |
1692 (when (re-search-forward | 2409 (goto-char (point-min)) |
1693 (concat "^Subject: +\\(\\(\\(Re: +\\)?\\(" regexp | 2410 (while (re-search-forward |
1694 " *\\)\\)+\\(Re: +\\)?\\)") | 2411 (concat "^Subject: +\\(R[Ee]: +\\)*\\(" regexp " *\\)") |
1695 nil t) | 2412 nil t) |
1696 (let ((s (or (match-string 3) (match-string 5)))) | 2413 (delete-region (match-beginning 2) (match-end 0)) |
1697 (delete-region (match-beginning 1) (match-end 1)) | 2414 (beginning-of-line)) |
1698 (when s | 2415 (when (re-search-forward |
1699 (goto-char (match-beginning 1)) | 2416 "^Subject: +\\(\\(R[Ee]: +\\)+\\)R[Ee]: +" nil t) |
1700 (insert s)))))))))) | 2417 (delete-region (match-beginning 1) (match-end 1)))))))) |
1701 | |
1702 (defun article-hide-pgp () | |
1703 "Remove any PGP headers and signatures in the current article." | |
1704 (interactive) | |
1705 (save-excursion | |
1706 (save-restriction | |
1707 (let ((inhibit-point-motion-hooks t) | |
1708 buffer-read-only beg end) | |
1709 (article-goto-body) | |
1710 ;; Hide the "header". | |
1711 (when (re-search-forward "^-----BEGIN PGP SIGNED MESSAGE-----\n" nil t) | |
1712 (push 'pgp gnus-article-wash-types) | |
1713 (delete-region (match-beginning 0) (match-end 0)) | |
1714 ;; Remove armor headers (rfc2440 6.2) | |
1715 (delete-region (point) (or (re-search-forward "^[ \t]*\n" nil t) | |
1716 (point))) | |
1717 (setq beg (point)) | |
1718 ;; Hide the actual signature. | |
1719 (and (search-forward "\n-----BEGIN PGP SIGNATURE-----\n" nil t) | |
1720 (setq end (1+ (match-beginning 0))) | |
1721 (delete-region | |
1722 end | |
1723 (if (search-forward "\n-----END PGP SIGNATURE-----\n" nil t) | |
1724 (match-end 0) | |
1725 ;; Perhaps we shouldn't hide to the end of the buffer | |
1726 ;; if there is no end to the signature? | |
1727 (point-max)))) | |
1728 ;; Hide "- " PGP quotation markers. | |
1729 (when (and beg end) | |
1730 (narrow-to-region beg end) | |
1731 (goto-char (point-min)) | |
1732 (while (re-search-forward "^- " nil t) | |
1733 (delete-region | |
1734 (match-beginning 0) (match-end 0))) | |
1735 (widen)) | |
1736 (gnus-run-hooks 'gnus-article-hide-pgp-hook)))))) | |
1737 | 2418 |
1738 (defun article-hide-pem (&optional arg) | 2419 (defun article-hide-pem (&optional arg) |
1739 "Toggle hiding of any PEM headers and signatures in the current article. | 2420 "Toggle hiding of any PEM headers and signatures in the current article. |
1740 If given a negative prefix, always show; if given a positive prefix, | 2421 If given a negative prefix, always show; if given a positive prefix, |
1741 always hide." | 2422 always hide." |
1747 ;; Hide the horrendously ugly "header". | 2428 ;; Hide the horrendously ugly "header". |
1748 (when (and (search-forward | 2429 (when (and (search-forward |
1749 "\n-----BEGIN PRIVACY-ENHANCED MESSAGE-----\n" | 2430 "\n-----BEGIN PRIVACY-ENHANCED MESSAGE-----\n" |
1750 nil t) | 2431 nil t) |
1751 (setq end (1+ (match-beginning 0)))) | 2432 (setq end (1+ (match-beginning 0)))) |
1752 (push 'pem gnus-article-wash-types) | 2433 (gnus-add-wash-type 'pem) |
1753 (gnus-article-hide-text-type | 2434 (gnus-article-hide-text-type |
1754 end | 2435 end |
1755 (if (search-forward "\n\n" nil t) | 2436 (if (search-forward "\n\n" nil t) |
1756 (match-end 0) | 2437 (match-end 0) |
1757 (point-max)) | 2438 (point-max)) |
1761 nil t) | 2442 nil t) |
1762 (gnus-article-hide-text-type | 2443 (gnus-article-hide-text-type |
1763 (match-beginning 0) (match-end 0) 'pem))))))) | 2444 (match-beginning 0) (match-end 0) 'pem))))))) |
1764 | 2445 |
1765 (defun article-strip-banner () | 2446 (defun article-strip-banner () |
1766 "Strip the banner specified by the `banner' group parameter." | 2447 "Strip the banners specified by the `banner' group parameter and by |
2448 `gnus-article-address-banner-alist'." | |
1767 (interactive) | 2449 (interactive) |
1768 (save-excursion | 2450 (save-excursion |
1769 (save-restriction | 2451 (save-restriction |
2452 (let ((inhibit-point-motion-hooks t)) | |
2453 (when (gnus-parameter-banner gnus-newsgroup-name) | |
2454 (article-really-strip-banner | |
2455 (gnus-parameter-banner gnus-newsgroup-name))) | |
2456 (when gnus-article-address-banner-alist | |
2457 (article-really-strip-banner | |
2458 (let ((from (save-restriction | |
2459 (widen) | |
2460 (article-narrow-to-head) | |
2461 (mail-fetch-field "from")))) | |
2462 (when (and from | |
2463 (setq from | |
2464 (caar (mail-header-parse-addresses from)))) | |
2465 (catch 'found | |
2466 (dolist (pair gnus-article-address-banner-alist) | |
2467 (when (string-match (car pair) from) | |
2468 (throw 'found (cdr pair))))))))))))) | |
2469 | |
2470 (defun article-really-strip-banner (banner) | |
2471 "Strip the banner specified by the argument." | |
2472 (save-excursion | |
2473 (save-restriction | |
1770 (let ((inhibit-point-motion-hooks t) | 2474 (let ((inhibit-point-motion-hooks t) |
1771 (banner (gnus-group-find-parameter gnus-newsgroup-name 'banner)) | |
1772 (gnus-signature-limit nil) | 2475 (gnus-signature-limit nil) |
1773 buffer-read-only beg end) | 2476 buffer-read-only) |
1774 (when banner | 2477 (article-goto-body) |
1775 (article-goto-body) | 2478 (cond |
1776 (cond | 2479 ((eq banner 'signature) |
1777 ((eq banner 'signature) | 2480 (when (gnus-article-narrow-to-signature) |
1778 (when (gnus-article-narrow-to-signature) | 2481 (widen) |
1779 (widen) | 2482 (forward-line -1) |
1780 (forward-line -1) | 2483 (delete-region (point) (point-max)))) |
1781 (delete-region (point) (point-max)))) | 2484 ((symbolp banner) |
1782 ((symbolp banner) | 2485 (if (setq banner (cdr (assq banner gnus-article-banner-alist))) |
1783 (if (setq banner (cdr (assq banner gnus-article-banner-alist))) | 2486 (while (re-search-forward banner nil t) |
1784 (while (re-search-forward banner nil t) | 2487 (delete-region (match-beginning 0) (match-end 0))))) |
1785 (delete-region (match-beginning 0) (match-end 0))))) | 2488 ((stringp banner) |
1786 ((stringp banner) | 2489 (while (re-search-forward banner nil t) |
1787 (while (re-search-forward banner nil t) | 2490 (delete-region (match-beginning 0) (match-end 0))))))))) |
1788 (delete-region (match-beginning 0) (match-end 0)))))))))) | |
1789 | 2491 |
1790 (defun article-babel () | 2492 (defun article-babel () |
1791 "Translate article using an online translation service." | 2493 "Translate article using an online translation service." |
1792 (interactive) | 2494 (interactive) |
1793 (require 'babel) | 2495 (require 'babel) |
1794 (save-excursion | 2496 (save-excursion |
1795 (set-buffer gnus-article-buffer) | 2497 (set-buffer gnus-article-buffer) |
1796 (when (article-goto-body) | 2498 (when (article-goto-body) |
1797 (let* ((inhibit-read-only t) | 2499 (let* ((buffer-read-only nil) |
1798 (start (point)) | 2500 (start (point)) |
1799 (end (point-max)) | 2501 (end (point-max)) |
1800 (orig (buffer-substring start end)) | 2502 (orig (buffer-substring start end)) |
1801 (trans (babel-as-string orig))) | 2503 (trans (babel-as-string orig))) |
1802 (save-restriction | 2504 (save-restriction |
1803 (narrow-to-region start end) | 2505 (narrow-to-region start end) |
1804 (delete-region start end) | 2506 (delete-region start end) |
1805 (insert trans)))))) | 2507 (insert trans)))))) |
1806 | 2508 |
1807 (defun article-hide-signature (&optional arg) | 2509 (defun article-hide-signature (&optional arg) |
1808 "Hide the signature in the current article. | 2510 "Hide the signature in the current article. |
1809 If given a negative prefix, always show; if given a positive prefix, | 2511 If given a negative prefix, always show; if given a positive prefix, |
1810 always hide." | 2512 always hide." |
1811 (interactive (gnus-article-hidden-arg)) | 2513 (interactive (gnus-article-hidden-arg)) |
1812 (unless (gnus-article-check-hidden-text 'signature arg) | 2514 (unless (gnus-article-check-hidden-text 'signature arg) |
1813 (save-excursion | 2515 (save-excursion |
1814 (save-restriction | 2516 (save-restriction |
1815 (let ((inhibit-read-only t)) | 2517 (let ((buffer-read-only nil)) |
1816 (when (gnus-article-narrow-to-signature) | 2518 (when (gnus-article-narrow-to-signature) |
1817 (gnus-article-hide-text-type | 2519 (gnus-article-hide-text-type |
1818 (point-min) (point-max) 'signature))))))) | 2520 (point-min) (point-max) 'signature)))))) |
2521 (gnus-set-mode-line 'article)) | |
1819 | 2522 |
1820 (defun article-strip-headers-in-body () | 2523 (defun article-strip-headers-in-body () |
1821 "Strip offensive headers from bodies." | 2524 "Strip offensive headers from bodies." |
1822 (interactive) | 2525 (interactive) |
1823 (save-excursion | 2526 (save-excursion |
1873 (unless (gnus-annotation-in-region-p | 2576 (unless (gnus-annotation-in-region-p |
1874 (match-beginning 0) (match-end 0)) | 2577 (match-beginning 0) (match-end 0)) |
1875 (replace-match "" nil t))) | 2578 (replace-match "" nil t))) |
1876 ;; Then replace multiple empty lines with a single empty line. | 2579 ;; Then replace multiple empty lines with a single empty line. |
1877 (article-goto-body) | 2580 (article-goto-body) |
1878 (while (re-search-forward "\n\n\n+" nil t) | 2581 (while (re-search-forward "\n\n\\(\n+\\)" nil t) |
1879 (unless (gnus-annotation-in-region-p | 2582 (unless (gnus-annotation-in-region-p |
1880 (match-beginning 0) (match-end 0)) | 2583 (match-beginning 0) (match-end 0)) |
1881 (replace-match "\n\n" t t)))))) | 2584 (delete-region (match-beginning 1) (match-end 1))))))) |
1882 | 2585 |
1883 (defun article-strip-leading-space () | 2586 (defun article-strip-leading-space () |
1884 "Remove all white space from the beginning of the lines in the article." | 2587 "Remove all white space from the beginning of the lines in the article." |
1885 (interactive) | 2588 (interactive) |
1886 (save-excursion | 2589 (save-excursion |
1930 (while (setq limit (pop limits)) | 2633 (while (setq limit (pop limits)) |
1931 (if (or (and (integerp limit) | 2634 (if (or (and (integerp limit) |
1932 (< (- (point-max) (point)) limit)) | 2635 (< (- (point-max) (point)) limit)) |
1933 (and (floatp limit) | 2636 (and (floatp limit) |
1934 (< (count-lines (point) (point-max)) limit)) | 2637 (< (count-lines (point) (point-max)) limit)) |
1935 (and (gnus-functionp limit) | 2638 (and (functionp limit) |
1936 (funcall limit)) | 2639 (funcall limit)) |
1937 (and (stringp limit) | 2640 (and (stringp limit) |
1938 (not (re-search-forward limit nil t)))) | 2641 (not (re-search-forward limit nil t)))) |
1939 () ; This limit did not succeed. | 2642 () ; This limit did not succeed. |
1940 (setq limited t | 2643 (setq limited t |
1999 nil))) | 2702 nil))) |
2000 | 2703 |
2001 (defun gnus-article-show-hidden-text (type &optional dummy) | 2704 (defun gnus-article-show-hidden-text (type &optional dummy) |
2002 "Show all hidden text of type TYPE. | 2705 "Show all hidden text of type TYPE. |
2003 Originally it is hide instead of DUMMY." | 2706 Originally it is hide instead of DUMMY." |
2004 (let ((inhibit-read-only t) | 2707 (let ((buffer-read-only nil) |
2005 (inhibit-point-motion-hooks t)) | 2708 (inhibit-point-motion-hooks t)) |
2006 (gnus-remove-text-properties-when | 2709 (gnus-remove-text-properties-when |
2007 'article-type type | 2710 'article-type type |
2008 (point-min) (point-max) | 2711 (point-min) (point-max) |
2009 (cons 'article-type (cons type | 2712 (cons 'article-type (cons type |
2010 gnus-hidden-properties))))) | 2713 gnus-hidden-properties))) |
2714 (gnus-delete-wash-type type))) | |
2011 | 2715 |
2012 (defconst article-time-units | 2716 (defconst article-time-units |
2013 `((year . ,(* 365.25 24 60 60)) | 2717 `((year . ,(* 365.25 24 60 60)) |
2014 (week . ,(* 7 24 60 60)) | 2718 (week . ,(* 7 24 60 60)) |
2015 (day . ,(* 24 60 60)) | 2719 (day . ,(* 24 60 60)) |
2016 (hour . ,(* 60 60)) | 2720 (hour . ,(* 60 60)) |
2017 (minute . 60) | 2721 (minute . 60) |
2018 (second . 1)) | 2722 (second . 1)) |
2019 "Mapping from time units to seconds.") | 2723 "Mapping from time units to seconds.") |
2724 | |
2725 (defun gnus-article-forward-header () | |
2726 "Move point to the start of the next header. | |
2727 If the current header is a continuation header, this can be several | |
2728 lines forward." | |
2729 (let ((ended nil)) | |
2730 (while (not ended) | |
2731 (forward-line 1) | |
2732 (if (looking-at "[ \t]+[^ \t]") | |
2733 (forward-line 1) | |
2734 (setq ended t))))) | |
2020 | 2735 |
2021 (defun article-date-ut (&optional type highlight header) | 2736 (defun article-date-ut (&optional type highlight header) |
2022 "Convert DATE date to universal time in the current article. | 2737 "Convert DATE date to universal time in the current article. |
2023 If TYPE is `local', convert to local time; if it is `lapsed', output | 2738 If TYPE is `local', convert to local time; if it is `lapsed', output |
2024 how much time has lapsed since DATE. For `lapsed', the value of | 2739 how much time has lapsed since DATE. For `lapsed', the value of |
2027 (interactive (list 'ut t)) | 2742 (interactive (list 'ut t)) |
2028 (let* ((header (or header | 2743 (let* ((header (or header |
2029 (message-fetch-field "date") | 2744 (message-fetch-field "date") |
2030 "")) | 2745 "")) |
2031 (tdate-regexp "^Date:[ \t]\\|^X-Sent:[ \t]") | 2746 (tdate-regexp "^Date:[ \t]\\|^X-Sent:[ \t]") |
2032 (date-regexp | 2747 (date-regexp |
2033 (cond | 2748 (cond |
2034 ((not gnus-article-date-lapsed-new-header) | 2749 ((not gnus-article-date-lapsed-new-header) |
2035 tdate-regexp) | 2750 tdate-regexp) |
2036 ((eq type 'lapsed) | 2751 ((eq type 'lapsed) |
2037 "^X-Sent:[ \t]") | 2752 "^X-Sent:[ \t]") |
2052 date) | 2767 date) |
2053 eface (get-text-property (1- (gnus-point-at-eol)) 'face)) | 2768 eface (get-text-property (1- (gnus-point-at-eol)) 'face)) |
2054 (forward-line 1)) | 2769 (forward-line 1)) |
2055 (when (and date (not (string= date ""))) | 2770 (when (and date (not (string= date ""))) |
2056 (goto-char (point-min)) | 2771 (goto-char (point-min)) |
2057 (let ((inhibit-read-only t)) | 2772 (let ((buffer-read-only nil)) |
2058 ;; Delete any old Date headers. | 2773 ;; Delete any old Date headers. |
2059 (while (re-search-forward date-regexp nil t) | 2774 (while (re-search-forward date-regexp nil t) |
2060 (if pos | 2775 (if pos |
2061 (delete-region (progn (beginning-of-line) (point)) | 2776 (delete-region (progn (beginning-of-line) (point)) |
2062 (progn (forward-line 1) (point))) | 2777 (progn (gnus-article-forward-header) |
2778 (point))) | |
2063 (delete-region (progn (beginning-of-line) (point)) | 2779 (delete-region (progn (beginning-of-line) (point)) |
2064 (progn (end-of-line) (point))) | 2780 (progn (gnus-article-forward-header) |
2781 (forward-char -1) | |
2782 (point))) | |
2065 (setq pos (point)))) | 2783 (setq pos (point)))) |
2066 (when (and (not pos) (re-search-forward tdate-regexp nil t)) | 2784 (when (and (not pos) |
2785 (re-search-forward tdate-regexp nil t)) | |
2067 (forward-line 1)) | 2786 (forward-line 1)) |
2068 (if pos (goto-char pos)) | 2787 (when pos |
2788 (goto-char pos)) | |
2069 (insert (article-make-date-line date (or type 'ut))) | 2789 (insert (article-make-date-line date (or type 'ut))) |
2070 (when (not pos) | 2790 (unless pos |
2071 (insert "\n") | 2791 (insert "\n") |
2072 (forward-line -1)) | 2792 (forward-line -1)) |
2073 ;; Do highlighting. | 2793 ;; Do highlighting. |
2074 (beginning-of-line) | 2794 (beginning-of-line) |
2075 (when (looking-at "\\([^:]+\\): *\\(.*\\)$") | 2795 (when (looking-at "\\([^:]+\\): *\\(.*\\)$") |
2080 (put-text-property (match-beginning 2) (match-end 2) | 2800 (put-text-property (match-beginning 2) (match-end 2) |
2081 'face eface)))))))) | 2801 'face eface)))))))) |
2082 | 2802 |
2083 (defun article-make-date-line (date type) | 2803 (defun article-make-date-line (date type) |
2084 "Return a DATE line of TYPE." | 2804 "Return a DATE line of TYPE." |
2085 (let ((time (condition-case () | 2805 (unless (memq type '(local ut original user iso8601 lapsed english)) |
2086 (date-to-time date) | 2806 (error "Unknown conversion type: %s" type)) |
2087 (error '(0 0))))) | 2807 (condition-case () |
2088 (cond | 2808 (let ((time (date-to-time date))) |
2089 ;; Convert to the local timezone. We have to slap a | |
2090 ;; `condition-case' round the calls to the timezone | |
2091 ;; functions since they aren't particularly resistant to | |
2092 ;; buggy dates. | |
2093 ((eq type 'local) | |
2094 (let ((tz (car (current-time-zone time)))) | |
2095 (format "Date: %s %s%02d%02d" (current-time-string time) | |
2096 (if (> tz 0) "+" "-") (/ (abs tz) 3600) | |
2097 (/ (% (abs tz) 3600) 60)))) | |
2098 ;; Convert to Universal Time. | |
2099 ((eq type 'ut) | |
2100 (concat "Date: " | |
2101 (current-time-string | |
2102 (let* ((e (parse-time-string date)) | |
2103 (tm (apply 'encode-time e)) | |
2104 (ms (car tm)) | |
2105 (ls (- (cadr tm) (car (current-time-zone time))))) | |
2106 (cond ((< ls 0) (list (1- ms) (+ ls 65536))) | |
2107 ((> ls 65535) (list (1+ ms) (- ls 65536))) | |
2108 (t (list ms ls))))) | |
2109 " UT")) | |
2110 ;; Get the original date from the article. | |
2111 ((eq type 'original) | |
2112 (concat "Date: " (if (string-match "\n+$" date) | |
2113 (substring date 0 (match-beginning 0)) | |
2114 date))) | |
2115 ;; Let the user define the format. | |
2116 ((eq type 'user) | |
2117 (if (gnus-functionp gnus-article-time-format) | |
2118 (funcall gnus-article-time-format time) | |
2119 (concat | |
2120 "Date: " | |
2121 (format-time-string gnus-article-time-format time)))) | |
2122 ;; ISO 8601. | |
2123 ((eq type 'iso8601) | |
2124 (let ((tz (car (current-time-zone time)))) | |
2125 (concat | |
2126 "Date: " | |
2127 (format-time-string "%Y%m%dT%H%M%S" time) | |
2128 (format "%s%02d%02d" | |
2129 (if (> tz 0) "+" "-") (/ (abs tz) 3600) | |
2130 (/ (% (abs tz) 3600) 60))))) | |
2131 ;; Do an X-Sent lapsed format. | |
2132 ((eq type 'lapsed) | |
2133 ;; If the date is seriously mangled, the timezone functions are | |
2134 ;; liable to bug out, so we ignore all errors. | |
2135 (let* ((now (current-time)) | |
2136 (real-time (subtract-time now time)) | |
2137 (real-sec (and real-time | |
2138 (+ (* (float (car real-time)) 65536) | |
2139 (cadr real-time)))) | |
2140 (sec (and real-time (abs real-sec))) | |
2141 num prev) | |
2142 (cond | 2809 (cond |
2143 ((null real-time) | 2810 ;; Convert to the local timezone. |
2144 "X-Sent: Unknown") | 2811 ((eq type 'local) |
2145 ((zerop sec) | 2812 (let ((tz (car (current-time-zone time)))) |
2146 "X-Sent: Now") | 2813 (format "Date: %s %s%02d%02d" (current-time-string time) |
2147 (t | 2814 (if (> tz 0) "+" "-") (/ (abs tz) 3600) |
2148 (concat | 2815 (/ (% (abs tz) 3600) 60)))) |
2149 "X-Sent: " | 2816 ;; Convert to Universal Time. |
2150 ;; This is a bit convoluted, but basically we go | 2817 ((eq type 'ut) |
2151 ;; through the time units for years, weeks, etc, | 2818 (concat "Date: " |
2152 ;; and divide things to see whether that results | 2819 (current-time-string |
2153 ;; in positive answers. | 2820 (let* ((e (parse-time-string date)) |
2154 (mapconcat | 2821 (tm (apply 'encode-time e)) |
2155 (lambda (unit) | 2822 (ms (car tm)) |
2156 (if (zerop (setq num (ffloor (/ sec (cdr unit))))) | 2823 (ls (- (cadr tm) (car (current-time-zone time))))) |
2157 ;; The (remaining) seconds are too few to | 2824 (cond ((< ls 0) (list (1- ms) (+ ls 65536))) |
2158 ;; be divided into this time unit. | 2825 ((> ls 65535) (list (1+ ms) (- ls 65536))) |
2159 "" | 2826 (t (list ms ls))))) |
2160 ;; It's big enough, so we output it. | 2827 " UT")) |
2161 (setq sec (- sec (* num (cdr unit)))) | 2828 ;; Get the original date from the article. |
2162 (prog1 | 2829 ((eq type 'original) |
2163 (concat (if prev ", " "") (int-to-string | 2830 (concat "Date: " (if (string-match "\n+$" date) |
2164 (floor num)) | 2831 (substring date 0 (match-beginning 0)) |
2165 " " (symbol-name (car unit)) | 2832 date))) |
2166 (if (> num 1) "s" "")) | 2833 ;; Let the user define the format. |
2167 (setq prev t)))) | 2834 ((eq type 'user) |
2168 article-time-units "") | 2835 (let ((format (or (condition-case nil |
2169 ;; If dates are odd, then it might appear like the | 2836 (with-current-buffer gnus-summary-buffer |
2170 ;; article was sent in the future. | 2837 gnus-article-time-format) |
2171 (if (> real-sec 0) | 2838 (error nil)) |
2172 " ago" | 2839 gnus-article-time-format))) |
2173 " in the future")))))) | 2840 (if (functionp format) |
2174 (t | 2841 (funcall format time) |
2175 (error "Unknown conversion type: %s" type))))) | 2842 (concat "Date: " (format-time-string format time))))) |
2843 ;; ISO 8601. | |
2844 ((eq type 'iso8601) | |
2845 (let ((tz (car (current-time-zone time)))) | |
2846 (concat | |
2847 "Date: " | |
2848 (format-time-string "%Y%m%dT%H%M%S" time) | |
2849 (format "%s%02d%02d" | |
2850 (if (> tz 0) "+" "-") (/ (abs tz) 3600) | |
2851 (/ (% (abs tz) 3600) 60))))) | |
2852 ;; Do an X-Sent lapsed format. | |
2853 ((eq type 'lapsed) | |
2854 ;; If the date is seriously mangled, the timezone functions are | |
2855 ;; liable to bug out, so we ignore all errors. | |
2856 (let* ((now (current-time)) | |
2857 (real-time (subtract-time now time)) | |
2858 (real-sec (and real-time | |
2859 (+ (* (float (car real-time)) 65536) | |
2860 (cadr real-time)))) | |
2861 (sec (and real-time (abs real-sec))) | |
2862 num prev) | |
2863 (cond | |
2864 ((null real-time) | |
2865 "X-Sent: Unknown") | |
2866 ((zerop sec) | |
2867 "X-Sent: Now") | |
2868 (t | |
2869 (concat | |
2870 "X-Sent: " | |
2871 ;; This is a bit convoluted, but basically we go | |
2872 ;; through the time units for years, weeks, etc, | |
2873 ;; and divide things to see whether that results | |
2874 ;; in positive answers. | |
2875 (mapconcat | |
2876 (lambda (unit) | |
2877 (if (zerop (setq num (ffloor (/ sec (cdr unit))))) | |
2878 ;; The (remaining) seconds are too few to | |
2879 ;; be divided into this time unit. | |
2880 "" | |
2881 ;; It's big enough, so we output it. | |
2882 (setq sec (- sec (* num (cdr unit)))) | |
2883 (prog1 | |
2884 (concat (if prev ", " "") (int-to-string | |
2885 (floor num)) | |
2886 " " (symbol-name (car unit)) | |
2887 (if (> num 1) "s" "")) | |
2888 (setq prev t)))) | |
2889 article-time-units "") | |
2890 ;; If dates are odd, then it might appear like the | |
2891 ;; article was sent in the future. | |
2892 (if (> real-sec 0) | |
2893 " ago" | |
2894 " in the future")))))) | |
2895 ;; Display the date in proper English | |
2896 ((eq type 'english) | |
2897 (let ((dtime (decode-time time))) | |
2898 (concat | |
2899 "Date: the " | |
2900 (number-to-string (nth 3 dtime)) | |
2901 (let ((digit (% (nth 3 dtime) 10))) | |
2902 (cond | |
2903 ((memq (nth 3 dtime) '(11 12 13)) "th") | |
2904 ((= digit 1) "st") | |
2905 ((= digit 2) "nd") | |
2906 ((= digit 3) "rd") | |
2907 (t "th"))) | |
2908 " of " | |
2909 (nth (1- (nth 4 dtime)) gnus-english-month-names) | |
2910 " " | |
2911 (number-to-string (nth 5 dtime)) | |
2912 " at " | |
2913 (format "%02d" (nth 2 dtime)) | |
2914 ":" | |
2915 (format "%02d" (nth 1 dtime))))))) | |
2916 (error | |
2917 (format "Date: %s (from Gnus)" date)))) | |
2176 | 2918 |
2177 (defun article-date-local (&optional highlight) | 2919 (defun article-date-local (&optional highlight) |
2178 "Convert the current article date to the local timezone." | 2920 "Convert the current article date to the local timezone." |
2179 (interactive (list t)) | 2921 (interactive (list t)) |
2180 (article-date-ut 'local highlight)) | 2922 (article-date-ut 'local highlight)) |
2923 | |
2924 (defun article-date-english (&optional highlight) | |
2925 "Convert the current article date to something that is proper English." | |
2926 (interactive (list t)) | |
2927 (article-date-ut 'english highlight)) | |
2181 | 2928 |
2182 (defun article-date-original (&optional highlight) | 2929 (defun article-date-original (&optional highlight) |
2183 "Convert the current article date to what it was originally. | 2930 "Convert the current article date to what it was originally. |
2184 This is only useful if you have used some other date conversion | 2931 This is only useful if you have used some other date conversion |
2185 function and want to see what the date was before converting." | 2932 function and want to see what the date was before converting." |
2198 (ignore-errors | 2945 (ignore-errors |
2199 (walk-windows | 2946 (walk-windows |
2200 (lambda (w) | 2947 (lambda (w) |
2201 (set-buffer (window-buffer w)) | 2948 (set-buffer (window-buffer w)) |
2202 (when (eq major-mode 'gnus-article-mode) | 2949 (when (eq major-mode 'gnus-article-mode) |
2203 (goto-char (point-min)) | 2950 (let ((mark (point-marker))) |
2204 (when (re-search-forward "^X-Sent:" nil t) | 2951 (goto-char (point-min)) |
2205 (article-date-lapsed t)))) | 2952 (when (re-search-forward "^X-Sent:" nil t) |
2953 (article-date-lapsed t)) | |
2954 (goto-char (marker-position mark)) | |
2955 (move-marker mark nil)))) | |
2206 nil 'visible))))) | 2956 nil 'visible))))) |
2207 | 2957 |
2208 (defun gnus-start-date-timer (&optional n) | 2958 (defun gnus-start-date-timer (&optional n) |
2209 "Start a timer to update the X-Sent header in the article buffers. | 2959 "Start a timer to update the X-Sent header in the article buffers. |
2210 The numerical prefix says how frequently (in seconds) the function | 2960 The numerical prefix says how frequently (in seconds) the function |
2232 (defun article-date-iso8601 (&optional highlight) | 2982 (defun article-date-iso8601 (&optional highlight) |
2233 "Convert the current article date to ISO8601." | 2983 "Convert the current article date to ISO8601." |
2234 (interactive (list t)) | 2984 (interactive (list t)) |
2235 (article-date-ut 'iso8601 highlight)) | 2985 (article-date-ut 'iso8601 highlight)) |
2236 | 2986 |
2237 (defun article-show-all () | 2987 ;; (defun article-show-all () |
2238 "Show all hidden text in the article buffer." | 2988 ;; "Show all hidden text in the article buffer." |
2989 ;; (interactive) | |
2990 ;; (save-excursion | |
2991 ;; (let ((buffer-read-only nil)) | |
2992 ;; (gnus-article-unhide-text (point-min) (point-max))))) | |
2993 | |
2994 (defun article-remove-leading-whitespace () | |
2995 "Remove excessive whitespace from all headers." | |
2239 (interactive) | 2996 (interactive) |
2240 (save-excursion | 2997 (save-excursion |
2241 (let ((inhibit-read-only t)) | 2998 (save-restriction |
2242 (gnus-article-unhide-text (point-min) (point-max))))) | 2999 (let ((buffer-read-only nil)) |
3000 (article-narrow-to-head) | |
3001 (goto-char (point-min)) | |
3002 (while (re-search-forward "^[^ :]+: \\([ \t]+\\)" nil t) | |
3003 (delete-region (match-beginning 1) (match-end 1))))))) | |
2243 | 3004 |
2244 (defun article-emphasize (&optional arg) | 3005 (defun article-emphasize (&optional arg) |
2245 "Emphasize text according to `gnus-emphasis-alist'." | 3006 "Emphasize text according to `gnus-emphasis-alist'." |
2246 (interactive (gnus-article-hidden-arg)) | 3007 (interactive (gnus-article-hidden-arg)) |
2247 (unless (gnus-article-check-hidden-text 'emphasis arg) | 3008 (unless (gnus-article-check-hidden-text 'emphasis arg) |
2250 (condition-case nil | 3011 (condition-case nil |
2251 (with-current-buffer gnus-summary-buffer | 3012 (with-current-buffer gnus-summary-buffer |
2252 gnus-article-emphasis-alist) | 3013 gnus-article-emphasis-alist) |
2253 (error)) | 3014 (error)) |
2254 gnus-emphasis-alist)) | 3015 gnus-emphasis-alist)) |
2255 (inhibit-read-only t) | 3016 (buffer-read-only nil) |
2256 (props (append '(article-type emphasis) | 3017 (props (append '(article-type emphasis) |
2257 gnus-hidden-properties)) | 3018 gnus-hidden-properties)) |
2258 regexp elem beg invisible visible face) | 3019 regexp elem beg invisible visible face) |
2259 (article-goto-body) | 3020 (article-goto-body) |
2260 (setq beg (point)) | 3021 (setq beg (point)) |
2263 (setq regexp (car elem) | 3024 (setq regexp (car elem) |
2264 invisible (nth 1 elem) | 3025 invisible (nth 1 elem) |
2265 visible (nth 2 elem) | 3026 visible (nth 2 elem) |
2266 face (nth 3 elem)) | 3027 face (nth 3 elem)) |
2267 (while (re-search-forward regexp nil t) | 3028 (while (re-search-forward regexp nil t) |
2268 (when (and (match-beginning visible) (match-beginning invisible)) | 3029 (when (and (match-beginning visible) (match-beginning invisible)) |
2269 (push 'emphasis gnus-article-wash-types) | 3030 (gnus-article-hide-text |
2270 (gnus-article-hide-text | 3031 (match-beginning invisible) (match-end invisible) props) |
2271 (match-beginning invisible) (match-end invisible) props) | 3032 (gnus-article-unhide-text-type |
2272 (gnus-article-unhide-text-type | 3033 (match-beginning visible) (match-end visible) 'emphasis) |
2273 (match-beginning visible) (match-end visible) 'emphasis) | 3034 (gnus-put-overlay-excluding-newlines |
2274 (gnus-put-text-property-excluding-newlines | 3035 (match-beginning visible) (match-end visible) 'face face) |
2275 (match-beginning visible) (match-end visible) 'face face) | 3036 (gnus-add-wash-type 'emphasis) |
2276 (goto-char (match-end invisible))))))))) | 3037 (goto-char (match-end invisible))))))))) |
2277 | 3038 |
2278 (defun gnus-article-setup-highlight-words (&optional highlight-words) | 3039 (defun gnus-article-setup-highlight-words (&optional highlight-words) |
2279 "Setup newsgroup emphasis alist." | 3040 "Setup newsgroup emphasis alist." |
2280 (unless gnus-article-emphasis-alist | 3041 (unless gnus-article-emphasis-alist |
2281 (let ((name (and gnus-newsgroup-name | 3042 (let ((name (and gnus-newsgroup-name |
2373 (file-name-directory default-name) | 3134 (file-name-directory default-name) |
2374 default-name)) | 3135 default-name)) |
2375 ;; A single split name was found | 3136 ;; A single split name was found |
2376 ((= 1 (length split-name)) | 3137 ((= 1 (length split-name)) |
2377 (let* ((name (expand-file-name | 3138 (let* ((name (expand-file-name |
2378 (car split-name) gnus-article-save-directory)) | 3139 (car split-name) |
3140 gnus-article-save-directory)) | |
2379 (dir (cond ((file-directory-p name) | 3141 (dir (cond ((file-directory-p name) |
2380 (file-name-as-directory name)) | 3142 (file-name-as-directory name)) |
2381 ((file-exists-p name) name) | 3143 ((file-exists-p name) name) |
2382 (t gnus-article-save-directory)))) | 3144 (t gnus-article-save-directory)))) |
2383 (read-file-name | 3145 (read-file-name |
2397 (car split-name)) | 3159 (car split-name)) |
2398 gnus-article-save-directory))) | 3160 gnus-article-save-directory))) |
2399 (car (push result file-name-history))))))) | 3161 (car (push result file-name-history))))))) |
2400 ;; Create the directory. | 3162 ;; Create the directory. |
2401 (gnus-make-directory (file-name-directory file)) | 3163 (gnus-make-directory (file-name-directory file)) |
2402 ;; If we have read a directory, we append the default file name. | 3164 ;; If we have read a directory, we append the default file name. |
2403 (when (file-directory-p file) | 3165 (when (file-directory-p file) |
2404 (setq file (expand-file-name (file-name-nondirectory default-name) | 3166 (setq file (expand-file-name (file-name-nondirectory |
3167 default-name) | |
2405 (file-name-as-directory file)))) | 3168 (file-name-as-directory file)))) |
2406 ;; Possibly translate some characters. | 3169 ;; Possibly translate some characters. |
2407 (nnheader-translate-file-chars file)))))) | 3170 (nnheader-translate-file-chars file)))))) |
2408 (gnus-make-directory (file-name-directory result)) | 3171 (gnus-make-directory (file-name-directory result)) |
2409 (set variable result))) | 3172 (set variable result))) |
2446 (gnus-eval-in-buffer-window gnus-save-article-buffer | 3209 (gnus-eval-in-buffer-window gnus-save-article-buffer |
2447 (save-excursion | 3210 (save-excursion |
2448 (save-restriction | 3211 (save-restriction |
2449 (widen) | 3212 (widen) |
2450 (if (and (file-readable-p filename) | 3213 (if (and (file-readable-p filename) |
3214 (file-regular-p filename) | |
2451 (mail-file-babyl-p filename)) | 3215 (mail-file-babyl-p filename)) |
2452 (rmail-output-to-rmail-file filename t) | 3216 (rmail-output-to-rmail-file filename t) |
2453 (gnus-output-to-mail filename))))) | 3217 (gnus-output-to-mail filename))))) |
2454 filename) | 3218 filename) |
2455 | 3219 |
2470 (delete-file filename)) | 3234 (delete-file filename)) |
2471 (gnus-output-to-file filename)))) | 3235 (gnus-output-to-file filename)))) |
2472 filename) | 3236 filename) |
2473 | 3237 |
2474 (defun gnus-summary-write-to-file (&optional filename) | 3238 (defun gnus-summary-write-to-file (&optional filename) |
2475 "Write this article to a file. | 3239 "Write this article to a file, overwriting it if the file exists. |
2476 Optional argument FILENAME specifies file name. | 3240 Optional argument FILENAME specifies file name. |
2477 The directory to save in defaults to `gnus-article-save-directory'." | 3241 The directory to save in defaults to `gnus-article-save-directory'." |
2478 (gnus-summary-save-in-file nil t)) | 3242 (gnus-summary-save-in-file nil t)) |
2479 | 3243 |
2480 (defun gnus-summary-save-body-in-file (&optional filename) | 3244 (defun gnus-summary-save-body-in-file (&optional filename) |
2519 (save-restriction | 3283 (save-restriction |
2520 (widen) | 3284 (widen) |
2521 (shell-command-on-region (point-min) (point-max) command nil))) | 3285 (shell-command-on-region (point-min) (point-max) command nil))) |
2522 (setq gnus-last-shell-command command)) | 3286 (setq gnus-last-shell-command command)) |
2523 | 3287 |
3288 (defmacro gnus-read-string (prompt &optional initial-contents history | |
3289 default-value) | |
3290 "Like `read-string' but allow for older XEmacsen that don't have the 5th arg." | |
3291 (if (and (featurep 'xemacs) | |
3292 (< emacs-minor-version 2)) | |
3293 `(read-string ,prompt ,initial-contents ,history) | |
3294 `(read-string ,prompt ,initial-contents ,history ,default-value))) | |
3295 | |
3296 (defun gnus-summary-pipe-to-muttprint (&optional command) | |
3297 "Pipe this article to muttprint." | |
3298 (setq command (gnus-read-string | |
3299 "Print using command: " gnus-summary-muttprint-program | |
3300 nil gnus-summary-muttprint-program)) | |
3301 (gnus-summary-save-in-pipe command)) | |
3302 | |
2524 ;;; Article file names when saving. | 3303 ;;; Article file names when saving. |
2525 | 3304 |
2526 (defun gnus-capitalize-newsgroup (newsgroup) | 3305 (defun gnus-capitalize-newsgroup (newsgroup) |
2527 "Capitalize NEWSGROUP name." | 3306 "Capitalize NEWSGROUP name." |
2528 (when (not (zerop (length newsgroup))) | 3307 (when (not (zerop (length newsgroup))) |
2571 ~/News/news.group. Otherwise, it is like ~/News/news/group/news." | 3350 ~/News/news.group. Otherwise, it is like ~/News/news/group/news." |
2572 (or last-file | 3351 (or last-file |
2573 (expand-file-name | 3352 (expand-file-name |
2574 (if (gnus-use-long-file-name 'not-save) | 3353 (if (gnus-use-long-file-name 'not-save) |
2575 newsgroup | 3354 newsgroup |
2576 (expand-file-name "news" (gnus-newsgroup-directory-form newsgroup))) | 3355 (file-relative-name |
3356 (expand-file-name "news" (gnus-newsgroup-directory-form newsgroup)) | |
3357 default-directory)) | |
2577 gnus-article-save-directory))) | 3358 gnus-article-save-directory))) |
3359 | |
3360 (defun gnus-sender-save-name (newsgroup headers &optional last-file) | |
3361 "Generate file name from sender." | |
3362 (let ((from (mail-header-from headers))) | |
3363 (expand-file-name | |
3364 (if (and from (string-match "\\([^ <]+\\)@" from)) | |
3365 (match-string 1 from) | |
3366 "nobody") | |
3367 gnus-article-save-directory))) | |
3368 | |
3369 (defun article-verify-x-pgp-sig () | |
3370 "Verify X-PGP-Sig." | |
3371 (interactive) | |
3372 (if (gnus-buffer-live-p gnus-original-article-buffer) | |
3373 (let ((sig (with-current-buffer gnus-original-article-buffer | |
3374 (gnus-fetch-field "X-PGP-Sig"))) | |
3375 items info headers) | |
3376 (when (and sig | |
3377 mml2015-use | |
3378 (mml2015-clear-verify-function)) | |
3379 (with-temp-buffer | |
3380 (insert-buffer-substring gnus-original-article-buffer) | |
3381 (setq items (split-string sig)) | |
3382 (message-narrow-to-head) | |
3383 (let ((inhibit-point-motion-hooks t) | |
3384 (case-fold-search t)) | |
3385 ;; Don't verify multiple headers. | |
3386 (setq headers (mapconcat (lambda (header) | |
3387 (concat header ": " | |
3388 (mail-fetch-field header) | |
3389 "\n")) | |
3390 (split-string (nth 1 items) ",") ""))) | |
3391 (delete-region (point-min) (point-max)) | |
3392 (insert "-----BEGIN PGP SIGNED MESSAGE-----\n\n") | |
3393 (insert "X-Signed-Headers: " (nth 1 items) "\n") | |
3394 (insert headers) | |
3395 (widen) | |
3396 (forward-line) | |
3397 (while (not (eobp)) | |
3398 (if (looking-at "^-") | |
3399 (insert "- ")) | |
3400 (forward-line)) | |
3401 (insert "\n-----BEGIN PGP SIGNATURE-----\n") | |
3402 (insert "Version: " (car items) "\n\n") | |
3403 (insert (mapconcat 'identity (cddr items) "\n")) | |
3404 (insert "\n-----END PGP SIGNATURE-----\n") | |
3405 (let ((mm-security-handle (list (format "multipart/signed")))) | |
3406 (mml2015-clean-buffer) | |
3407 (let ((coding-system-for-write (or gnus-newsgroup-charset | |
3408 'iso-8859-1))) | |
3409 (funcall (mml2015-clear-verify-function))) | |
3410 (setq info | |
3411 (or (mm-handle-multipart-ctl-parameter | |
3412 mm-security-handle 'gnus-details) | |
3413 (mm-handle-multipart-ctl-parameter | |
3414 mm-security-handle 'gnus-info))))) | |
3415 (when info | |
3416 (let (buffer-read-only bface eface) | |
3417 (save-restriction | |
3418 (message-narrow-to-head) | |
3419 (goto-char (point-max)) | |
3420 (forward-line -1) | |
3421 (setq bface (get-text-property (gnus-point-at-bol) 'face) | |
3422 eface (get-text-property (1- (gnus-point-at-eol)) 'face)) | |
3423 (message-remove-header "X-Gnus-PGP-Verify") | |
3424 (if (re-search-forward "^X-PGP-Sig:" nil t) | |
3425 (forward-line) | |
3426 (goto-char (point-max))) | |
3427 (narrow-to-region (point) (point)) | |
3428 (insert "X-Gnus-PGP-Verify: " info "\n") | |
3429 (goto-char (point-min)) | |
3430 (forward-line) | |
3431 (while (not (eobp)) | |
3432 (if (not (looking-at "^[ \t]")) | |
3433 (insert " ")) | |
3434 (forward-line)) | |
3435 ;; Do highlighting. | |
3436 (goto-char (point-min)) | |
3437 (when (looking-at "\\([^:]+\\): *") | |
3438 (put-text-property (match-beginning 1) (1+ (match-end 1)) | |
3439 'face bface) | |
3440 (put-text-property (match-end 0) (point-max) | |
3441 'face eface))))))))) | |
3442 | |
3443 (defun article-verify-cancel-lock () | |
3444 "Verify Cancel-Lock header." | |
3445 (interactive) | |
3446 (if (gnus-buffer-live-p gnus-original-article-buffer) | |
3447 (canlock-verify gnus-original-article-buffer))) | |
2578 | 3448 |
2579 (eval-and-compile | 3449 (eval-and-compile |
2580 (mapcar | 3450 (mapcar |
2581 (lambda (func) | 3451 (lambda (func) |
2582 (let (afunc gfunc) | 3452 (let (afunc gfunc) |
2584 (setq afunc (car func) | 3454 (setq afunc (car func) |
2585 gfunc (cdr func)) | 3455 gfunc (cdr func)) |
2586 (setq afunc func | 3456 (setq afunc func |
2587 gfunc (intern (format "gnus-%s" func)))) | 3457 gfunc (intern (format "gnus-%s" func)))) |
2588 (defalias gfunc | 3458 (defalias gfunc |
2589 (if (fboundp afunc) | 3459 (when (fboundp afunc) |
2590 `(lambda (&optional interactive &rest args) | 3460 `(lambda (&optional interactive &rest args) |
2591 ,(documentation afunc t) | 3461 ,(documentation afunc t) |
2592 (interactive (list t)) | 3462 (interactive (list t)) |
2593 (save-excursion | 3463 (save-excursion |
2594 (set-buffer gnus-article-buffer) | 3464 (set-buffer gnus-article-buffer) |
2595 (if interactive | 3465 (if interactive |
2596 (call-interactively ',afunc) | 3466 (call-interactively ',afunc) |
2597 (apply ',afunc args)))))))) | 3467 (apply ',afunc args)))))))) |
2598 '(article-hide-headers | 3468 '(article-hide-headers |
3469 article-verify-x-pgp-sig | |
3470 article-verify-cancel-lock | |
2599 article-hide-boring-headers | 3471 article-hide-boring-headers |
2600 article-treat-overstrike | 3472 article-treat-overstrike |
2601 article-fill-long-lines | 3473 article-fill-long-lines |
2602 article-capitalize-sentences | 3474 article-capitalize-sentences |
2603 article-remove-cr | 3475 article-remove-cr |
3476 article-remove-leading-whitespace | |
2604 article-display-x-face | 3477 article-display-x-face |
3478 article-display-face | |
2605 article-de-quoted-unreadable | 3479 article-de-quoted-unreadable |
2606 article-de-base64-unreadable | 3480 article-de-base64-unreadable |
2607 article-decode-HZ | 3481 article-decode-HZ |
2608 article-wash-html | 3482 article-wash-html |
3483 article-unsplit-urls | |
2609 article-hide-list-identifiers | 3484 article-hide-list-identifiers |
2610 article-hide-pgp | |
2611 article-strip-banner | 3485 article-strip-banner |
2612 article-babel | 3486 article-babel |
2613 article-hide-pem | 3487 article-hide-pem |
2614 article-hide-signature | 3488 article-hide-signature |
2615 article-strip-headers-in-body | 3489 article-strip-headers-in-body |
2619 article-strip-leading-space | 3493 article-strip-leading-space |
2620 article-strip-trailing-space | 3494 article-strip-trailing-space |
2621 article-strip-blank-lines | 3495 article-strip-blank-lines |
2622 article-strip-all-blank-lines | 3496 article-strip-all-blank-lines |
2623 article-date-local | 3497 article-date-local |
3498 article-date-english | |
2624 article-date-iso8601 | 3499 article-date-iso8601 |
2625 article-date-original | 3500 article-date-original |
2626 article-date-ut | 3501 article-date-ut |
2627 article-decode-mime-words | 3502 article-decode-mime-words |
2628 article-decode-charset | 3503 article-decode-charset |
2630 article-date-user | 3505 article-date-user |
2631 article-date-lapsed | 3506 article-date-lapsed |
2632 article-emphasize | 3507 article-emphasize |
2633 article-treat-dumbquotes | 3508 article-treat-dumbquotes |
2634 article-normalize-headers | 3509 article-normalize-headers |
2635 (article-show-all . gnus-article-show-all-headers)))) | 3510 ;; (article-show-all . gnus-article-show-all-headers) |
3511 ))) | |
2636 | 3512 |
2637 ;;; | 3513 ;;; |
2638 ;;; Gnus article mode | 3514 ;;; Gnus article mode |
2639 ;;; | 3515 ;;; |
2640 | 3516 |
2655 "e" gnus-summary-edit-article | 3531 "e" gnus-summary-edit-article |
2656 "<" beginning-of-buffer | 3532 "<" beginning-of-buffer |
2657 ">" end-of-buffer | 3533 ">" end-of-buffer |
2658 "\C-c\C-i" gnus-info-find-node | 3534 "\C-c\C-i" gnus-info-find-node |
2659 "\C-c\C-b" gnus-bug | 3535 "\C-c\C-b" gnus-bug |
3536 "R" gnus-article-reply-with-original | |
3537 "F" gnus-article-followup-with-original | |
2660 "\C-hk" gnus-article-describe-key | 3538 "\C-hk" gnus-article-describe-key |
2661 "\C-hc" gnus-article-describe-key-briefly | 3539 "\C-hc" gnus-article-describe-key-briefly |
2662 | 3540 |
2663 "\C-d" gnus-article-read-summary-keys | 3541 "\C-d" gnus-article-read-summary-keys |
2664 "\M-*" gnus-article-read-summary-keys | 3542 "\M-*" gnus-article-read-summary-keys |
2667 "\M-g" gnus-article-read-summary-keys) | 3545 "\M-g" gnus-article-read-summary-keys) |
2668 | 3546 |
2669 (substitute-key-definition | 3547 (substitute-key-definition |
2670 'undefined 'gnus-article-read-summary-keys gnus-article-mode-map) | 3548 'undefined 'gnus-article-read-summary-keys gnus-article-mode-map) |
2671 | 3549 |
2672 (defvar gnus-article-post-menu nil) | |
2673 | |
2674 (defun gnus-article-make-menu-bar () | 3550 (defun gnus-article-make-menu-bar () |
3551 (unless (boundp 'gnus-article-commands-menu) | |
3552 (gnus-summary-make-menu-bar)) | |
2675 (gnus-turn-off-edit-menu 'article) | 3553 (gnus-turn-off-edit-menu 'article) |
2676 (unless (boundp 'gnus-article-article-menu) | 3554 (unless (boundp 'gnus-article-article-menu) |
2677 (easy-menu-define | 3555 (easy-menu-define |
2678 gnus-article-article-menu gnus-article-mode-map "" | 3556 gnus-article-article-menu gnus-article-mode-map "" |
2679 '("Article" | 3557 '("Article" |
2691 ["Hide headers" gnus-article-hide-headers t] | 3569 ["Hide headers" gnus-article-hide-headers t] |
2692 ["Hide signature" gnus-article-hide-signature t] | 3570 ["Hide signature" gnus-article-hide-signature t] |
2693 ["Hide citation" gnus-article-hide-citation t] | 3571 ["Hide citation" gnus-article-hide-citation t] |
2694 ["Treat overstrike" gnus-article-treat-overstrike t] | 3572 ["Treat overstrike" gnus-article-treat-overstrike t] |
2695 ["Remove carriage return" gnus-article-remove-cr t] | 3573 ["Remove carriage return" gnus-article-remove-cr t] |
3574 ["Remove leading whitespace" gnus-article-remove-leading-whitespace t] | |
2696 ["Remove quoted-unreadable" gnus-article-de-quoted-unreadable t] | 3575 ["Remove quoted-unreadable" gnus-article-de-quoted-unreadable t] |
2697 ["Remove base64" gnus-article-de-base64-unreadable t] | 3576 ["Remove base64" gnus-article-de-base64-unreadable t] |
2698 ["Treat html" gnus-article-wash-html t] | 3577 ["Treat html" gnus-article-wash-html t] |
3578 ["Remove newlines from within URLs" gnus-article-unsplit-urls t] | |
2699 ["Decode HZ" gnus-article-decode-HZ t])) | 3579 ["Decode HZ" gnus-article-decode-HZ t])) |
2700 | 3580 |
2701 ;; Note "Commands" menu is defined in gnus-sum.el for consistency | 3581 ;; Note "Commands" menu is defined in gnus-sum.el for consistency |
2702 | 3582 |
2703 (when (boundp 'gnus-summary-post-menu) | 3583 ;; Note "Post" menu is defined in gnus-sum.el for consistency |
2704 (cond | |
2705 ((not (keymapp gnus-summary-post-menu)) | |
2706 (setq gnus-article-post-menu gnus-summary-post-menu)) | |
2707 ((not gnus-article-post-menu) | |
2708 ;; Don't share post menu. | |
2709 (setq gnus-article-post-menu | |
2710 (copy-keymap gnus-summary-post-menu)))) | |
2711 (define-key gnus-article-mode-map [menu-bar post] | |
2712 (cons "Post" gnus-article-post-menu))) | |
2713 | 3584 |
2714 (gnus-run-hooks 'gnus-article-menu-hook))) | 3585 (gnus-run-hooks 'gnus-article-menu-hook))) |
2715 | |
2716 ;; Fixme: do something for the Emacs tool bar in Article mode a la | |
2717 ;; Summary. | |
2718 | 3586 |
2719 (defun gnus-article-mode () | 3587 (defun gnus-article-mode () |
2720 "Major mode for displaying an article. | 3588 "Major mode for displaying an article. |
2721 | 3589 |
2722 All normal editing commands are switched off. | 3590 All normal editing commands are switched off. |
2736 (setq mode-name "Article") | 3604 (setq mode-name "Article") |
2737 (setq major-mode 'gnus-article-mode) | 3605 (setq major-mode 'gnus-article-mode) |
2738 (make-local-variable 'minor-mode-alist) | 3606 (make-local-variable 'minor-mode-alist) |
2739 (use-local-map gnus-article-mode-map) | 3607 (use-local-map gnus-article-mode-map) |
2740 (when (gnus-visual-p 'article-menu 'menu) | 3608 (when (gnus-visual-p 'article-menu 'menu) |
2741 (gnus-article-make-menu-bar)) | 3609 (gnus-article-make-menu-bar) |
3610 (when gnus-summary-tool-bar-map | |
3611 (set (make-local-variable 'tool-bar-map) gnus-summary-tool-bar-map))) | |
2742 (gnus-update-format-specifications nil 'article-mode) | 3612 (gnus-update-format-specifications nil 'article-mode) |
2743 (set (make-local-variable 'page-delimiter) gnus-page-delimiter) | 3613 (set (make-local-variable 'page-delimiter) gnus-page-delimiter) |
2744 (make-local-variable 'gnus-page-broken) | 3614 (set (make-local-variable 'gnus-page-broken) nil) |
2745 (make-local-variable 'gnus-button-marker-list) | 3615 (make-local-variable 'gnus-button-marker-list) |
2746 (make-local-variable 'gnus-article-current-summary) | 3616 (make-local-variable 'gnus-article-current-summary) |
2747 (make-local-variable 'gnus-article-mime-handles) | 3617 (make-local-variable 'gnus-article-mime-handles) |
2748 (make-local-variable 'gnus-article-decoded-p) | 3618 (make-local-variable 'gnus-article-decoded-p) |
2749 (make-local-variable 'gnus-article-mime-handle-alist) | 3619 (make-local-variable 'gnus-article-mime-handle-alist) |
2750 (make-local-variable 'gnus-article-wash-types) | 3620 (make-local-variable 'gnus-article-wash-types) |
3621 (make-local-variable 'gnus-article-image-alist) | |
3622 (make-local-variable 'gnus-article-charset) | |
3623 (make-local-variable 'gnus-article-ignored-charsets) | |
2751 (gnus-set-default-directory) | 3624 (gnus-set-default-directory) |
2752 (buffer-disable-undo) | 3625 (buffer-disable-undo) |
2753 (setq buffer-read-only t) | 3626 (setq buffer-read-only t) |
2754 (set-syntax-table gnus-article-mode-syntax-table) | 3627 (set-syntax-table gnus-article-mode-syntax-table) |
2755 (mm-enable-multibyte) | 3628 (mm-enable-multibyte) |
2781 (setq major-mode 'gnus-original-article-mode) | 3654 (setq major-mode 'gnus-original-article-mode) |
2782 (make-local-variable 'gnus-original-article)) | 3655 (make-local-variable 'gnus-original-article)) |
2783 (if (get-buffer name) | 3656 (if (get-buffer name) |
2784 (save-excursion | 3657 (save-excursion |
2785 (set-buffer name) | 3658 (set-buffer name) |
3659 (when (and gnus-article-edit-mode | |
3660 (buffer-modified-p) | |
3661 (not | |
3662 (y-or-n-p "Article mode edit in progress; discard? "))) | |
3663 (error "Action aborted")) | |
3664 (set (make-local-variable 'gnus-article-edit-mode) nil) | |
2786 (when gnus-article-mime-handles | 3665 (when gnus-article-mime-handles |
2787 (mm-destroy-parts gnus-article-mime-handles) | 3666 (mm-destroy-parts gnus-article-mime-handles) |
2788 (setq gnus-article-mime-handles nil)) | 3667 (setq gnus-article-mime-handles nil)) |
2789 ;; Set it to nil in article-buffer! | 3668 ;; Set it to nil in article-buffer! |
2790 (setq gnus-article-mime-handle-alist nil) | 3669 (setq gnus-article-mime-handle-alist nil) |
2791 (buffer-disable-undo) | 3670 (buffer-disable-undo) |
2792 (setq buffer-read-only t) | 3671 (setq buffer-read-only t) |
3672 ;; This list just keeps growing if we don't reset it. | |
3673 (setq gnus-button-marker-list nil) | |
2793 (unless (eq major-mode 'gnus-article-mode) | 3674 (unless (eq major-mode 'gnus-article-mode) |
2794 (gnus-article-mode)) | 3675 (gnus-article-mode)) |
2795 (current-buffer)) | 3676 (current-buffer)) |
2796 (save-excursion | 3677 (save-excursion |
2797 (set-buffer (gnus-get-buffer-create name)) | 3678 (set-buffer (gnus-get-buffer-create name)) |
2802 | 3683 |
2803 ;; Set article window start at LINE, where LINE is the number of lines | 3684 ;; Set article window start at LINE, where LINE is the number of lines |
2804 ;; from the head of the article. | 3685 ;; from the head of the article. |
2805 (defun gnus-article-set-window-start (&optional line) | 3686 (defun gnus-article-set-window-start (&optional line) |
2806 (set-window-start | 3687 (set-window-start |
2807 (get-buffer-window gnus-article-buffer t) | 3688 (gnus-get-buffer-window gnus-article-buffer t) |
2808 (save-excursion | 3689 (save-excursion |
2809 (set-buffer gnus-article-buffer) | 3690 (set-buffer gnus-article-buffer) |
2810 (goto-char (point-min)) | 3691 (goto-char (point-min)) |
2811 (if (not line) | 3692 (if (not line) |
2812 (point-min) | 3693 (point-min) |
2835 (set-buffer gnus-article-buffer) | 3716 (set-buffer gnus-article-buffer) |
2836 ;; Deactivate active regions. | 3717 ;; Deactivate active regions. |
2837 (when (and (boundp 'transient-mark-mode) | 3718 (when (and (boundp 'transient-mark-mode) |
2838 transient-mark-mode) | 3719 transient-mark-mode) |
2839 (setq mark-active nil)) | 3720 (setq mark-active nil)) |
2840 (if (not (setq result (let ((inhibit-read-only t)) | 3721 (if (not (setq result (let ((buffer-read-only nil)) |
2841 (gnus-request-article-this-buffer | 3722 (gnus-request-article-this-buffer |
2842 article group)))) | 3723 article group)))) |
2843 ;; There is no such article. | 3724 ;; There is no such article. |
2844 (save-excursion | 3725 (save-excursion |
2845 (when (and (numberp article) | 3726 (when (and (numberp article) |
2846 (not (memq article gnus-newsgroup-sparse))) | 3727 (not (memq article gnus-newsgroup-sparse))) |
2847 (setq gnus-article-current | 3728 (setq gnus-article-current |
2848 (cons gnus-newsgroup-name article)) | 3729 (cons gnus-newsgroup-name article)) |
2849 (set-buffer gnus-summary-buffer) | 3730 (set-buffer gnus-summary-buffer) |
2850 (setq gnus-current-article article) | 3731 (setq gnus-current-article article) |
2851 (if (eq (gnus-article-mark article) gnus-undownloaded-mark) | 3732 (if (and (memq article gnus-newsgroup-undownloaded) |
3733 (not (gnus-online (gnus-find-method-for-group | |
3734 gnus-newsgroup-name)))) | |
2852 (progn | 3735 (progn |
2853 (gnus-summary-set-agent-mark article) | 3736 (gnus-summary-set-agent-mark article) |
2854 (message "Message marked for downloading")) | 3737 (message "Message marked for downloading")) |
2855 (gnus-summary-mark-article article gnus-canceled-mark) | 3738 (gnus-summary-mark-article article gnus-canceled-mark) |
2856 (unless (memq article gnus-newsgroup-sparse) | 3739 (unless (memq article gnus-newsgroup-sparse) |
2910 (when (or (numberp article) | 3793 (when (or (numberp article) |
2911 (stringp article)) | 3794 (stringp article)) |
2912 (gnus-article-prepare-display) | 3795 (gnus-article-prepare-display) |
2913 ;; Do page break. | 3796 ;; Do page break. |
2914 (goto-char (point-min)) | 3797 (goto-char (point-min)) |
2915 (setq gnus-page-broken | 3798 (when gnus-break-pages |
2916 (when gnus-break-pages | 3799 (gnus-narrow-to-page))) |
2917 (gnus-narrow-to-page) | |
2918 t))) | |
2919 (let ((gnus-article-mime-handle-alist-1 | 3800 (let ((gnus-article-mime-handle-alist-1 |
2920 gnus-article-mime-handle-alist)) | 3801 gnus-article-mime-handle-alist)) |
2921 (gnus-set-mode-line 'article)) | 3802 (gnus-set-mode-line 'article)) |
2922 (article-goto-body) | 3803 (article-goto-body) |
3804 (unless (bobp) | |
3805 (forward-line -1)) | |
2923 (set-window-point (get-buffer-window (current-buffer)) (point)) | 3806 (set-window-point (get-buffer-window (current-buffer)) (point)) |
2924 (gnus-configure-windows 'article) | 3807 (gnus-configure-windows 'article) |
2925 t)))))) | 3808 t)))))) |
2926 | 3809 |
2927 ;;;###autoload | 3810 ;;;###autoload |
2932 (let ((gnus-article-buffer (current-buffer)) | 3815 (let ((gnus-article-buffer (current-buffer)) |
2933 buffer-read-only) | 3816 buffer-read-only) |
2934 (unless (eq major-mode 'gnus-article-mode) | 3817 (unless (eq major-mode 'gnus-article-mode) |
2935 (gnus-article-mode)) | 3818 (gnus-article-mode)) |
2936 (setq buffer-read-only nil | 3819 (setq buffer-read-only nil |
2937 gnus-article-wash-types nil) | 3820 gnus-article-wash-types nil |
3821 gnus-article-image-alist nil) | |
2938 (gnus-run-hooks 'gnus-tmp-internal-hook) | 3822 (gnus-run-hooks 'gnus-tmp-internal-hook) |
2939 (when gnus-display-mime-function | 3823 (when gnus-display-mime-function |
2940 (funcall gnus-display-mime-function)) | 3824 (funcall gnus-display-mime-function)) |
2941 (gnus-run-hooks 'gnus-article-prepare-hook))) | 3825 (gnus-run-hooks 'gnus-article-prepare-hook))) |
2942 | 3826 |
2943 ;;; | 3827 ;;; |
2944 ;;; Gnus MIME viewing functions | 3828 ;;; Gnus MIME viewing functions |
2945 ;;; | 3829 ;;; |
2946 | 3830 |
2947 (defvar gnus-mime-button-line-format "%{%([%p. %d%T]%)%}%e\n" | 3831 (defvar gnus-mime-button-line-format "%{%([%p. %d%T]%)%}%e\n" |
2948 "The following specs can be used: | 3832 "Format of the MIME buttons. |
3833 | |
3834 Valid specifiers include: | |
2949 %t The MIME type | 3835 %t The MIME type |
2950 %T MIME type, along with additional info | 3836 %T MIME type, along with additional info |
2951 %n The `name' parameter | 3837 %n The `name' parameter |
2952 %d The description, if any | 3838 %d The description, if any |
2953 %l The length of the encoded part | 3839 %l The length of the encoded part |
2954 %p The part identifier number | 3840 %p The part identifier number |
2955 %e Dots if the part isn't displayed") | 3841 %e Dots if the part isn't displayed |
3842 | |
3843 General format specifiers can also be used. See Info node | |
3844 `(gnus)Formatting Variables'.") | |
2956 | 3845 |
2957 (defvar gnus-mime-button-line-format-alist | 3846 (defvar gnus-mime-button-line-format-alist |
2958 '((?t gnus-tmp-type ?s) | 3847 '((?t gnus-tmp-type ?s) |
2959 (?T gnus-tmp-type-long ?s) | 3848 (?T gnus-tmp-type-long ?s) |
2960 (?n gnus-tmp-name ?s) | 3849 (?n gnus-tmp-name ?s) |
2965 | 3854 |
2966 (defvar gnus-mime-button-commands | 3855 (defvar gnus-mime-button-commands |
2967 '((gnus-article-press-button "\r" "Toggle Display") | 3856 '((gnus-article-press-button "\r" "Toggle Display") |
2968 (gnus-mime-view-part "v" "View Interactively...") | 3857 (gnus-mime-view-part "v" "View Interactively...") |
2969 (gnus-mime-view-part-as-type "t" "View As Type...") | 3858 (gnus-mime-view-part-as-type "t" "View As Type...") |
3859 (gnus-mime-view-part-as-charset "C" "View As charset...") | |
2970 (gnus-mime-save-part "o" "Save...") | 3860 (gnus-mime-save-part "o" "Save...") |
3861 (gnus-mime-save-part-and-strip "\C-o" "Save and Strip") | |
3862 (gnus-mime-delete-part "d" "Delete part") | |
2971 (gnus-mime-copy-part "c" "View As Text, In Other Buffer") | 3863 (gnus-mime-copy-part "c" "View As Text, In Other Buffer") |
2972 (gnus-mime-inline-part "i" "View As Text, In This Buffer") | 3864 (gnus-mime-inline-part "i" "View As Text, In This Buffer") |
2973 (gnus-mime-internalize-part "E" "View Internally") | 3865 (gnus-mime-view-part-internally "E" "View Internally") |
2974 (gnus-mime-externalize-part "e" "View Externally") | 3866 (gnus-mime-view-part-externally "e" "View Externally") |
3867 (gnus-mime-print-part "p" "Print") | |
2975 (gnus-mime-pipe-part "|" "Pipe To Command...") | 3868 (gnus-mime-pipe-part "|" "Pipe To Command...") |
2976 (gnus-mime-action-on-part "." "Take action on the part"))) | 3869 (gnus-mime-action-on-part "." "Take action on the part..."))) |
2977 | 3870 |
2978 (defun gnus-article-mime-part-status () | 3871 (defun gnus-article-mime-part-status () |
2979 (if gnus-article-mime-handle-alist-1 | 3872 (if gnus-article-mime-handle-alist-1 |
2980 (format " (%d parts)" (length gnus-article-mime-handle-alist-1)) | 3873 (if (eq 1 (length gnus-article-mime-handle-alist-1)) |
3874 " (1 part)" | |
3875 (format " (%d parts)" (length gnus-article-mime-handle-alist-1))) | |
2981 "")) | 3876 "")) |
2982 | 3877 |
2983 (defvar gnus-mime-button-map | 3878 (defvar gnus-mime-button-map |
2984 (let ((map (make-sparse-keymap))) | 3879 (let ((map (make-sparse-keymap))) |
2985 ;; Not for Emacs 21: fixme better. | 3880 (unless (>= (string-to-number emacs-version) 21) |
2986 ;; (set-keymap-parent map gnus-article-mode-map) | 3881 ;; XEmacs doesn't care. |
3882 (set-keymap-parent map gnus-article-mode-map)) | |
2987 (define-key map gnus-mouse-2 'gnus-article-push-button) | 3883 (define-key map gnus-mouse-2 'gnus-article-push-button) |
2988 (define-key map gnus-down-mouse-3 'gnus-mime-button-menu) | 3884 (define-key map gnus-down-mouse-3 'gnus-mime-button-menu) |
2989 (dolist (c gnus-mime-button-commands) | 3885 (dolist (c gnus-mime-button-commands) |
2990 (define-key map (cadr c) (car c))) | 3886 (define-key map (cadr c) (car c))) |
2991 map)) | 3887 map)) |
2992 | 3888 |
2993 (defun gnus-mime-button-menu (event) | 3889 (easy-menu-define |
2994 "Construct a context-sensitive menu of MIME commands." | 3890 gnus-mime-button-menu gnus-mime-button-map "MIME button menu." |
2995 (interactive "e") | 3891 `("MIME Part" |
2996 (save-excursion | 3892 ,@(mapcar (lambda (c) |
2997 (mouse-set-point event) | 3893 (vector (caddr c) (car c) :enable t)) |
2998 (gnus-article-check-buffer) | 3894 gnus-mime-button-commands))) |
2999 (let ((response (x-popup-menu | 3895 |
3000 t `("MIME Part" | 3896 (eval-when-compile |
3001 ("" ,@(mapcar (lambda (c) | 3897 (define-compiler-macro popup-menu (&whole form |
3002 (cons (caddr c) (car c))) | 3898 menu &optional position prefix) |
3003 gnus-mime-button-commands)))))) | 3899 (if (and (fboundp 'popup-menu) |
3004 (if response | 3900 (not (memq 'popup-menu (assoc "lmenu" load-history)))) |
3005 (call-interactively response))))) | 3901 form |
3902 ;; Gnus is probably running under Emacs 20. | |
3903 `(let* ((menu (cdr ,menu)) | |
3904 (response (x-popup-menu | |
3905 t (list (car menu) | |
3906 (cons "" (mapcar (lambda (c) | |
3907 (cons (caddr c) (car c))) | |
3908 (cdr menu))))))) | |
3909 (if response | |
3910 (call-interactively (nth 3 (assq response menu)))))))) | |
3911 | |
3912 (defun gnus-mime-button-menu (event prefix) | |
3913 "Construct a context-sensitive menu of MIME commands." | |
3914 (interactive "e\nP") | |
3915 (save-window-excursion | |
3916 (let ((pos (event-start event))) | |
3917 (select-window (posn-window pos)) | |
3918 (goto-char (posn-point pos)) | |
3919 (gnus-article-check-buffer) | |
3920 (popup-menu gnus-mime-button-menu nil prefix)))) | |
3006 | 3921 |
3007 (defun gnus-mime-view-all-parts (&optional handles) | 3922 (defun gnus-mime-view-all-parts (&optional handles) |
3008 "View all the MIME parts." | 3923 "View all the MIME parts." |
3009 (interactive) | 3924 (interactive) |
3010 (save-current-buffer | 3925 (save-current-buffer |
3011 (set-buffer gnus-article-buffer) | 3926 (set-buffer gnus-article-buffer) |
3012 (let ((handles (or handles gnus-article-mime-handles)) | 3927 (let ((handles (or handles gnus-article-mime-handles)) |
3013 (mail-parse-charset gnus-newsgroup-charset) | 3928 (mail-parse-charset gnus-newsgroup-charset) |
3014 (mail-parse-ignored-charsets | 3929 (mail-parse-ignored-charsets |
3015 (save-excursion (set-buffer gnus-summary-buffer) | 3930 (with-current-buffer gnus-summary-buffer |
3016 gnus-newsgroup-ignored-charsets))) | 3931 gnus-newsgroup-ignored-charsets))) |
3017 (if (stringp (car handles)) | 3932 (when handles |
3018 (gnus-mime-view-all-parts (cdr handles)) | 3933 (mm-remove-parts handles) |
3019 (mapcar 'mm-display-part handles))))) | 3934 (goto-char (point-min)) |
3935 (or (search-forward "\n\n") (goto-char (point-max))) | |
3936 (let (buffer-read-only) | |
3937 (delete-region (point) (point-max)) | |
3938 (mm-display-parts handles)))))) | |
3939 | |
3940 (defun gnus-mime-save-part-and-strip () | |
3941 "Save the MIME part under point then replace it with an external body." | |
3942 (interactive) | |
3943 (gnus-article-check-buffer) | |
3944 (let* ((data (get-text-property (point) 'gnus-data)) | |
3945 file param | |
3946 (handles gnus-article-mime-handles)) | |
3947 (if (mm-multiple-handles gnus-article-mime-handles) | |
3948 (error "This function is not implemented")) | |
3949 (setq file (and data (mm-save-part data))) | |
3950 (when file | |
3951 (with-current-buffer (mm-handle-buffer data) | |
3952 (erase-buffer) | |
3953 (insert "Content-Type: " (mm-handle-media-type data)) | |
3954 (mml-insert-parameter-string (cdr (mm-handle-type data)) | |
3955 '(charset)) | |
3956 (insert "\n") | |
3957 (insert "Content-ID: " (message-make-message-id) "\n") | |
3958 (insert "Content-Transfer-Encoding: binary\n") | |
3959 (insert "\n")) | |
3960 (setcdr data | |
3961 (cdr (mm-make-handle nil | |
3962 `("message/external-body" | |
3963 (access-type . "LOCAL-FILE") | |
3964 (name . ,file))))) | |
3965 (set-buffer gnus-summary-buffer) | |
3966 (gnus-article-edit-article | |
3967 `(lambda () | |
3968 (erase-buffer) | |
3969 (let ((mail-parse-charset (or gnus-article-charset | |
3970 ',gnus-newsgroup-charset)) | |
3971 (mail-parse-ignored-charsets | |
3972 (or gnus-article-ignored-charsets | |
3973 ',gnus-newsgroup-ignored-charsets)) | |
3974 (mbl mml-buffer-list)) | |
3975 (setq mml-buffer-list nil) | |
3976 (insert-buffer gnus-original-article-buffer) | |
3977 (mime-to-mml ',handles) | |
3978 (setq gnus-article-mime-handles nil) | |
3979 (let ((mbl1 mml-buffer-list)) | |
3980 (setq mml-buffer-list mbl) | |
3981 (set (make-local-variable 'mml-buffer-list) mbl1)) | |
3982 (gnus-make-local-hook 'kill-buffer-hook) | |
3983 (add-hook 'kill-buffer-hook 'mml-destroy-buffers t t))) | |
3984 `(lambda (no-highlight) | |
3985 (let ((mail-parse-charset (or gnus-article-charset | |
3986 ',gnus-newsgroup-charset)) | |
3987 (message-options message-options) | |
3988 (message-options-set-recipient) | |
3989 (mail-parse-ignored-charsets | |
3990 (or gnus-article-ignored-charsets | |
3991 ',gnus-newsgroup-ignored-charsets))) | |
3992 (mml-to-mime) | |
3993 (mml-destroy-buffers) | |
3994 (remove-hook 'kill-buffer-hook | |
3995 'mml-destroy-buffers t) | |
3996 (kill-local-variable 'mml-buffer-list)) | |
3997 (gnus-summary-edit-article-done | |
3998 ,(or (mail-header-references gnus-current-headers) "") | |
3999 ,(gnus-group-read-only-p) | |
4000 ,gnus-summary-buffer no-highlight)))))) | |
4001 | |
4002 (defun gnus-mime-delete-part () | |
4003 "Delete the MIME part under point. | |
4004 Replace it with some information about the removed part." | |
4005 (interactive) | |
4006 (gnus-article-check-buffer) | |
4007 (unless (and gnus-novice-user | |
4008 (not (gnus-yes-or-no-p | |
4009 "Really delete attachment forever? "))) | |
4010 (let* ((data (get-text-property (point) 'gnus-data)) | |
4011 (handles gnus-article-mime-handles) | |
4012 (none "(none)") | |
4013 (description | |
4014 (or | |
4015 (mail-decode-encoded-word-string (or (mm-handle-description data) | |
4016 none)))) | |
4017 (filename | |
4018 (or (mail-content-type-get (mm-handle-disposition data) 'filename) | |
4019 none)) | |
4020 (type (mm-handle-media-type data))) | |
4021 (if (mm-multiple-handles gnus-article-mime-handles) | |
4022 (error "This function is not implemented")) | |
4023 (with-current-buffer (mm-handle-buffer data) | |
4024 (let ((bsize (format "%s" (buffer-size)))) | |
4025 (erase-buffer) | |
4026 (insert | |
4027 (concat | |
4028 ",----\n" | |
4029 "| The following attachment has been deleted:\n" | |
4030 "|\n" | |
4031 "| Type: " type "\n" | |
4032 "| Filename: " filename "\n" | |
4033 "| Size (encoded): " bsize " Byte\n" | |
4034 "| Description: " description "\n" | |
4035 "`----\n")) | |
4036 (setcdr data | |
4037 (cdr (mm-make-handle | |
4038 nil `("text/plain") nil nil | |
4039 (list "attachment") | |
4040 (format "Deleted attachment (%s bytes)" bsize)))))) | |
4041 (set-buffer gnus-summary-buffer) | |
4042 ;; FIXME: maybe some of the following code (borrowed from | |
4043 ;; `gnus-mime-save-part-and-strip') isn't necessary? | |
4044 (gnus-article-edit-article | |
4045 `(lambda () | |
4046 (erase-buffer) | |
4047 (let ((mail-parse-charset (or gnus-article-charset | |
4048 ',gnus-newsgroup-charset)) | |
4049 (mail-parse-ignored-charsets | |
4050 (or gnus-article-ignored-charsets | |
4051 ',gnus-newsgroup-ignored-charsets)) | |
4052 (mbl mml-buffer-list)) | |
4053 (setq mml-buffer-list nil) | |
4054 (insert-buffer gnus-original-article-buffer) | |
4055 (mime-to-mml ',handles) | |
4056 (setq gnus-article-mime-handles nil) | |
4057 (let ((mbl1 mml-buffer-list)) | |
4058 (setq mml-buffer-list mbl) | |
4059 (set (make-local-variable 'mml-buffer-list) mbl1)) | |
4060 (gnus-make-local-hook 'kill-buffer-hook) | |
4061 (add-hook 'kill-buffer-hook 'mml-destroy-buffers t t))) | |
4062 `(lambda (no-highlight) | |
4063 (let ((mail-parse-charset (or gnus-article-charset | |
4064 ',gnus-newsgroup-charset)) | |
4065 (message-options message-options) | |
4066 (message-options-set-recipient) | |
4067 (mail-parse-ignored-charsets | |
4068 (or gnus-article-ignored-charsets | |
4069 ',gnus-newsgroup-ignored-charsets))) | |
4070 (mml-to-mime) | |
4071 (mml-destroy-buffers) | |
4072 (remove-hook 'kill-buffer-hook | |
4073 'mml-destroy-buffers t) | |
4074 (kill-local-variable 'mml-buffer-list)) | |
4075 (gnus-summary-edit-article-done | |
4076 ,(or (mail-header-references gnus-current-headers) "") | |
4077 ,(gnus-group-read-only-p) | |
4078 ,gnus-summary-buffer no-highlight))))) | |
4079 ;; Not in `gnus-mime-save-part-and-strip': | |
4080 (gnus-article-edit-done) | |
4081 (gnus-summary-expand-window) | |
4082 (gnus-summary-show-article)) | |
3020 | 4083 |
3021 (defun gnus-mime-save-part () | 4084 (defun gnus-mime-save-part () |
3022 "Save the MIME part under point." | 4085 "Save the MIME part under point." |
3023 (interactive) | 4086 (interactive) |
3024 (gnus-article-check-buffer) | 4087 (gnus-article-check-buffer) |
3025 (let ((data (get-text-property (point) 'gnus-data))) | 4088 (let ((data (get-text-property (point) 'gnus-data))) |
3026 (mm-save-part data))) | 4089 (when data |
4090 (mm-save-part data)))) | |
3027 | 4091 |
3028 (defun gnus-mime-pipe-part () | 4092 (defun gnus-mime-pipe-part () |
3029 "Pipe the MIME part under point to a process." | 4093 "Pipe the MIME part under point to a process." |
3030 (interactive) | 4094 (interactive) |
3031 (gnus-article-check-buffer) | 4095 (gnus-article-check-buffer) |
3032 (let ((data (get-text-property (point) 'gnus-data))) | 4096 (let ((data (get-text-property (point) 'gnus-data))) |
3033 (mm-pipe-part data))) | 4097 (when data |
4098 (mm-pipe-part data)))) | |
3034 | 4099 |
3035 (defun gnus-mime-view-part () | 4100 (defun gnus-mime-view-part () |
3036 "Interactively choose a viewing method for the MIME part under point." | 4101 "Interactively choose a viewing method for the MIME part under point." |
3037 (interactive) | 4102 (interactive) |
3038 (gnus-article-check-buffer) | 4103 (gnus-article-check-buffer) |
3039 (let ((data (get-text-property (point) 'gnus-data))) | 4104 (let ((data (get-text-property (point) 'gnus-data))) |
3040 (push (setq data (copy-sequence data)) gnus-article-mime-handles) | 4105 (when data |
3041 (mm-interactively-view-part data))) | 4106 (setq gnus-article-mime-handles |
4107 (mm-merge-handles | |
4108 gnus-article-mime-handles (setq data (copy-sequence data)))) | |
4109 (mm-interactively-view-part data)))) | |
3042 | 4110 |
3043 (defun gnus-mime-view-part-as-type-internal () | 4111 (defun gnus-mime-view-part-as-type-internal () |
3044 (gnus-article-check-buffer) | 4112 (gnus-article-check-buffer) |
3045 (let* ((name (mail-content-type-get | 4113 (let* ((name (mail-content-type-get |
3046 (mm-handle-type (get-text-property (point) 'gnus-data)) | 4114 (mm-handle-type (get-text-property (point) 'gnus-data)) |
3047 'name)) | 4115 'name)) |
3048 (def-type (and name (mm-default-file-encoding name)))) | 4116 (def-type (and name (mm-default-file-encoding name)))) |
3049 (and def-type (cons def-type 0)))) | 4117 (and def-type (cons def-type 0)))) |
3050 | 4118 |
3051 (defun gnus-mime-view-part-as-type (mime-type) | 4119 (defun gnus-mime-view-part-as-type (&optional mime-type) |
3052 "Choose a MIME media type, and view the part as such." | 4120 "Choose a MIME media type, and view the part as such." |
3053 (interactive | 4121 (interactive) |
3054 (list (completing-read | 4122 (unless mime-type |
3055 "View as MIME type: " | 4123 (setq mime-type (completing-read |
3056 (mapcar #'list (mailcap-mime-types)) | 4124 "View as MIME type: " |
3057 nil nil | 4125 (mapcar #'list (mailcap-mime-types)) |
3058 (gnus-mime-view-part-as-type-internal)))) | 4126 nil nil |
4127 (gnus-mime-view-part-as-type-internal)))) | |
3059 (gnus-article-check-buffer) | 4128 (gnus-article-check-buffer) |
3060 (let ((handle (get-text-property (point) 'gnus-data))) | 4129 (let ((handle (get-text-property (point) 'gnus-data))) |
3061 (gnus-mm-display-part | 4130 (when handle |
3062 (mm-make-handle (mm-handle-buffer handle) | 4131 (setq handle |
3063 (cons mime-type (cdr (mm-handle-type handle))) | 4132 (mm-make-handle (mm-handle-buffer handle) |
3064 (mm-handle-encoding handle) | 4133 (cons mime-type (cdr (mm-handle-type handle))) |
3065 (mm-handle-undisplayer handle) | 4134 (mm-handle-encoding handle) |
3066 (mm-handle-disposition handle) | 4135 (mm-handle-undisplayer handle) |
3067 (mm-handle-description handle) | 4136 (mm-handle-disposition handle) |
3068 (mm-handle-cache handle) | 4137 (mm-handle-description handle) |
3069 (mm-handle-id handle))))) | 4138 nil |
4139 (mm-handle-id handle))) | |
4140 (setq gnus-article-mime-handles | |
4141 (mm-merge-handles gnus-article-mime-handles handle)) | |
4142 (gnus-mm-display-part handle)))) | |
4143 | |
4144 (eval-when-compile | |
4145 (require 'jka-compr)) | |
4146 | |
4147 ;; jka-compr.el uses a "sh -c" to direct stderr to err-file, but these days | |
4148 ;; emacs can do that itself. | |
4149 ;; | |
4150 (defun gnus-mime-jka-compr-maybe-uncompress () | |
4151 "Uncompress the current buffer if `auto-compression-mode' is enabled. | |
4152 The uncompress method used is derived from `buffer-file-name'." | |
4153 (when (and (fboundp 'jka-compr-installed-p) | |
4154 (jka-compr-installed-p)) | |
4155 (let ((info (jka-compr-get-compression-info buffer-file-name))) | |
4156 (when info | |
4157 (let ((basename (file-name-nondirectory buffer-file-name)) | |
4158 (args (jka-compr-info-uncompress-args info)) | |
4159 (prog (jka-compr-info-uncompress-program info)) | |
4160 (message (jka-compr-info-uncompress-message info)) | |
4161 (err-file (jka-compr-make-temp-name))) | |
4162 (if message | |
4163 (message "%s %s..." message basename)) | |
4164 (unwind-protect | |
4165 (unless (memq (apply 'call-process-region | |
4166 (point-min) (point-max) | |
4167 prog | |
4168 t (list t err-file) nil | |
4169 args) | |
4170 jka-compr-acceptable-retval-list) | |
4171 (jka-compr-error prog args basename message err-file)) | |
4172 (jka-compr-delete-temp-file err-file))))))) | |
3070 | 4173 |
3071 (defun gnus-mime-copy-part (&optional handle) | 4174 (defun gnus-mime-copy-part (&optional handle) |
3072 "Put the MIME part under point into a new buffer." | 4175 "Put the MIME part under point into a new buffer. |
4176 If `auto-compression-mode' is enabled, compressed files like .gz and .bz2 | |
4177 are decompressed." | |
3073 (interactive) | 4178 (interactive) |
3074 (gnus-article-check-buffer) | 4179 (gnus-article-check-buffer) |
3075 (let* ((handle (or handle (get-text-property (point) 'gnus-data))) | 4180 (let* ((handle (or handle (get-text-property (point) 'gnus-data))) |
3076 (contents (mm-get-part handle)) | 4181 (contents (and handle (mm-get-part handle))) |
3077 (base (file-name-nondirectory | 4182 (base (and handle |
3078 (or | 4183 (file-name-nondirectory |
3079 (mail-content-type-get (mm-handle-type handle) 'name) | 4184 (or |
3080 (mail-content-type-get (mm-handle-type handle) | 4185 (mail-content-type-get (mm-handle-type handle) 'name) |
3081 'filename) | 4186 (mail-content-type-get (mm-handle-disposition handle) |
3082 "*decoded*"))) | 4187 'filename) |
3083 (buffer (generate-new-buffer base))) | 4188 "*decoded*")))) |
3084 (switch-to-buffer buffer) | 4189 (buffer (and base (generate-new-buffer base)))) |
3085 (insert contents) | 4190 (when contents |
3086 ;; We do it this way to make `normal-mode' set the appropriate mode. | 4191 (switch-to-buffer buffer) |
3087 (unwind-protect | 4192 (insert contents) |
3088 (progn | 4193 ;; We do it this way to make `normal-mode' set the appropriate mode. |
3089 (setq buffer-file-name (expand-file-name base)) | 4194 (unwind-protect |
3090 (normal-mode)) | 4195 (progn |
3091 (setq buffer-file-name nil)) | 4196 (setq buffer-file-name (expand-file-name base)) |
3092 (goto-char (point-min)))) | 4197 (gnus-mime-jka-compr-maybe-uncompress) |
4198 (normal-mode)) | |
4199 (setq buffer-file-name nil)) | |
4200 (goto-char (point-min))))) | |
4201 | |
4202 (defun gnus-mime-print-part (&optional handle filename) | |
4203 "Print the MIME part under point." | |
4204 (interactive (list nil (ps-print-preprint current-prefix-arg))) | |
4205 (gnus-article-check-buffer) | |
4206 (let* ((handle (or handle (get-text-property (point) 'gnus-data))) | |
4207 (contents (and handle (mm-get-part handle))) | |
4208 (file (mm-make-temp-file (expand-file-name "mm." mm-tmp-directory))) | |
4209 (printer (mailcap-mime-info (mm-handle-media-type handle) "print"))) | |
4210 (when contents | |
4211 (if printer | |
4212 (unwind-protect | |
4213 (progn | |
4214 (mm-save-part-to-file handle file) | |
4215 (call-process shell-file-name nil | |
4216 (generate-new-buffer " *mm*") | |
4217 nil | |
4218 shell-command-switch | |
4219 (mm-mailcap-command | |
4220 printer file (mm-handle-type handle)))) | |
4221 (delete-file file)) | |
4222 (with-temp-buffer | |
4223 (insert contents) | |
4224 (gnus-print-buffer)) | |
4225 (ps-despool filename))))) | |
3093 | 4226 |
3094 (defun gnus-mime-inline-part (&optional handle arg) | 4227 (defun gnus-mime-inline-part (&optional handle arg) |
3095 "Insert the MIME part under point into the current buffer." | 4228 "Insert the MIME part under point into the current buffer." |
3096 (interactive (list nil current-prefix-arg)) | 4229 (interactive (list nil current-prefix-arg)) |
3097 (gnus-article-check-buffer) | 4230 (gnus-article-check-buffer) |
3098 (let* ((handle (or handle (get-text-property (point) 'gnus-data))) | 4231 (let* ((handle (or handle (get-text-property (point) 'gnus-data))) |
3099 contents charset | 4232 contents charset |
3100 (b (point)) | 4233 (b (point)) |
3101 buffer-read-only) | 4234 buffer-read-only) |
3102 (if (mm-handle-undisplayer handle) | 4235 (when handle |
3103 (mm-remove-part handle) | 4236 (if (and (not arg) (mm-handle-undisplayer handle)) |
3104 (setq contents (mm-get-part handle)) | 4237 (mm-remove-part handle) |
3105 (cond | 4238 (setq contents (mm-get-part handle)) |
3106 ((not arg) | 4239 (cond |
3107 (setq charset (or (mail-content-type-get | 4240 ((not arg) |
3108 (mm-handle-type handle) 'charset) | 4241 (setq charset (or (mail-content-type-get |
3109 gnus-newsgroup-charset))) | 4242 (mm-handle-type handle) 'charset) |
3110 ((numberp arg) | 4243 gnus-newsgroup-charset))) |
3111 (setq charset | 4244 ((numberp arg) |
3112 (or (cdr (assq arg | 4245 (if (mm-handle-undisplayer handle) |
3113 gnus-summary-show-article-charset-alist)) | 4246 (mm-remove-part handle)) |
3114 (read-coding-system "Charset: "))))) | 4247 (setq charset |
3115 (forward-line 2) | 4248 (or (cdr (assq arg |
3116 (mm-insert-inline handle | 4249 gnus-summary-show-article-charset-alist)) |
3117 (if (and charset | 4250 (mm-read-coding-system "Charset: "))))) |
3118 (setq charset (mm-charset-to-coding-system | 4251 (forward-line 2) |
3119 charset)) | 4252 (mm-insert-inline handle |
3120 (not (eq charset 'ascii))) | 4253 (if (and charset |
3121 (mm-decode-coding-string contents charset) | 4254 (setq charset (mm-charset-to-coding-system |
3122 contents)) | 4255 charset)) |
3123 (goto-char b)))) | 4256 (not (eq charset 'ascii))) |
3124 | 4257 (mm-decode-coding-string contents charset) |
3125 (defun gnus-mime-externalize-part (&optional handle) | 4258 contents)) |
4259 (goto-char b))))) | |
4260 | |
4261 (defun gnus-mime-view-part-as-charset (&optional handle arg) | |
4262 "Insert the MIME part under point into the current buffer using the | |
4263 specified charset." | |
4264 (interactive (list nil current-prefix-arg)) | |
4265 (gnus-article-check-buffer) | |
4266 (let* ((handle (or handle (get-text-property (point) 'gnus-data))) | |
4267 contents charset | |
4268 (b (point)) | |
4269 buffer-read-only) | |
4270 (when handle | |
4271 (if (mm-handle-undisplayer handle) | |
4272 (mm-remove-part handle)) | |
4273 (let ((gnus-newsgroup-charset | |
4274 (or (cdr (assq arg | |
4275 gnus-summary-show-article-charset-alist)) | |
4276 (mm-read-coding-system "Charset: "))) | |
4277 (gnus-newsgroup-ignored-charsets 'gnus-all)) | |
4278 (gnus-article-press-button))))) | |
4279 | |
4280 (defun gnus-mime-view-part-externally (&optional handle) | |
3126 "View the MIME part under point with an external viewer." | 4281 "View the MIME part under point with an external viewer." |
3127 (interactive) | 4282 (interactive) |
3128 (gnus-article-check-buffer) | 4283 (gnus-article-check-buffer) |
3129 (let* ((handle (or handle (get-text-property (point) 'gnus-data))) | 4284 (let* ((handle (or handle (get-text-property (point) 'gnus-data))) |
3130 (mm-user-display-methods nil) | 4285 (mm-user-display-methods nil) |
3131 (mm-inlined-types nil) | 4286 (mm-inlined-types nil) |
3132 (mail-parse-charset gnus-newsgroup-charset) | 4287 (mail-parse-charset gnus-newsgroup-charset) |
3133 (mail-parse-ignored-charsets | 4288 (mail-parse-ignored-charsets |
3134 (save-excursion (set-buffer gnus-summary-buffer) | 4289 (save-excursion (set-buffer gnus-summary-buffer) |
3135 gnus-newsgroup-ignored-charsets))) | 4290 gnus-newsgroup-ignored-charsets))) |
3136 (if (mm-handle-undisplayer handle) | 4291 (when handle |
3137 (mm-remove-part handle) | 4292 (if (mm-handle-undisplayer handle) |
3138 (mm-display-part handle)))) | 4293 (mm-remove-part handle) |
3139 | 4294 (mm-display-part handle))))) |
3140 (defun gnus-mime-internalize-part (&optional handle) | 4295 |
4296 (defun gnus-mime-view-part-internally (&optional handle) | |
3141 "View the MIME part under point with an internal viewer. | 4297 "View the MIME part under point with an internal viewer. |
3142 In no internal viewer is available, use an external viewer." | 4298 If no internal viewer is available, use an external viewer." |
3143 (interactive) | 4299 (interactive) |
3144 (gnus-article-check-buffer) | 4300 (gnus-article-check-buffer) |
3145 (let* ((handle (or handle (get-text-property (point) 'gnus-data))) | 4301 (let* ((handle (or handle (get-text-property (point) 'gnus-data))) |
3146 (mm-inlined-types '(".*")) | 4302 (mm-inlined-types '(".*")) |
3147 (mm-inline-large-images t) | 4303 (mm-inline-large-images t) |
3148 (mail-parse-charset gnus-newsgroup-charset) | 4304 (mail-parse-charset gnus-newsgroup-charset) |
3149 (mail-parse-ignored-charsets | 4305 (mail-parse-ignored-charsets |
3150 (save-excursion (set-buffer gnus-summary-buffer) | 4306 (save-excursion (set-buffer gnus-summary-buffer) |
3151 gnus-newsgroup-ignored-charsets))) | 4307 gnus-newsgroup-ignored-charsets)) |
3152 (if (mm-handle-undisplayer handle) | 4308 buffer-read-only) |
3153 (mm-remove-part handle) | 4309 (when handle |
3154 (mm-display-part handle)))) | 4310 (if (mm-handle-undisplayer handle) |
4311 (mm-remove-part handle) | |
4312 (mm-display-part handle))))) | |
3155 | 4313 |
3156 (defun gnus-mime-action-on-part (&optional action) | 4314 (defun gnus-mime-action-on-part (&optional action) |
3157 "Do something with the MIME attachment at \(point\)." | 4315 "Do something with the MIME attachment at \(point\)." |
3158 (interactive | 4316 (interactive |
3159 (list (completing-read "Action: " gnus-mime-action-alist))) | 4317 (list (completing-read "Action: " gnus-mime-action-alist nil t))) |
3160 (gnus-article-check-buffer) | 4318 (gnus-article-check-buffer) |
3161 (let ((action-pair (assoc action gnus-mime-action-alist))) | 4319 (let ((action-pair (assoc action gnus-mime-action-alist))) |
3162 (if action-pair | 4320 (if action-pair |
3163 (funcall (cdr action-pair))))) | 4321 (funcall (cdr action-pair))))) |
3164 | |
3165 | 4322 |
3166 (defun gnus-article-part-wrapper (n function) | 4323 (defun gnus-article-part-wrapper (n function) |
3167 (save-current-buffer | 4324 (save-current-buffer |
3168 (set-buffer gnus-article-buffer) | 4325 (set-buffer gnus-article-buffer) |
3169 (when (> n (length gnus-article-mime-handle-alist)) | 4326 (when (> n (length gnus-article-mime-handle-alist)) |
3190 (defun gnus-article-copy-part (n) | 4347 (defun gnus-article-copy-part (n) |
3191 "Copy MIME part N, which is the numerical prefix." | 4348 "Copy MIME part N, which is the numerical prefix." |
3192 (interactive "p") | 4349 (interactive "p") |
3193 (gnus-article-part-wrapper n 'gnus-mime-copy-part)) | 4350 (gnus-article-part-wrapper n 'gnus-mime-copy-part)) |
3194 | 4351 |
3195 (defun gnus-article-externalize-part (n) | 4352 (defun gnus-article-view-part-as-charset (n) |
4353 "View MIME part N using a specified charset. | |
4354 N is the numerical prefix." | |
4355 (interactive "p") | |
4356 (gnus-article-part-wrapper n 'gnus-mime-view-part-as-charset)) | |
4357 | |
4358 (defun gnus-article-view-part-externally (n) | |
3196 "View MIME part N externally, which is the numerical prefix." | 4359 "View MIME part N externally, which is the numerical prefix." |
3197 (interactive "p") | 4360 (interactive "p") |
3198 (gnus-article-part-wrapper n 'gnus-mime-externalize-part)) | 4361 (gnus-article-part-wrapper n 'gnus-mime-view-part-externally)) |
3199 | 4362 |
3200 (defun gnus-article-inline-part (n) | 4363 (defun gnus-article-inline-part (n) |
3201 "Inline MIME part N, which is the numerical prefix." | 4364 "Inline MIME part N, which is the numerical prefix." |
3202 (interactive "p") | 4365 (interactive "p") |
3203 (gnus-article-part-wrapper n 'gnus-mime-inline-part)) | 4366 (gnus-article-part-wrapper n 'gnus-mime-inline-part)) |
3251 (forward-line 1) | 4414 (forward-line 1) |
3252 (prog1 | 4415 (prog1 |
3253 (let ((window (selected-window)) | 4416 (let ((window (selected-window)) |
3254 (mail-parse-charset gnus-newsgroup-charset) | 4417 (mail-parse-charset gnus-newsgroup-charset) |
3255 (mail-parse-ignored-charsets | 4418 (mail-parse-ignored-charsets |
3256 (save-excursion (set-buffer gnus-summary-buffer) | 4419 (if (gnus-buffer-live-p gnus-summary-buffer) |
3257 gnus-newsgroup-ignored-charsets))) | 4420 (save-excursion |
4421 (set-buffer gnus-summary-buffer) | |
4422 gnus-newsgroup-ignored-charsets) | |
4423 nil))) | |
3258 (save-excursion | 4424 (save-excursion |
3259 (unwind-protect | 4425 (unwind-protect |
3260 (let ((win (get-buffer-window (current-buffer) t)) | 4426 (let ((win (gnus-get-buffer-window (current-buffer) t)) |
3261 (beg (point))) | 4427 (beg (point))) |
3262 (when win | 4428 (when win |
3263 (select-window win)) | 4429 (select-window win)) |
3264 (goto-char point) | 4430 (goto-char point) |
3265 (forward-line) | 4431 (forward-line) |
3266 (if (mm-handle-displayed-p handle) | 4432 (if (mm-handle-displayed-p handle) |
3267 ;; This will remove the part. | 4433 ;; This will remove the part. |
3268 (mm-display-part handle) | 4434 (mm-display-part handle) |
3269 (save-restriction | 4435 (save-restriction |
3270 (narrow-to-region (point) (1+ (point))) | 4436 (narrow-to-region (point) |
4437 (if (eobp) (point) (1+ (point)))) | |
3271 (mm-display-part handle) | 4438 (mm-display-part handle) |
3272 ;; We narrow to the part itself and | 4439 ;; We narrow to the part itself and |
3273 ;; then call the treatment functions. | 4440 ;; then call the treatment functions. |
3274 (goto-char (point-min)) | 4441 (goto-char (point-min)) |
3275 (forward-line 1) | 4442 (forward-line 1) |
3276 (narrow-to-region (point) (point-max)) | 4443 (narrow-to-region (point) (point-max)) |
3277 (gnus-treat-article | 4444 (gnus-treat-article |
3278 nil id | 4445 nil id |
3279 (gnus-article-mime-total-parts) | 4446 (gnus-article-mime-total-parts) |
3280 (mm-handle-media-type handle))))) | 4447 (mm-handle-media-type handle))))) |
3281 (select-window window)))) | 4448 (if (window-live-p window) |
4449 (select-window window))))) | |
3282 (goto-char point) | 4450 (goto-char point) |
3283 (delete-region (gnus-point-at-bol) (progn (forward-line 1) (point))) | 4451 (gnus-delete-line) |
3284 (gnus-insert-mime-button | 4452 (gnus-insert-mime-button |
3285 handle id (list (mm-handle-displayed-p handle))) | 4453 handle id (list (mm-handle-displayed-p handle))) |
3286 (goto-char point)))) | 4454 (goto-char point)))) |
3287 | 4455 |
3288 (defun gnus-article-goto-part (n) | 4456 (defun gnus-article-goto-part (n) |
3289 "Go to MIME part N." | 4457 "Go to MIME part N." |
3290 (let ((point (text-property-any (point-min) (point-max) 'gnus-part n))) | 4458 (gnus-goto-char (text-property-any (point-min) (point-max) 'gnus-part n))) |
3291 (when point | |
3292 (goto-char point)))) | |
3293 | 4459 |
3294 (defun gnus-insert-mime-button (handle gnus-tmp-id &optional displayed) | 4460 (defun gnus-insert-mime-button (handle gnus-tmp-id &optional displayed) |
3295 (let ((gnus-tmp-name | 4461 (let ((gnus-tmp-name |
3296 (or (mail-content-type-get (mm-handle-type handle) | 4462 (or (mail-content-type-get (mm-handle-type handle) 'name) |
3297 'name) | 4463 (mail-content-type-get (mm-handle-disposition handle) 'filename) |
3298 (mail-content-type-get (mm-handle-disposition handle) | 4464 (mail-content-type-get (mm-handle-type handle) 'url) |
3299 'filename) | |
3300 "")) | 4465 "")) |
3301 (gnus-tmp-type (mm-handle-media-type handle)) | 4466 (gnus-tmp-type (mm-handle-media-type handle)) |
3302 (gnus-tmp-description | 4467 (gnus-tmp-description |
3303 (mail-decode-encoded-word-string (or (mm-handle-description handle) | 4468 (mail-decode-encoded-word-string (or (mm-handle-description handle) |
3304 ""))) | 4469 ""))) |
3312 (when (string-match ".*/" gnus-tmp-name) | 4477 (when (string-match ".*/" gnus-tmp-name) |
3313 (setq gnus-tmp-name (replace-match "" t t gnus-tmp-name))) | 4478 (setq gnus-tmp-name (replace-match "" t t gnus-tmp-name))) |
3314 (setq gnus-tmp-type-long (concat gnus-tmp-type | 4479 (setq gnus-tmp-type-long (concat gnus-tmp-type |
3315 (and (not (equal gnus-tmp-name "")) | 4480 (and (not (equal gnus-tmp-name "")) |
3316 (concat "; " gnus-tmp-name)))) | 4481 (concat "; " gnus-tmp-name)))) |
3317 (or (equal gnus-tmp-description "") | 4482 (unless (equal gnus-tmp-description "") |
3318 (setq gnus-tmp-type-long (concat " --- " gnus-tmp-type-long))) | 4483 (setq gnus-tmp-type-long (concat " --- " gnus-tmp-type-long))) |
3319 (unless (bolp) | 4484 (unless (bolp) |
3320 (insert "\n")) | 4485 (insert "\n")) |
3321 (setq b (point)) | 4486 (setq b (point)) |
3322 (gnus-eval-format | 4487 (gnus-eval-format |
3323 gnus-mime-button-line-format gnus-mime-button-line-format-alist | 4488 gnus-mime-button-line-format gnus-mime-button-line-format-alist |
3324 `(keymap ,gnus-mime-button-map | 4489 `(,@(gnus-local-map-property gnus-mime-button-map) |
3325 ;; Not for Emacs 21: fixme better. | 4490 gnus-callback gnus-mm-display-part |
3326 ;; local-map ,gnus-mime-button-map | 4491 gnus-part ,gnus-tmp-id |
3327 gnus-callback gnus-mm-display-part | 4492 article-type annotation |
3328 gnus-part ,gnus-tmp-id | 4493 gnus-data ,handle)) |
3329 article-type annotation | 4494 (setq e (if (bolp) |
3330 gnus-data ,handle)) | 4495 ;; Exclude a newline. |
3331 (setq e (point)) | 4496 (1- (point)) |
4497 (point))) | |
3332 (widget-convert-button | 4498 (widget-convert-button |
3333 'link b e | 4499 'link b e |
3334 :mime-handle handle | 4500 :mime-handle handle |
3335 :action 'gnus-widget-press-button | 4501 :action 'gnus-widget-press-button |
3336 :button-keymap gnus-mime-button-map | 4502 :button-keymap gnus-mime-button-map |
3369 (when window | 4535 (when window |
3370 (select-window window) | 4536 (select-window window) |
3371 ;; We have to do this since selecting the window | 4537 ;; We have to do this since selecting the window |
3372 ;; may change the point. So we set the window point. | 4538 ;; may change the point. So we set the window point. |
3373 (set-window-point window point))) | 4539 (set-window-point window point))) |
3374 (let* ((handles (or ihandles (mm-dissect-buffer) (mm-uu-dissect))) | 4540 (let* ((handles (or ihandles |
4541 (mm-dissect-buffer nil gnus-article-loose-mime) | |
4542 (and gnus-article-emulate-mime | |
4543 (mm-uu-dissect)))) | |
3375 buffer-read-only handle name type b e display) | 4544 buffer-read-only handle name type b e display) |
3376 (when (and (not ihandles) | 4545 (when (and (not ihandles) |
3377 (not gnus-displaying-mime)) | 4546 (not gnus-displaying-mime)) |
3378 ;; Top-level call; we clean up. | 4547 ;; Top-level call; we clean up. |
3379 (when gnus-article-mime-handles | 4548 (when gnus-article-mime-handles |
3405 (save-restriction | 4574 (save-restriction |
3406 (article-goto-body) | 4575 (article-goto-body) |
3407 (narrow-to-region (point-min) (point)) | 4576 (narrow-to-region (point-min) (point)) |
3408 (gnus-treat-article 'head)))))))) | 4577 (gnus-treat-article 'head)))))))) |
3409 | 4578 |
3410 (defvar gnus-mime-display-multipart-as-mixed nil) | 4579 (defcustom gnus-mime-display-multipart-as-mixed nil |
4580 "Display \"multipart\" parts as \"multipart/mixed\". | |
4581 | |
4582 If t, it overrides nil values of | |
4583 `gnus-mime-display-multipart-alternative-as-mixed' and | |
4584 `gnus-mime-display-multipart-related-as-mixed'." | |
4585 :group 'gnus-article-mime | |
4586 :type 'boolean) | |
4587 | |
4588 (defcustom gnus-mime-display-multipart-alternative-as-mixed nil | |
4589 "Display \"multipart/alternative\" parts as \"multipart/mixed\"." | |
4590 :group 'gnus-article-mime | |
4591 :type 'boolean) | |
4592 | |
4593 (defcustom gnus-mime-display-multipart-related-as-mixed nil | |
4594 "Display \"multipart/related\" parts as \"multipart/mixed\". | |
4595 | |
4596 If displaying \"text/html\" is discouraged \(see | |
4597 `mm-discouraged-alternatives'\) images or other material inside a | |
4598 \"multipart/related\" part might be overlooked when this variable is nil." | |
4599 :group 'gnus-article-mime | |
4600 :type 'boolean) | |
3411 | 4601 |
3412 (defun gnus-mime-display-part (handle) | 4602 (defun gnus-mime-display-part (handle) |
3413 (cond | 4603 (cond |
3414 ;; Single part. | 4604 ;; Single part. |
3415 ((not (stringp (car handle))) | 4605 ((not (stringp (car handle))) |
3418 ((cdr (assoc (car handle) gnus-mime-multipart-functions)) | 4608 ((cdr (assoc (car handle) gnus-mime-multipart-functions)) |
3419 (funcall (cdr (assoc (car handle) gnus-mime-multipart-functions)) | 4609 (funcall (cdr (assoc (car handle) gnus-mime-multipart-functions)) |
3420 handle)) | 4610 handle)) |
3421 ;; multipart/alternative | 4611 ;; multipart/alternative |
3422 ((and (equal (car handle) "multipart/alternative") | 4612 ((and (equal (car handle) "multipart/alternative") |
3423 (not gnus-mime-display-multipart-as-mixed)) | 4613 (not (or gnus-mime-display-multipart-as-mixed |
4614 gnus-mime-display-multipart-alternative-as-mixed))) | |
3424 (let ((id (1+ (length gnus-article-mime-handle-alist)))) | 4615 (let ((id (1+ (length gnus-article-mime-handle-alist)))) |
3425 (push (cons id handle) gnus-article-mime-handle-alist) | 4616 (push (cons id handle) gnus-article-mime-handle-alist) |
3426 (gnus-mime-display-alternative (cdr handle) nil nil id))) | 4617 (gnus-mime-display-alternative (cdr handle) nil nil id))) |
3427 ;; multipart/related | 4618 ;; multipart/related |
3428 ((and (equal (car handle) "multipart/related") | 4619 ((and (equal (car handle) "multipart/related") |
3429 (not gnus-mime-display-multipart-as-mixed)) | 4620 (not (or gnus-mime-display-multipart-as-mixed |
4621 gnus-mime-display-multipart-related-as-mixed))) | |
3430 ;;;!!!We should find the start part, but we just default | 4622 ;;;!!!We should find the start part, but we just default |
3431 ;;;!!!to the first part. | 4623 ;;;!!!to the first part. |
4624 ;;(gnus-mime-display-part (cadr handle)) | |
4625 ;;;!!! Most multipart/related is an HTML message plus images. | |
4626 ;;;!!! Unfortunately we are unable to let W3 display those | |
4627 ;;;!!! included images, so we just display it as a mixed multipart. | |
4628 ;;(gnus-mime-display-mixed (cdr handle)) | |
4629 ;;;!!! No, w3 can display everything just fine. | |
3432 (gnus-mime-display-part (cadr handle))) | 4630 (gnus-mime-display-part (cadr handle))) |
4631 ((equal (car handle) "multipart/signed") | |
4632 (gnus-add-wash-type 'signed) | |
4633 (gnus-mime-display-security handle)) | |
4634 ((equal (car handle) "multipart/encrypted") | |
4635 (gnus-add-wash-type 'encrypted) | |
4636 (gnus-mime-display-security handle)) | |
3433 ;; Other multiparts are handled like multipart/mixed. | 4637 ;; Other multiparts are handled like multipart/mixed. |
3434 (t | 4638 (t |
3435 (gnus-mime-display-mixed (cdr handle))))) | 4639 (gnus-mime-display-mixed (cdr handle))))) |
3436 | 4640 |
3437 (defun gnus-mime-part-function (handles) | 4641 (defun gnus-mime-part-function (handles) |
3458 (or (not (mm-handle-disposition handle)) | 4662 (or (not (mm-handle-disposition handle)) |
3459 (equal (car (mm-handle-disposition handle)) | 4663 (equal (car (mm-handle-disposition handle)) |
3460 "inline") | 4664 "inline") |
3461 (mm-attachment-override-p handle)))) | 4665 (mm-attachment-override-p handle)))) |
3462 (mm-automatic-display-p handle) | 4666 (mm-automatic-display-p handle) |
3463 (or (mm-inlined-p handle) | 4667 (or (and |
4668 (mm-inlinable-p handle) | |
4669 (mm-inlined-p handle)) | |
3464 (mm-automatic-external-display-p type))) | 4670 (mm-automatic-external-display-p type))) |
3465 (setq display t) | 4671 (setq display t) |
3466 (when (equal (mm-handle-media-supertype handle) "text") | 4672 (when (equal (mm-handle-media-supertype handle) "text") |
3467 (setq text t))) | 4673 (setq text t))) |
3468 (let ((id (1+ (length gnus-article-mime-handle-alist))) | 4674 (let ((id (1+ (length gnus-article-mime-handle-alist))) |
3473 ;(gnus-article-insert-newline) | 4679 ;(gnus-article-insert-newline) |
3474 (gnus-insert-mime-button | 4680 (gnus-insert-mime-button |
3475 handle id (list (or display (and not-attachment text)))) | 4681 handle id (list (or display (and not-attachment text)))) |
3476 (gnus-article-insert-newline) | 4682 (gnus-article-insert-newline) |
3477 ;(gnus-article-insert-newline) | 4683 ;(gnus-article-insert-newline) |
4684 ;; Remember modify the number of forward lines. | |
3478 (setq move t)) | 4685 (setq move t)) |
3479 (setq beg (point)) | 4686 (setq beg (point)) |
3480 (cond | 4687 (cond |
3481 (display | 4688 (display |
3482 (when move | 4689 (when move |
3483 (forward-line -2) | 4690 (forward-line -1) |
3484 (setq beg (point))) | 4691 (setq beg (point))) |
3485 (let ((mail-parse-charset gnus-newsgroup-charset) | 4692 (let ((mail-parse-charset gnus-newsgroup-charset) |
3486 (mail-parse-ignored-charsets | 4693 (mail-parse-ignored-charsets |
3487 (save-excursion (condition-case () | 4694 (save-excursion (condition-case () |
3488 (set-buffer gnus-summary-buffer) | 4695 (set-buffer gnus-summary-buffer) |
3490 gnus-newsgroup-ignored-charsets))) | 4697 gnus-newsgroup-ignored-charsets))) |
3491 (mm-display-part handle t)) | 4698 (mm-display-part handle t)) |
3492 (goto-char (point-max))) | 4699 (goto-char (point-max))) |
3493 ((and text not-attachment) | 4700 ((and text not-attachment) |
3494 (when move | 4701 (when move |
3495 (forward-line -2) | 4702 (forward-line -1) |
3496 (setq beg (point))) | 4703 (setq beg (point))) |
3497 (gnus-article-insert-newline) | 4704 (gnus-article-insert-newline) |
3498 (mm-insert-inline handle (mm-get-part handle)) | 4705 (mm-insert-inline handle (mm-get-part handle)) |
3499 (goto-char (point-max)))) | 4706 (goto-char (point-max)))) |
3500 ;; Do highlighting. | 4707 ;; Do highlighting. |
3507 (mm-handle-media-type handle))))))))) | 4714 (mm-handle-media-type handle))))))))) |
3508 | 4715 |
3509 (defun gnus-unbuttonized-mime-type-p (type) | 4716 (defun gnus-unbuttonized-mime-type-p (type) |
3510 "Say whether TYPE is to be unbuttonized." | 4717 "Say whether TYPE is to be unbuttonized." |
3511 (unless gnus-inhibit-mime-unbuttonizing | 4718 (unless gnus-inhibit-mime-unbuttonizing |
3512 (catch 'found | 4719 (when (catch 'found |
3513 (let ((types gnus-unbuttonized-mime-types)) | 4720 (let ((types gnus-unbuttonized-mime-types)) |
3514 (while types | 4721 (while types |
3515 (when (string-match (pop types) type) | 4722 (when (string-match (pop types) type) |
3516 (throw 'found t))))))) | 4723 (throw 'found t))))) |
4724 (not (catch 'found | |
4725 (let ((types gnus-buttonized-mime-types)) | |
4726 (while types | |
4727 (when (string-match (pop types) type) | |
4728 (throw 'found t))))))))) | |
3517 | 4729 |
3518 (defun gnus-article-insert-newline () | 4730 (defun gnus-article-insert-newline () |
3519 "Insert a newline, but mark it as undeletable." | 4731 "Insert a newline, but mark it as undeletable." |
3520 (gnus-put-text-property | 4732 (gnus-put-text-property |
3521 (point) (progn (insert "\n") (point)) 'gnus-undeletable t)) | 4733 (point) (progn (insert "\n") (point)) 'gnus-undeletable t)) |
3539 (setq begend (list (point-marker))) | 4751 (setq begend (list (point-marker))) |
3540 ;; Do the toggle. | 4752 ;; Do the toggle. |
3541 (unless (setq not-pref (cadr (member preferred ihandles))) | 4753 (unless (setq not-pref (cadr (member preferred ihandles))) |
3542 (setq not-pref (car ihandles))) | 4754 (setq not-pref (car ihandles))) |
3543 (when (or ibegend | 4755 (when (or ibegend |
4756 (not preferred) | |
3544 (not (gnus-unbuttonized-mime-type-p | 4757 (not (gnus-unbuttonized-mime-type-p |
3545 "multipart/alternative"))) | 4758 "multipart/alternative"))) |
3546 (gnus-add-text-properties | 4759 (gnus-add-text-properties |
3547 (setq from (point)) | 4760 (setq from (point)) |
3548 (progn | 4761 (progn |
3553 (unless ,(not ibegend) | 4766 (unless ,(not ibegend) |
3554 (setq gnus-article-mime-handle-alist | 4767 (setq gnus-article-mime-handle-alist |
3555 ',gnus-article-mime-handle-alist)) | 4768 ',gnus-article-mime-handle-alist)) |
3556 (gnus-mime-display-alternative | 4769 (gnus-mime-display-alternative |
3557 ',ihandles ',not-pref ',begend ,id)) | 4770 ',ihandles ',not-pref ',begend ,id)) |
3558 ;; Not for Emacs 21: fixme better. | 4771 ,@(gnus-local-map-property gnus-mime-button-map) |
3559 ;; local-map ,gnus-mime-button-map | |
3560 ,gnus-mouse-face-prop ,gnus-article-mouse-face | 4772 ,gnus-mouse-face-prop ,gnus-article-mouse-face |
3561 face ,gnus-article-button-face | 4773 face ,gnus-article-button-face |
3562 keymap ,gnus-mime-button-map | |
3563 gnus-part ,id | 4774 gnus-part ,id |
3564 gnus-data ,handle)) | 4775 gnus-data ,handle)) |
3565 (widget-convert-button 'link from (point) | 4776 (widget-convert-button 'link from (point) |
3566 :action 'gnus-widget-press-button | 4777 :action 'gnus-widget-press-button |
3567 :button-keymap gnus-widget-button-keymap) | 4778 :button-keymap gnus-widget-button-keymap) |
3579 (unless ,(not ibegend) | 4790 (unless ,(not ibegend) |
3580 (setq gnus-article-mime-handle-alist | 4791 (setq gnus-article-mime-handle-alist |
3581 ',gnus-article-mime-handle-alist)) | 4792 ',gnus-article-mime-handle-alist)) |
3582 (gnus-mime-display-alternative | 4793 (gnus-mime-display-alternative |
3583 ',ihandles ',handle ',begend ,id)) | 4794 ',ihandles ',handle ',begend ,id)) |
3584 ;; Not for Emacs 21: fixme better. | 4795 ,@(gnus-local-map-property gnus-mime-button-map) |
3585 ;; local-map ,gnus-mime-button-map | |
3586 ,gnus-mouse-face-prop ,gnus-article-mouse-face | 4796 ,gnus-mouse-face-prop ,gnus-article-mouse-face |
3587 face ,gnus-article-button-face | 4797 face ,gnus-article-button-face |
3588 keymap ,gnus-mime-button-map | |
3589 gnus-part ,id | 4798 gnus-part ,id |
3590 gnus-data ,handle)) | 4799 gnus-data ,handle)) |
3591 (widget-convert-button 'link from (point) | 4800 (widget-convert-button 'link from (point) |
3592 :action 'gnus-widget-press-button | 4801 :action 'gnus-widget-press-button |
3593 :button-keymap gnus-widget-button-keymap) | 4802 :button-keymap gnus-widget-button-keymap) |
3612 (goto-char (point-max)) | 4821 (goto-char (point-max)) |
3613 (setcdr begend (point-marker))))) | 4822 (setcdr begend (point-marker))))) |
3614 (when ibegend | 4823 (when ibegend |
3615 (goto-char point)))) | 4824 (goto-char point)))) |
3616 | 4825 |
4826 (defconst gnus-article-wash-status-strings | |
4827 (let ((alist '((cite "c" "Possible hidden citation text" | |
4828 " " "All citation text visible") | |
4829 (headers "h" "Hidden headers" | |
4830 " " "All headers visible.") | |
4831 (pgp "p" "Encrypted or signed message status hidden" | |
4832 " " "No hidden encryption nor digital signature status") | |
4833 (signature "s" "Signature has been hidden" | |
4834 " " "Signature is visible") | |
4835 (overstrike "o" "Overstrike (^H) characters applied" | |
4836 " " "No overstrike characters applied") | |
4837 (emphasis "e" "/*_Emphasis_*/ characters applied" | |
4838 " " "No /*_emphasis_*/ characters applied"))) | |
4839 result) | |
4840 (dolist (entry alist result) | |
4841 (let ((key (nth 0 entry)) | |
4842 (on (copy-sequence (nth 1 entry))) | |
4843 (on-help (nth 2 entry)) | |
4844 (off (copy-sequence (nth 3 entry))) | |
4845 (off-help (nth 4 entry))) | |
4846 (put-text-property 0 1 'help-echo on-help on) | |
4847 (put-text-property 0 1 'help-echo off-help off) | |
4848 (push (list key on off) result)))) | |
4849 "Alist of strings describing wash status in the mode line. | |
4850 Each entry has the form (KEY ON OF), where the KEY is a symbol | |
4851 representing the particular washing function, ON is the string to use | |
4852 in the article mode line when the washing function is active, and OFF | |
4853 is the string to use when it is inactive.") | |
4854 | |
4855 (defun gnus-article-wash-status-entry (key value) | |
4856 (let ((entry (assoc key gnus-article-wash-status-strings))) | |
4857 (if value (nth 1 entry) (nth 2 entry)))) | |
4858 | |
3617 (defun gnus-article-wash-status () | 4859 (defun gnus-article-wash-status () |
3618 "Return a string which display status of article washing." | 4860 "Return a string which display status of article washing." |
3619 (save-excursion | 4861 (save-excursion |
3620 (set-buffer gnus-article-buffer) | 4862 (set-buffer gnus-article-buffer) |
3621 (let ((cite (memq 'cite gnus-article-wash-types)) | 4863 (let ((cite (memq 'cite gnus-article-wash-types)) |
3622 (headers (memq 'headers gnus-article-wash-types)) | 4864 (headers (memq 'headers gnus-article-wash-types)) |
3623 (boring (memq 'boring-headers gnus-article-wash-types)) | 4865 (boring (memq 'boring-headers gnus-article-wash-types)) |
3624 (pgp (memq 'pgp gnus-article-wash-types)) | 4866 (pgp (memq 'pgp gnus-article-wash-types)) |
3625 (pem (memq 'pem gnus-article-wash-types)) | 4867 (pem (memq 'pem gnus-article-wash-types)) |
4868 (signed (memq 'signed gnus-article-wash-types)) | |
4869 (encrypted (memq 'encrypted gnus-article-wash-types)) | |
3626 (signature (memq 'signature gnus-article-wash-types)) | 4870 (signature (memq 'signature gnus-article-wash-types)) |
3627 (overstrike (memq 'overstrike gnus-article-wash-types)) | 4871 (overstrike (memq 'overstrike gnus-article-wash-types)) |
3628 (emphasis (memq 'emphasis gnus-article-wash-types))) | 4872 (emphasis (memq 'emphasis gnus-article-wash-types))) |
3629 (format "%c%c%c%c%c%c" | 4873 (concat |
3630 (if cite ?c ? ) | 4874 (gnus-article-wash-status-entry 'cite cite) |
3631 (if (or headers boring) ?h ? ) | 4875 (gnus-article-wash-status-entry 'headers (or headers boring)) |
3632 (if (or pgp pem) ?p ? ) | 4876 (gnus-article-wash-status-entry 'pgp (or pgp pem signed encrypted)) |
3633 (if signature ?s ? ) | 4877 (gnus-article-wash-status-entry 'signature signature) |
3634 (if overstrike ?o ? ) | 4878 (gnus-article-wash-status-entry 'overstrike overstrike) |
3635 (if emphasis ?e ? ))))) | 4879 (gnus-article-wash-status-entry 'emphasis emphasis))))) |
4880 | |
4881 (defun gnus-add-wash-type (type) | |
4882 "Add a washing of TYPE to the current status." | |
4883 (add-to-list 'gnus-article-wash-types type)) | |
4884 | |
4885 (defun gnus-delete-wash-type (type) | |
4886 "Add a washing of TYPE to the current status." | |
4887 (setq gnus-article-wash-types (delq type gnus-article-wash-types))) | |
4888 | |
4889 (defun gnus-add-image (category image) | |
4890 "Add IMAGE of CATEGORY to the list of displayed images." | |
4891 (let ((entry (assq category gnus-article-image-alist))) | |
4892 (unless entry | |
4893 (setq entry (list category)) | |
4894 (push entry gnus-article-image-alist)) | |
4895 (nconc entry (list image)))) | |
4896 | |
4897 (defun gnus-delete-images (category) | |
4898 "Delete all images in CATEGORY." | |
4899 (let ((entry (assq category gnus-article-image-alist))) | |
4900 (dolist (image (cdr entry)) | |
4901 (gnus-remove-image image category)) | |
4902 (setq gnus-article-image-alist (delq entry gnus-article-image-alist)) | |
4903 (gnus-delete-wash-type category))) | |
3636 | 4904 |
3637 (defalias 'gnus-article-hide-headers-if-wanted 'gnus-article-maybe-hide-headers) | 4905 (defalias 'gnus-article-hide-headers-if-wanted 'gnus-article-maybe-hide-headers) |
3638 | 4906 |
3639 (defun gnus-article-maybe-hide-headers () | 4907 (defun gnus-article-maybe-hide-headers () |
3640 "Hide unwanted headers if `gnus-have-all-headers' is nil. | 4908 "Hide unwanted headers if `gnus-have-all-headers' is nil. |
3669 (set-buffer gnus-article-buffer) | 4937 (set-buffer gnus-article-buffer) |
3670 (goto-char (point-min)) | 4938 (goto-char (point-min)) |
3671 (widen) | 4939 (widen) |
3672 ;; Remove any old next/prev buttons. | 4940 ;; Remove any old next/prev buttons. |
3673 (when (gnus-visual-p 'page-marker) | 4941 (when (gnus-visual-p 'page-marker) |
3674 (let ((inhibit-read-only t)) | 4942 (let ((buffer-read-only nil)) |
3675 (gnus-remove-text-with-property 'gnus-prev) | 4943 (gnus-remove-text-with-property 'gnus-prev) |
3676 (gnus-remove-text-with-property 'gnus-next))) | 4944 (gnus-remove-text-with-property 'gnus-next))) |
3677 (when | 4945 (if |
3678 (cond ((< arg 0) | 4946 (cond ((< arg 0) |
3679 (re-search-backward page-delimiter nil 'move (1+ (abs arg)))) | 4947 (re-search-backward page-delimiter nil 'move (1+ (abs arg)))) |
3680 ((> arg 0) | 4948 ((> arg 0) |
3681 (re-search-forward page-delimiter nil 'move arg))) | 4949 (re-search-forward page-delimiter nil 'move arg))) |
3682 (goto-char (match-end 0))) | 4950 (goto-char (match-end 0)) |
3683 (narrow-to-region | |
3684 (point) | |
3685 (if (re-search-forward page-delimiter nil 'move) | |
3686 (match-beginning 0) | |
3687 (point))) | |
3688 (when (and (gnus-visual-p 'page-marker) | |
3689 (> (point-min) (save-restriction (widen) (point-min)))) | |
3690 (save-excursion | 4951 (save-excursion |
3691 (goto-char (point-min)) | 4952 (goto-char (point-min)) |
3692 (gnus-insert-prev-page-button))) | 4953 (setq gnus-page-broken |
3693 (when (and (gnus-visual-p 'page-marker) | 4954 (and (re-search-forward page-delimiter nil t) t)))) |
3694 (< (point-max) (save-restriction (widen) (point-max)))) | 4955 (when gnus-page-broken |
3695 (save-excursion | 4956 (narrow-to-region |
3696 (goto-char (point-max)) | 4957 (point) |
3697 (gnus-insert-next-page-button))))) | 4958 (if (re-search-forward page-delimiter nil 'move) |
4959 (match-beginning 0) | |
4960 (point))) | |
4961 (when (and (gnus-visual-p 'page-marker) | |
4962 (not (= (point-min) 1))) | |
4963 (save-excursion | |
4964 (goto-char (point-min)) | |
4965 (gnus-insert-prev-page-button))) | |
4966 (when (and (gnus-visual-p 'page-marker) | |
4967 (< (+ (point-max) 2) (buffer-size))) | |
4968 (save-excursion | |
4969 (goto-char (point-max)) | |
4970 (gnus-insert-next-page-button)))))) | |
3698 | 4971 |
3699 ;; Article mode commands | 4972 ;; Article mode commands |
3700 | 4973 |
3701 (defun gnus-article-goto-next-page () | 4974 (defun gnus-article-goto-next-page () |
3702 "Show the next page of the article." | 4975 "Show the next page of the article." |
3703 (interactive) | 4976 (interactive) |
3704 (when (gnus-article-next-page) | 4977 (when (gnus-article-next-page) |
3705 (goto-char (point-min)) | 4978 (goto-char (point-min)) |
3706 (gnus-article-read-summary-keys nil (gnus-character-to-event ?n)))) | 4979 (gnus-article-read-summary-keys nil (gnus-character-to-event ?n)))) |
3707 | 4980 |
4981 | |
3708 (defun gnus-article-goto-prev-page () | 4982 (defun gnus-article-goto-prev-page () |
3709 "Show the next page of the article." | 4983 "Show the previous page of the article." |
3710 (interactive) | 4984 (interactive) |
3711 (if (bobp) (gnus-article-read-summary-keys nil (gnus-character-to-event ?p)) | 4985 (if (bobp) |
4986 (gnus-article-read-summary-keys nil (gnus-character-to-event ?p)) | |
3712 (gnus-article-prev-page nil))) | 4987 (gnus-article-prev-page nil))) |
4988 | |
4989 ;; This is cleaner but currently breaks `gnus-pick-mode': | |
4990 ;; | |
4991 ;; (defun gnus-article-goto-next-page () | |
4992 ;; "Show the next page of the article." | |
4993 ;; (interactive) | |
4994 ;; (gnus-eval-in-buffer-window gnus-summary-buffer | |
4995 ;; (gnus-summary-next-page))) | |
4996 ;; | |
4997 ;; (defun gnus-article-goto-prev-page () | |
4998 ;; "Show the next page of the article." | |
4999 ;; (interactive) | |
5000 ;; (gnus-eval-in-buffer-window gnus-summary-buffer | |
5001 ;; (gnus-summary-prev-page))) | |
3713 | 5002 |
3714 (defun gnus-article-next-page (&optional lines) | 5003 (defun gnus-article-next-page (&optional lines) |
3715 "Show the next page of the current article. | 5004 "Show the next page of the current article. |
3716 If end of article, return non-nil. Otherwise return nil. | 5005 If end of article, return non-nil. Otherwise return nil. |
3717 Argument LINES specifies lines to be scrolled up." | 5006 Argument LINES specifies lines to be scrolled up." |
3718 (interactive "p") | 5007 (interactive "p") |
3719 (move-to-window-line -1) | 5008 (move-to-window-line -1) |
3720 (if (save-excursion | 5009 (if (save-excursion |
3721 (end-of-line) | 5010 (end-of-line) |
3722 (and (pos-visible-in-window-p) ;Not continuation line. | 5011 (and (pos-visible-in-window-p) ;Not continuation line. |
3723 (eobp))) | 5012 (>= (1+ (point)) (point-max)))) ;Allow for trailing newline. |
3724 ;; Nothing in this page. | 5013 ;; Nothing in this page. |
3725 (if (or (not gnus-page-broken) | 5014 (if (or (not gnus-page-broken) |
3726 (save-excursion | 5015 (save-excursion |
3727 (save-restriction | 5016 (save-restriction |
3728 (widen) (forward-line 1) (eobp)))) ;Real end-of-buffer? | 5017 (widen) |
3729 t ;Nothing more. | 5018 (eobp)))) ;Real end-of-buffer? |
5019 (progn | |
5020 (when gnus-article-over-scroll | |
5021 (gnus-article-next-page-1 lines)) | |
5022 t) ;Nothing more. | |
3730 (gnus-narrow-to-page 1) ;Go to next page. | 5023 (gnus-narrow-to-page 1) ;Go to next page. |
3731 nil) | 5024 nil) |
3732 ;; More in this page. | 5025 ;; More in this page. |
3733 (let ((scroll-in-place nil)) | 5026 (gnus-article-next-page-1 lines) |
3734 (condition-case () | |
3735 (scroll-up lines) | |
3736 (end-of-buffer | |
3737 ;; Long lines may cause an end-of-buffer error. | |
3738 (goto-char (point-max))))) | |
3739 (move-to-window-line 0) | |
3740 nil)) | 5027 nil)) |
5028 | |
5029 (defun gnus-article-next-page-1 (lines) | |
5030 (let ((scroll-in-place nil)) | |
5031 (condition-case () | |
5032 (scroll-up lines) | |
5033 (end-of-buffer | |
5034 ;; Long lines may cause an end-of-buffer error. | |
5035 (goto-char (point-max))))) | |
5036 (move-to-window-line 0)) | |
3741 | 5037 |
3742 (defun gnus-article-prev-page (&optional lines) | 5038 (defun gnus-article-prev-page (&optional lines) |
3743 "Show previous page of current article. | 5039 "Show previous page of current article. |
3744 Argument LINES specifies lines to be scrolled down." | 5040 Argument LINES specifies lines to be scrolled down." |
3745 (interactive "p") | 5041 (interactive "p") |
3757 (scroll-down lines) | 5053 (scroll-down lines) |
3758 (beginning-of-buffer | 5054 (beginning-of-buffer |
3759 (goto-char (point-min)))) | 5055 (goto-char (point-min)))) |
3760 (move-to-window-line 0))))) | 5056 (move-to-window-line 0))))) |
3761 | 5057 |
5058 (defun gnus-article-only-boring-p () | |
5059 "Decide whether there is only boring text remaining in the article. | |
5060 Something \"interesting\" is a word of at least two letters that does | |
5061 not have a face in `gnus-article-boring-faces'." | |
5062 (when (and gnus-article-skip-boring | |
5063 (boundp 'gnus-article-boring-faces) | |
5064 (symbol-value 'gnus-article-boring-faces)) | |
5065 (save-excursion | |
5066 (catch 'only-boring | |
5067 (while (re-search-forward "\\b\\w\\w" nil t) | |
5068 (forward-char -1) | |
5069 (when (not (gnus-intersection | |
5070 (gnus-faces-at (point)) | |
5071 (symbol-value 'gnus-article-boring-faces))) | |
5072 (throw 'only-boring nil))) | |
5073 (throw 'only-boring t))))) | |
5074 | |
3762 (defun gnus-article-refer-article () | 5075 (defun gnus-article-refer-article () |
3763 "Read article specified by message-id around point." | 5076 "Read article specified by message-id around point." |
3764 (interactive) | 5077 (interactive) |
3765 (let ((point (point))) | 5078 (save-excursion |
3766 (search-forward ">" nil t) ;Move point to end of "<....>". | 5079 (re-search-backward "[ \t]\\|^" (gnus-point-at-bol) t) |
3767 (if (re-search-backward "\\(<[^<> \t\n]+>\\)" nil t) | 5080 (re-search-forward "<?news:<?\\|<" (gnus-point-at-eol) t) |
3768 (let ((message-id (match-string 1))) | 5081 (if (re-search-forward "[^@ ]+@[^ \t>]+" (gnus-point-at-eol) t) |
3769 (goto-char point) | 5082 (let ((msg-id (concat "<" (match-string 0) ">"))) |
3770 (set-buffer gnus-summary-buffer) | 5083 (set-buffer gnus-summary-buffer) |
3771 (gnus-summary-refer-article message-id)) | 5084 (gnus-summary-refer-article msg-id)) |
3772 (goto-char (point)) | |
3773 (error "No references around point")))) | 5085 (error "No references around point")))) |
3774 | 5086 |
3775 (defun gnus-article-show-summary () | 5087 (defun gnus-article-show-summary () |
3776 "Reconfigure windows to show summary buffer." | 5088 "Reconfigure windows to show summary buffer." |
3777 (interactive) | 5089 (interactive) |
3816 (defun gnus-article-read-summary-keys (&optional arg key not-restore-window) | 5128 (defun gnus-article-read-summary-keys (&optional arg key not-restore-window) |
3817 "Read a summary buffer key sequence and execute it from the article buffer." | 5129 "Read a summary buffer key sequence and execute it from the article buffer." |
3818 (interactive "P") | 5130 (interactive "P") |
3819 (gnus-article-check-buffer) | 5131 (gnus-article-check-buffer) |
3820 (let ((nosaves | 5132 (let ((nosaves |
3821 '("q" "Q" "c" "r" "R" "\C-c\C-f" "m" "a" "f" "F" | 5133 '("q" "Q" "c" "r" "\C-c\C-f" "m" "a" "f" |
3822 "Zc" "ZC" "ZE" "ZQ" "ZZ" "Zn" "ZR" "ZG" "ZN" "ZP" | 5134 "Zc" "ZC" "ZE" "ZQ" "ZZ" "Zn" "ZR" "ZG" "ZN" "ZP" |
3823 "=" "^" "\M-^" "|")) | 5135 "=" "^" "\M-^" "|")) |
3824 (nosave-but-article | 5136 (nosave-but-article |
3825 '("A\r")) | 5137 '("A\r")) |
3826 (nosave-in-article | 5138 (nosave-in-article |
3827 '("\C-d")) | 5139 '("\C-d")) |
3828 (up-to-top | 5140 (up-to-top |
3829 '("n" "Gn" "p" "Gp")) | 5141 '("n" "Gn" "p" "Gp")) |
3830 keys new-sum-point) | 5142 keys new-sum-point) |
3831 (save-excursion | 5143 (save-excursion |
3832 (set-buffer gnus-article-current-summary) | 5144 (set-buffer gnus-article-current-summary) |
3833 (let (gnus-pick-mode) | 5145 (let (gnus-pick-mode) |
3834 (push (or key last-command-event) unread-command-events) | 5146 (push (or key last-command-event) unread-command-events) |
3835 (setq keys (if (featurep 'xemacs) | 5147 (setq keys (if (featurep 'xemacs) |
3836 (events-to-keys (read-key-sequence nil)) | 5148 (events-to-keys (read-key-sequence nil)) |
3837 (read-key-sequence nil))))) | 5149 (read-key-sequence nil))))) |
3838 | 5150 |
3839 (message "") | 5151 (message "") |
3840 | 5152 |
3841 (if (or (member keys nosaves) | 5153 (if (or (member keys nosaves) |
3842 (member keys nosave-but-article) | 5154 (member keys nosave-but-article) |
3843 (member keys nosave-in-article)) | 5155 (member keys nosave-in-article)) |
3844 (let (func) | 5156 (let (func) |
3845 (save-window-excursion | 5157 (save-window-excursion |
3846 (pop-to-buffer gnus-article-current-summary 'norecord) | 5158 (pop-to-buffer gnus-article-current-summary 'norecord) |
3847 ;; We disable the pick minor mode commands. | 5159 ;; We disable the pick minor mode commands. |
3848 (let (gnus-pick-mode) | 5160 (let (gnus-pick-mode) |
3849 (setq func (lookup-key (current-local-map) keys)))) | 5161 (setq func (lookup-key (current-local-map) keys)))) |
3850 (if (or (not func) | 5162 (if (or (not func) |
3851 (numberp func)) | 5163 (numberp func)) |
3852 (ding) | 5164 (ding) |
3853 (unless (member keys nosave-in-article) | 5165 (unless (member keys nosave-in-article) |
3854 (set-buffer gnus-article-current-summary)) | 5166 (set-buffer gnus-article-current-summary)) |
3855 (call-interactively func) | 5167 (call-interactively func) |
3856 (setq new-sum-point (point))) | 5168 (setq new-sum-point (point))) |
3857 (when (member keys nosave-but-article) | 5169 (when (member keys nosave-but-article) |
3858 (pop-to-buffer gnus-article-buffer 'norecord))) | 5170 (pop-to-buffer gnus-article-buffer 'norecord))) |
3859 ;; These commands should restore window configuration. | 5171 ;; These commands should restore window configuration. |
3860 (let ((obuf (current-buffer)) | 5172 (let ((obuf (current-buffer)) |
3861 (owin (current-window-configuration)) | 5173 (owin (current-window-configuration)) |
3862 (opoint (point)) | 5174 (opoint (point)) |
3863 (summary gnus-article-current-summary) | 5175 (summary gnus-article-current-summary) |
3864 func in-buffer selected) | 5176 func in-buffer selected) |
3865 (if not-restore-window | 5177 (if not-restore-window |
3866 (pop-to-buffer summary 'norecord) | 5178 (pop-to-buffer summary 'norecord) |
3867 (switch-to-buffer summary 'norecord)) | 5179 (switch-to-buffer summary 'norecord)) |
3868 (setq in-buffer (current-buffer)) | 5180 (setq in-buffer (current-buffer)) |
3869 ;; We disable the pick minor mode commands. | 5181 ;; We disable the pick minor mode commands. |
3870 (if (and (setq func (let (gnus-pick-mode) | 5182 (if (and (setq func (let (gnus-pick-mode) |
3871 (lookup-key (current-local-map) keys))) | 5183 (lookup-key (current-local-map) keys))) |
3872 (functionp func)) | 5184 (functionp func)) |
3873 (progn | 5185 (progn |
3874 (call-interactively func) | 5186 (call-interactively func) |
3875 (setq new-sum-point (point)) | 5187 (setq new-sum-point (point)) |
3876 (when (eq in-buffer (current-buffer)) | 5188 (when (eq in-buffer (current-buffer)) |
3877 (setq selected (gnus-summary-select-article)) | 5189 (setq selected (gnus-summary-select-article)) |
3878 (set-buffer obuf) | 5190 (set-buffer obuf) |
3879 (unless not-restore-window | 5191 (unless not-restore-window |
3880 (set-window-configuration owin)) | 5192 (set-window-configuration owin)) |
3886 (point))) | 5198 (point))) |
3887 (let ((win (get-buffer-window gnus-article-current-summary))) | 5199 (let ((win (get-buffer-window gnus-article-current-summary))) |
3888 (when win | 5200 (when win |
3889 (set-window-point win new-sum-point)))) ) | 5201 (set-window-point win new-sum-point)))) ) |
3890 (switch-to-buffer gnus-article-buffer) | 5202 (switch-to-buffer gnus-article-buffer) |
3891 (ding)))))) | 5203 (ding)))))) |
3892 | 5204 |
3893 (defun gnus-article-describe-key (key) | 5205 (defun gnus-article-describe-key (key) |
3894 "Display documentation of the function invoked by KEY. KEY is a string." | 5206 "Display documentation of the function invoked by KEY. KEY is a string." |
3895 (interactive "kDescribe key: ") | 5207 (interactive "kDescribe key: ") |
3896 (gnus-article-check-buffer) | 5208 (gnus-article-check-buffer) |
3897 (if (eq (key-binding key) 'gnus-article-read-summary-keys) | 5209 (if (eq (key-binding key) 'gnus-article-read-summary-keys) |
3898 (save-excursion | 5210 (save-excursion |
3899 (set-buffer gnus-article-current-summary) | 5211 (set-buffer gnus-article-current-summary) |
3900 (let (gnus-pick-mode) | 5212 (let (gnus-pick-mode) |
3901 (push (elt key 0) unread-command-events) | 5213 (if (featurep 'xemacs) |
3902 (setq key (if (featurep 'xemacs) | 5214 (progn |
3903 (events-to-keys (read-key-sequence "Describe key: ")) | 5215 (push (elt key 0) unread-command-events) |
3904 (read-key-sequence "Describe key: ")))) | 5216 (setq key (events-to-keys |
5217 (read-key-sequence "Describe key: ")))) | |
5218 (setq unread-command-events | |
5219 (mapcar | |
5220 (lambda (x) (if (>= x 128) (list 'meta (- x 128)) x)) | |
5221 (string-to-list key))) | |
5222 (setq key (read-key-sequence "Describe key: ")))) | |
3905 (describe-key key)) | 5223 (describe-key key)) |
3906 (describe-key key))) | 5224 (describe-key key))) |
3907 | 5225 |
3908 (defun gnus-article-describe-key-briefly (key &optional insert) | 5226 (defun gnus-article-describe-key-briefly (key &optional insert) |
3909 "Display documentation of the function invoked by KEY. KEY is a string." | 5227 "Display documentation of the function invoked by KEY. KEY is a string." |
3911 (gnus-article-check-buffer) | 5229 (gnus-article-check-buffer) |
3912 (if (eq (key-binding key) 'gnus-article-read-summary-keys) | 5230 (if (eq (key-binding key) 'gnus-article-read-summary-keys) |
3913 (save-excursion | 5231 (save-excursion |
3914 (set-buffer gnus-article-current-summary) | 5232 (set-buffer gnus-article-current-summary) |
3915 (let (gnus-pick-mode) | 5233 (let (gnus-pick-mode) |
3916 (push (elt key 0) unread-command-events) | 5234 (if (featurep 'xemacs) |
3917 (setq key (if (featurep 'xemacs) | 5235 (progn |
3918 (events-to-keys (read-key-sequence "Describe key: ")) | 5236 (push (elt key 0) unread-command-events) |
3919 (read-key-sequence "Describe key: ")))) | 5237 (setq key (events-to-keys |
5238 (read-key-sequence "Describe key: ")))) | |
5239 (setq unread-command-events | |
5240 (mapcar | |
5241 (lambda (x) (if (>= x 128) (list 'meta (- x 128)) x)) | |
5242 (string-to-list key))) | |
5243 (setq key (read-key-sequence "Describe key: ")))) | |
3920 (describe-key-briefly key insert)) | 5244 (describe-key-briefly key insert)) |
3921 (describe-key-briefly key insert))) | 5245 (describe-key-briefly key insert))) |
3922 | 5246 |
5247 (defun gnus-article-reply-with-original (&optional wide) | |
5248 "Start composing a reply mail to the current message. | |
5249 The text in the region will be yanked. If the region isn't active, | |
5250 the entire article will be yanked." | |
5251 (interactive "P") | |
5252 (let ((article (cdr gnus-article-current)) | |
5253 contents) | |
5254 (if (not (gnus-mark-active-p)) | |
5255 (with-current-buffer gnus-summary-buffer | |
5256 (gnus-summary-reply (list (list article)) wide)) | |
5257 (setq contents (buffer-substring (point) (mark t))) | |
5258 ;; Deactivate active regions. | |
5259 (when (and (boundp 'transient-mark-mode) | |
5260 transient-mark-mode) | |
5261 (setq mark-active nil)) | |
5262 (with-current-buffer gnus-summary-buffer | |
5263 (gnus-summary-reply | |
5264 (list (list article contents)) wide))))) | |
5265 | |
5266 (defun gnus-article-followup-with-original () | |
5267 "Compose a followup to the current article. | |
5268 The text in the region will be yanked. If the region isn't active, | |
5269 the entire article will be yanked." | |
5270 (interactive) | |
5271 (let ((article (cdr gnus-article-current)) | |
5272 contents) | |
5273 (if (not (gnus-mark-active-p)) | |
5274 (with-current-buffer gnus-summary-buffer | |
5275 (gnus-summary-followup (list (list article)))) | |
5276 (setq contents (buffer-substring (point) (mark t))) | |
5277 ;; Deactivate active regions. | |
5278 (when (and (boundp 'transient-mark-mode) | |
5279 transient-mark-mode) | |
5280 (setq mark-active nil)) | |
5281 (with-current-buffer gnus-summary-buffer | |
5282 (gnus-summary-followup | |
5283 (list (list article contents))))))) | |
5284 | |
3923 (defun gnus-article-hide (&optional arg force) | 5285 (defun gnus-article-hide (&optional arg force) |
3924 "Hide all the gruft in the current article. | 5286 "Hide all the gruft in the current article. |
3925 This means that PGP stuff, signatures, cited text and (some) | 5287 This means that signatures, cited text and (some) headers will be |
3926 headers will be hidden. | 5288 hidden. |
3927 If given a prefix, show the hidden text instead." | 5289 If given a prefix, show the hidden text instead." |
3928 (interactive (append (gnus-article-hidden-arg) (list 'force))) | 5290 (interactive (append (gnus-article-hidden-arg) (list 'force))) |
3929 (gnus-article-hide-headers arg) | 5291 (gnus-article-hide-headers arg) |
3930 (gnus-article-hide-list-identifiers arg) | 5292 (gnus-article-hide-list-identifiers arg) |
3931 (gnus-article-hide-pgp arg) | |
3932 (gnus-article-hide-citation-maybe arg force) | 5293 (gnus-article-hide-citation-maybe arg force) |
3933 (gnus-article-hide-signature arg)) | 5294 (gnus-article-hide-signature arg)) |
3934 | 5295 |
3935 (defun gnus-article-maybe-highlight () | 5296 (defun gnus-article-maybe-highlight () |
3936 "Do some article highlighting if article highlighting is requested." | 5297 "Do some article highlighting if article highlighting is requested." |
3941 ;; Make sure the connection to the server is alive. | 5302 ;; Make sure the connection to the server is alive. |
3942 (unless (gnus-server-opened | 5303 (unless (gnus-server-opened |
3943 (gnus-find-method-for-group gnus-newsgroup-name)) | 5304 (gnus-find-method-for-group gnus-newsgroup-name)) |
3944 (gnus-check-server (gnus-find-method-for-group gnus-newsgroup-name)) | 5305 (gnus-check-server (gnus-find-method-for-group gnus-newsgroup-name)) |
3945 (gnus-request-group gnus-newsgroup-name t))) | 5306 (gnus-request-group gnus-newsgroup-name t))) |
5307 | |
5308 (eval-when-compile | |
5309 (autoload 'nneething-get-file-name "nneething")) | |
3946 | 5310 |
3947 (defun gnus-request-article-this-buffer (article group) | 5311 (defun gnus-request-article-this-buffer (article group) |
3948 "Get an article and insert it into this buffer." | 5312 "Get an article and insert it into this buffer." |
3949 (let (do-update-line sparse-header) | 5313 (let (do-update-line sparse-header) |
3950 (prog1 | 5314 (prog1 |
3991 | 5355 |
3992 (let ((method (gnus-find-method-for-group | 5356 (let ((method (gnus-find-method-for-group |
3993 gnus-newsgroup-name))) | 5357 gnus-newsgroup-name))) |
3994 (when (and (eq (car method) 'nneething) | 5358 (when (and (eq (car method) 'nneething) |
3995 (vectorp header)) | 5359 (vectorp header)) |
3996 (let ((dir (expand-file-name | 5360 (let ((dir (nneething-get-file-name |
3997 (mail-header-subject header) | 5361 (mail-header-id header)))) |
3998 (file-name-as-directory | 5362 (when (and (stringp dir) |
3999 (or (cadr (assq 'nneething-address method)) | 5363 (file-directory-p dir)) |
4000 (nth 1 method)))))) | |
4001 (when (file-directory-p dir) | |
4002 (setq article 'nneething) | 5364 (setq article 'nneething) |
4003 (gnus-group-enter-directory dir)))))))) | 5365 (gnus-group-enter-directory dir)))))))) |
4004 | 5366 |
4005 (cond | 5367 (cond |
4006 ;; Refuse to select canceled articles. | 5368 ;; Refuse to select canceled articles. |
4035 ;; Check the cache. | 5397 ;; Check the cache. |
4036 ((and gnus-use-cache | 5398 ((and gnus-use-cache |
4037 (numberp article) | 5399 (numberp article) |
4038 (gnus-cache-request-article article group)) | 5400 (gnus-cache-request-article article group)) |
4039 'article) | 5401 'article) |
5402 ;; Check the agent cache. | |
5403 ((gnus-agent-request-article article group) | |
5404 'article) | |
4040 ;; Get the article and put into the article buffer. | 5405 ;; Get the article and put into the article buffer. |
4041 ((or (stringp article) | 5406 ((or (stringp article) |
4042 (numberp article)) | 5407 (numberp article)) |
4043 (let ((gnus-override-method gnus-override-method) | 5408 (let ((gnus-override-method gnus-override-method) |
4044 (methods (and (stringp article) | 5409 (methods (and (stringp article) |
4045 gnus-refer-article-method)) | 5410 gnus-refer-article-method)) |
5411 (backend (car (gnus-find-method-for-group | |
5412 gnus-newsgroup-name))) | |
4046 result | 5413 result |
4047 (inhibit-read-only t)) | 5414 (buffer-read-only nil)) |
4048 (if (or (not (listp methods)) | 5415 (if (or (not (listp methods)) |
4049 (and (symbolp (car methods)) | 5416 (and (symbolp (car methods)) |
4050 (assq (car methods) nnoo-definition-alist))) | 5417 (assq (car methods) nnoo-definition-alist))) |
4051 (setq methods (list methods))) | 5418 (setq methods (list methods))) |
4052 (when (and (null gnus-override-method) | 5419 (when (and (null gnus-override-method) |
4059 gnus-current-select-method))) | 5426 gnus-current-select-method))) |
4060 (erase-buffer) | 5427 (erase-buffer) |
4061 (gnus-kill-all-overlays) | 5428 (gnus-kill-all-overlays) |
4062 (let ((gnus-newsgroup-name group)) | 5429 (let ((gnus-newsgroup-name group)) |
4063 (gnus-check-group-server)) | 5430 (gnus-check-group-server)) |
4064 (when (gnus-request-article article group (current-buffer)) | 5431 (cond |
5432 ((gnus-request-article article group (current-buffer)) | |
4065 (when (numberp article) | 5433 (when (numberp article) |
4066 (gnus-async-prefetch-next group article | 5434 (gnus-async-prefetch-next group article |
4067 gnus-summary-buffer) | 5435 gnus-summary-buffer) |
4068 (when gnus-keep-backlog | 5436 (when gnus-keep-backlog |
4069 (gnus-backlog-enter-article | 5437 (gnus-backlog-enter-article |
4070 group article (current-buffer)))) | 5438 group article (current-buffer)))) |
4071 (setq result 'article)) | 5439 (setq result 'article)) |
4072 (if (not result) | 5440 (methods |
4073 (if methods | 5441 (setq gnus-override-method (pop methods))) |
4074 (setq gnus-override-method (pop methods)) | 5442 ((not (string-match "^400 " |
4075 (setq result 'done)))) | 5443 (nnheader-get-report backend))) |
5444 ;; If we get 400 server disconnect, reconnect and | |
5445 ;; retry; otherwise, assume the article has expired. | |
5446 (setq result 'done)))) | |
4076 (and (eq result 'article) 'article))) | 5447 (and (eq result 'article) 'article))) |
4077 ;; It was a pseudo. | 5448 ;; It was a pseudo. |
4078 (t article))) | 5449 (t article))) |
4079 | 5450 |
4080 ;; Associate this article with the current summary buffer. | 5451 ;; Associate this article with the current summary buffer. |
4108 (stringp article))) | 5479 (stringp article))) |
4109 (let ((buf (current-buffer))) | 5480 (let ((buf (current-buffer))) |
4110 (set-buffer gnus-summary-buffer) | 5481 (set-buffer gnus-summary-buffer) |
4111 (gnus-summary-update-article do-update-line sparse-header) | 5482 (gnus-summary-update-article do-update-line sparse-header) |
4112 (gnus-summary-goto-subject do-update-line nil t) | 5483 (gnus-summary-goto-subject do-update-line nil t) |
4113 (set-window-point (get-buffer-window (current-buffer) t) | 5484 (set-window-point (gnus-get-buffer-window (current-buffer) t) |
4114 (point)) | 5485 (point)) |
4115 (set-buffer buf)))))) | 5486 (set-buffer buf)))))) |
4116 | 5487 |
4117 ;;; | 5488 ;;; |
4118 ;;; Article editing | 5489 ;;; Article editing |
4124 :type 'hook) | 5495 :type 'hook) |
4125 | 5496 |
4126 (defvar gnus-article-edit-done-function nil) | 5497 (defvar gnus-article-edit-done-function nil) |
4127 | 5498 |
4128 (defvar gnus-article-edit-mode-map nil) | 5499 (defvar gnus-article-edit-mode-map nil) |
5500 (defvar gnus-article-edit-mode nil) | |
4129 | 5501 |
4130 ;; Should we be using derived.el for this? | 5502 ;; Should we be using derived.el for this? |
4131 (unless gnus-article-edit-mode-map | 5503 (unless gnus-article-edit-mode-map |
4132 (setq gnus-article-edit-mode-map (make-sparse-keymap)) | 5504 (setq gnus-article-edit-mode-map (make-keymap)) |
4133 (set-keymap-parent gnus-article-edit-mode-map text-mode-map) | 5505 (set-keymap-parent gnus-article-edit-mode-map text-mode-map) |
4134 | 5506 |
4135 (gnus-define-keys gnus-article-edit-mode-map | 5507 (gnus-define-keys gnus-article-edit-mode-map |
5508 "\C-c?" describe-mode | |
4136 "\C-c\C-c" gnus-article-edit-done | 5509 "\C-c\C-c" gnus-article-edit-done |
4137 "\C-c\C-k" gnus-article-edit-exit) | 5510 "\C-c\C-k" gnus-article-edit-exit |
5511 "\C-c\C-f\C-t" message-goto-to | |
5512 "\C-c\C-f\C-o" message-goto-from | |
5513 "\C-c\C-f\C-b" message-goto-bcc | |
5514 ;;"\C-c\C-f\C-w" message-goto-fcc | |
5515 "\C-c\C-f\C-c" message-goto-cc | |
5516 "\C-c\C-f\C-s" message-goto-subject | |
5517 "\C-c\C-f\C-r" message-goto-reply-to | |
5518 "\C-c\C-f\C-n" message-goto-newsgroups | |
5519 "\C-c\C-f\C-d" message-goto-distribution | |
5520 "\C-c\C-f\C-f" message-goto-followup-to | |
5521 "\C-c\C-f\C-m" message-goto-mail-followup-to | |
5522 "\C-c\C-f\C-k" message-goto-keywords | |
5523 "\C-c\C-f\C-u" message-goto-summary | |
5524 "\C-c\C-f\C-i" message-insert-or-toggle-importance | |
5525 "\C-c\C-f\C-a" message-generate-unsubscribed-mail-followup-to | |
5526 "\C-c\C-b" message-goto-body | |
5527 "\C-c\C-i" message-goto-signature | |
5528 | |
5529 "\C-c\C-t" message-insert-to | |
5530 "\C-c\C-n" message-insert-newsgroups | |
5531 "\C-c\C-o" message-sort-headers | |
5532 "\C-c\C-e" message-elide-region | |
5533 "\C-c\C-v" message-delete-not-region | |
5534 "\C-c\C-z" message-kill-to-signature | |
5535 "\M-\r" message-newline-and-reformat | |
5536 "\C-c\C-a" mml-attach-file | |
5537 "\C-a" message-beginning-of-line | |
5538 "\t" message-tab | |
5539 "\M-;" comment-region) | |
4138 | 5540 |
4139 (gnus-define-keys (gnus-article-edit-wash-map | 5541 (gnus-define-keys (gnus-article-edit-wash-map |
4140 "\C-c\C-w" gnus-article-edit-mode-map) | 5542 "\C-c\C-w" gnus-article-edit-mode-map) |
4141 "f" gnus-article-edit-full-stops)) | 5543 "f" gnus-article-edit-full-stops)) |
4142 | 5544 |
4143 (define-derived-mode gnus-article-edit-mode message-mode "Article Edit" | 5545 (easy-menu-define |
5546 gnus-article-edit-mode-field-menu gnus-article-edit-mode-map "" | |
5547 '("Field" | |
5548 ["Fetch To" message-insert-to t] | |
5549 ["Fetch Newsgroups" message-insert-newsgroups t] | |
5550 "----" | |
5551 ["To" message-goto-to t] | |
5552 ["From" message-goto-from t] | |
5553 ["Subject" message-goto-subject t] | |
5554 ["Cc" message-goto-cc t] | |
5555 ["Reply-To" message-goto-reply-to t] | |
5556 ["Summary" message-goto-summary t] | |
5557 ["Keywords" message-goto-keywords t] | |
5558 ["Newsgroups" message-goto-newsgroups t] | |
5559 ["Followup-To" message-goto-followup-to t] | |
5560 ["Mail-Followup-To" message-goto-mail-followup-to t] | |
5561 ["Distribution" message-goto-distribution t] | |
5562 ["Body" message-goto-body t] | |
5563 ["Signature" message-goto-signature t])) | |
5564 | |
5565 (define-derived-mode gnus-article-edit-mode text-mode "Article Edit" | |
4144 "Major mode for editing articles. | 5566 "Major mode for editing articles. |
4145 This is an extended text-mode. | 5567 This is an extended text-mode. |
4146 | 5568 |
4147 \\{gnus-article-edit-mode-map}" | 5569 \\{gnus-article-edit-mode-map}" |
4148 (make-local-variable 'gnus-article-edit-done-function) | 5570 (make-local-variable 'gnus-article-edit-done-function) |
4149 (make-local-variable 'gnus-prev-winconf) | 5571 (make-local-variable 'gnus-prev-winconf) |
4150 (set (make-local-variable 'font-lock-defaults) | 5572 (set (make-local-variable 'font-lock-defaults) |
4151 '(message-font-lock-keywords t)) | 5573 '(message-font-lock-keywords t)) |
5574 (set (make-local-variable 'mail-header-separator) "") | |
5575 (set (make-local-variable 'gnus-article-edit-mode) t) | |
5576 (easy-menu-add message-mode-field-menu message-mode-map) | |
5577 (mml-mode) | |
4152 (setq buffer-read-only nil) | 5578 (setq buffer-read-only nil) |
4153 (buffer-enable-undo) | 5579 (buffer-enable-undo) |
4154 (widen)) | 5580 (widen)) |
4155 | 5581 |
4156 (defun gnus-article-edit (&optional force) | 5582 (defun gnus-article-edit (&optional force) |
4175 "Start editing the contents of the current article buffer." | 5601 "Start editing the contents of the current article buffer." |
4176 (let ((winconf (current-window-configuration))) | 5602 (let ((winconf (current-window-configuration))) |
4177 (set-buffer gnus-article-buffer) | 5603 (set-buffer gnus-article-buffer) |
4178 (gnus-article-edit-mode) | 5604 (gnus-article-edit-mode) |
4179 (funcall start-func) | 5605 (funcall start-func) |
5606 (set-buffer-modified-p nil) | |
4180 (gnus-configure-windows 'edit-article) | 5607 (gnus-configure-windows 'edit-article) |
4181 (setq gnus-article-edit-done-function exit-func) | 5608 (setq gnus-article-edit-done-function exit-func) |
4182 (setq gnus-prev-winconf winconf) | 5609 (setq gnus-prev-winconf winconf) |
4183 (gnus-message 6 "C-c C-c to end edits"))) | 5610 (gnus-message 6 "C-c C-c to end edits"))) |
4184 | 5611 |
4185 (defun gnus-article-edit-done (&optional arg) | 5612 (defun gnus-article-edit-done (&optional arg) |
4186 "Update the article edits and exit." | 5613 "Update the article edits and exit." |
4187 (interactive "P") | 5614 (interactive "P") |
4188 (widen) | |
4189 (save-excursion | |
4190 (save-restriction | |
4191 (when (article-goto-body) | |
4192 (let ((lines (count-lines (point) (point-max))) | |
4193 (length (- (point-max) (point))) | |
4194 (case-fold-search t) | |
4195 (body (copy-marker (point)))) | |
4196 (goto-char (point-min)) | |
4197 (when (re-search-forward "^content-length:[ \t]\\([0-9]+\\)" body t) | |
4198 (delete-region (match-beginning 1) (match-end 1)) | |
4199 (insert (number-to-string length))) | |
4200 (goto-char (point-min)) | |
4201 (when (re-search-forward | |
4202 "^x-content-length:[ \t]\\([0-9]+\\)" body t) | |
4203 (delete-region (match-beginning 1) (match-end 1)) | |
4204 (insert (number-to-string length))) | |
4205 (goto-char (point-min)) | |
4206 (when (re-search-forward "^lines:[ \t]\\([0-9]+\\)" body t) | |
4207 (delete-region (match-beginning 1) (match-end 1)) | |
4208 (insert (number-to-string lines))))))) | |
4209 (let ((func gnus-article-edit-done-function) | 5615 (let ((func gnus-article-edit-done-function) |
4210 (buf (current-buffer)) | 5616 (buf (current-buffer)) |
4211 (start (window-start))) | 5617 (start (window-start)) |
4212 (gnus-article-edit-exit) | 5618 (p (point)) |
5619 (winconf gnus-prev-winconf)) | |
5620 (widen) ;; Widen it in case that users narrowed the buffer. | |
5621 (funcall func arg) | |
5622 (set-buffer buf) | |
5623 ;; The cache and backlog have to be flushed somewhat. | |
5624 (when gnus-keep-backlog | |
5625 (gnus-backlog-remove-article | |
5626 (car gnus-article-current) (cdr gnus-article-current))) | |
5627 ;; Flush original article as well. | |
4213 (save-excursion | 5628 (save-excursion |
4214 (set-buffer buf) | 5629 (when (get-buffer gnus-original-article-buffer) |
4215 (let ((inhibit-read-only t)) | 5630 (set-buffer gnus-original-article-buffer) |
4216 (funcall func arg)) | 5631 (setq gnus-original-article nil))) |
4217 ;; The cache and backlog have to be flushed somewhat. | 5632 (when gnus-use-cache |
4218 (when gnus-keep-backlog | 5633 (gnus-cache-update-article |
4219 (gnus-backlog-remove-article | 5634 (car gnus-article-current) (cdr gnus-article-current))) |
4220 (car gnus-article-current) (cdr gnus-article-current))) | 5635 ;; We remove all text props from the article buffer. |
4221 ;; Flush original article as well. | 5636 (kill-all-local-variables) |
4222 (save-excursion | 5637 (gnus-set-text-properties (point-min) (point-max) nil) |
4223 (when (get-buffer gnus-original-article-buffer) | 5638 (gnus-article-mode) |
4224 (set-buffer gnus-original-article-buffer) | 5639 (set-window-configuration winconf) |
4225 (setq gnus-original-article nil))) | |
4226 (when gnus-use-cache | |
4227 (gnus-cache-update-article | |
4228 (car gnus-article-current) (cdr gnus-article-current)))) | |
4229 (set-buffer buf) | 5640 (set-buffer buf) |
4230 (set-window-start (get-buffer-window buf) start) | 5641 (set-window-start (get-buffer-window buf) start) |
4231 (set-window-point (get-buffer-window buf) (point)))) | 5642 (set-window-point (get-buffer-window buf) (point))) |
5643 (gnus-summary-show-article)) | |
4232 | 5644 |
4233 (defun gnus-article-edit-exit () | 5645 (defun gnus-article-edit-exit () |
4234 "Exit the article editing without updating." | 5646 "Exit the article editing without updating." |
4235 (interactive) | 5647 (interactive) |
4236 ;; We remove all text props from the article buffer. | 5648 (when (or (not (buffer-modified-p)) |
4237 (let ((buf (buffer-substring-no-properties (point-min) (point-max))) | 5649 (yes-or-no-p "Article modified; kill anyway? ")) |
4238 (curbuf (current-buffer)) | 5650 (let ((curbuf (current-buffer)) |
4239 (p (point)) | 5651 (p (point)) |
4240 (window-start (window-start))) | 5652 (window-start (window-start))) |
4241 (erase-buffer) | 5653 (erase-buffer) |
4242 (insert buf) | 5654 (if (gnus-buffer-live-p gnus-original-article-buffer) |
4243 (let ((winconf gnus-prev-winconf)) | 5655 (insert-buffer gnus-original-article-buffer)) |
4244 (gnus-article-mode) | 5656 (let ((winconf gnus-prev-winconf)) |
4245 (set-window-configuration winconf) | 5657 (kill-all-local-variables) |
4246 ;; Tippy-toe some to make sure that point remains where it was. | 5658 (gnus-article-mode) |
4247 (save-current-buffer | 5659 (set-window-configuration winconf) |
4248 (set-buffer curbuf) | 5660 ;; Tippy-toe some to make sure that point remains where it was. |
4249 (set-window-start (get-buffer-window (current-buffer)) window-start) | 5661 (save-current-buffer |
4250 (goto-char p))))) | 5662 (set-buffer curbuf) |
5663 (set-window-start (get-buffer-window (current-buffer)) window-start) | |
5664 (goto-char p)))) | |
5665 (gnus-summary-show-article))) | |
4251 | 5666 |
4252 (defun gnus-article-edit-full-stops () | 5667 (defun gnus-article-edit-full-stops () |
4253 "Interactively repair spacing at end of sentences." | 5668 "Interactively repair spacing at end of sentences." |
4254 (interactive) | 5669 (interactive) |
4255 (save-excursion | 5670 (save-excursion |
4266 | 5681 |
4267 ;;; Internal Variables: | 5682 ;;; Internal Variables: |
4268 | 5683 |
4269 (defcustom gnus-button-url-regexp | 5684 (defcustom gnus-button-url-regexp |
4270 (if (string-match "[[:digit:]]" "1") ;; support POSIX? | 5685 (if (string-match "[[:digit:]]" "1") ;; support POSIX? |
4271 "\\b\\(\\(www\\.\\|\\(s?https?\\|ftp\\|file\\|gopher\\|news\\|telnet\\|wais\\|mailto\\|info\\):\\)\\(//[-a-zA-Z0-9_.]+:[0-9]*\\)?[-a-zA-Z0-9_=!?#$@~`%&*+|\\/:;.,[:word:]]+[-a-zA-Z0-9_=#$@~`%&*+|\\/[:word:]]\\)" | 5686 "\\b\\(\\(www\\.\\|\\(s?https?\\|ftp\\|file\\|gopher\\|nntp\\|news\\|telnet\\|wais\\|mailto\\|info\\):\\)\\(//[-a-z0-9_.]+:[0-9]*\\)?[-a-z0-9_=!?#$@~%&*+\\/:;.,[:word:]]+[-a-z0-9_=#$@~%&*+\\/[:word:]]\\)" |
4272 "\\b\\(\\(www\\.\\|\\(s?https?\\|ftp\\|file\\|gopher\\|news\\|telnet\\|wais\\|mailto\\|info\\):\\)\\(//[-a-zA-Z0-9_.]+:[0-9]*\\)?\\([-a-zA-Z0-9_=!?#$@~`%&*+|\\/:;.,]\\|\\w\\)+\\([-a-zA-Z0-9_=#$@~`%&*+|\\/]\\|\\w\\)\\)") | 5687 "\\b\\(\\(www\\.\\|\\(s?https?\\|ftp\\|file\\|gopher\\|nntp\\|news\\|telnet\\|wais\\|mailto\\|info\\):\\)\\(//[-a-z0-9_.]+:[0-9]*\\)?\\([-a-z0-9_=!?#$@~%&*+\\/:;.,]\\|\\w\\)+\\([-a-z0-9_=#$@~%&*+\\/]\\|\\w\\)\\)") |
4273 "Regular expression that matches URLs." | 5688 "Regular expression that matches URLs." |
4274 :group 'gnus-article-buttons | 5689 :group 'gnus-article-buttons |
4275 :type 'regexp) | 5690 :type 'regexp) |
4276 | 5691 |
5692 (defcustom gnus-button-valid-fqdn-regexp | |
5693 message-valid-fqdn-regexp | |
5694 "Regular expression that matches a valid FQDN." | |
5695 :group 'gnus-article-buttons | |
5696 :type 'regexp) | |
5697 | |
5698 (defcustom gnus-button-man-handler 'manual-entry | |
5699 "Function to use for displaying man pages. | |
5700 The function must take at least one argument with a string naming the | |
5701 man page." | |
5702 :type '(choice (function-item :tag "Man" manual-entry) | |
5703 (function-item :tag "Woman" woman) | |
5704 (function :tag "Other")) | |
5705 :group 'gnus-article-buttons) | |
5706 | |
5707 (defcustom gnus-ctan-url "http://tug.ctan.org/tex-archive/" | |
5708 "Top directory of a CTAN \(Comprehensive TeX Archive Network\) archive. | |
5709 If the default site is too slow, try to find a CTAN mirror, see | |
5710 <URL:http://tug.ctan.org/tex-archive/CTAN.sites?action=/index.html>. See also | |
5711 the variable `gnus-button-handle-ctan'." | |
5712 :group 'gnus-article-buttons | |
5713 :link '(custom-manual "(gnus)Group Parameters") | |
5714 :type '(choice (const "http://www.tex.ac.uk/tex-archive/") | |
5715 (const "http://tug.ctan.org/tex-archive/") | |
5716 (const "http://www.dante.de/CTAN/") | |
5717 (string :tag "Other"))) | |
5718 | |
5719 (defcustom gnus-button-ctan-handler 'browse-url | |
5720 "Function to use for displaying CTAN links. | |
5721 The function must take one argument, the string naming the URL." | |
5722 :type '(choice (function-item :tag "Browse Url" browse-url) | |
5723 (function :tag "Other")) | |
5724 :group 'gnus-article-buttons) | |
5725 | |
5726 (defcustom gnus-button-handle-ctan-bogus-regexp "^/?tex-archive/\\|^/" | |
5727 "Bogus strings removed from CTAN URLs." | |
5728 :group 'gnus-article-buttons | |
5729 :type '(choice (const "^/?tex-archive/\\|/") | |
5730 (regexp :tag "Other"))) | |
5731 | |
5732 (defcustom gnus-button-ctan-directory-regexp | |
5733 (concat | |
5734 "\\("; Cannot use `\(?: ... \)' (compatibility with Emacs 20). | |
5735 "biblio\\|digests\\|dviware\\|fonts\\|graphics\\|help\\|" | |
5736 "indexing\\|info\\|language\\|macros\\|support\\|systems\\|" | |
5737 "tds\\|tools\\|usergrps\\|web\\|nonfree\\|obsolete" | |
5738 "\\)") | |
5739 "Regular expression for ctan directories. | |
5740 It should match all directories in the top level of `gnus-ctan-url'." | |
5741 :group 'gnus-article-buttons | |
5742 :type 'regexp) | |
5743 | |
5744 (defcustom gnus-button-mid-or-mail-regexp | |
5745 (concat "\\b\\(<?[a-z0-9$%(*-=?[_][^<>\")!;:,{}\n\t ]*@" | |
5746 ;; Felix Wiemann in <87oeuomcz9.fsf@news2.ososo.de> | |
5747 gnus-button-valid-fqdn-regexp | |
5748 ">?\\)\\b") | |
5749 "Regular expression that matches a message ID or a mail address." | |
5750 :group 'gnus-article-buttons | |
5751 :type 'regexp) | |
5752 | |
5753 (defcustom gnus-button-prefer-mid-or-mail 'gnus-button-mid-or-mail-heuristic | |
5754 "What to do when the button on a string as \"foo123@bar.invalid\" is pushed. | |
5755 Strings like this can be either a message ID or a mail address. If it is one | |
5756 of the symbols `mid' or `mail', Gnus will always assume that the string is a | |
5757 message ID or a mail address, respectively. If this variable is set to the | |
5758 symbol `ask', always query the user what do do. If it is a function, this | |
5759 function will be called with the string as it's only argument. The function | |
5760 must return `mid', `mail', `invalid' or `ask'." | |
5761 :group 'gnus-article-buttons | |
5762 :type '(choice (function-item :tag "Heuristic function" | |
5763 gnus-button-mid-or-mail-heuristic) | |
5764 (const ask) | |
5765 (const mid) | |
5766 (const mail))) | |
5767 | |
5768 (defcustom gnus-button-mid-or-mail-heuristic-alist | |
5769 '((-10.0 . ".+\\$.+@") | |
5770 (-10.0 . "#") | |
5771 (-10.0 . "\\*") | |
5772 (-5.0 . "\\+[^+]*\\+.*@") ;; # two plus signs | |
5773 (-5.0 . "@[Nn][Ee][Ww][Ss]") ;; /\@news/i | |
5774 (-5.0 . "@.*[Dd][Ii][Aa][Ll][Uu][Pp]") ;; /\@.*dialup/i; | |
5775 (-1.0 . "^[^a-z]+@") | |
5776 ;; | |
5777 (-5.0 . "\\.[0-9][0-9]+.*@") ;; "\.[0-9]{2,}.*\@" | |
5778 (-5.0 . "[a-z].*[A-Z].*[a-z].*[A-Z].*@") ;; "([a-z].*[A-Z].*){2,}\@" | |
5779 (-3.0 . "[A-Z][A-Z][a-z][a-z].*@") | |
5780 (-5.0 . "\\...?.?@") ;; (-5.0 . "\..{1,3}\@") | |
5781 ;; | |
5782 (-2.0 . "^[0-9]") | |
5783 (-1.0 . "^[0-9][0-9]") | |
5784 ;; | |
5785 ;; -3.0 /^[0-9][0-9a-fA-F]{2,2}/; | |
5786 (-3.0 . "^[0-9][0-9a-fA-F][0-9a-fA-F][^0-9a-fA-F]") | |
5787 ;; -5.0 /^[0-9][0-9a-fA-F]{3,3}/; | |
5788 (-5.0 . "^[0-9][0-9a-fA-F][0-9a-fA-F][0-9a-fA-F][^0-9a-fA-F]") | |
5789 ;; | |
5790 (-3.0 . "[0-9][0-9][0-9][0-9][0-9][^0-9].*@") ;; "[0-9]{5,}.*\@" | |
5791 (-3.0 . "[0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][^0-9].*@") | |
5792 ;; "[0-9]{8,}.*\@" | |
5793 (-3.0 | |
5794 . "[0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9].*@") | |
5795 ;; "[0-9]{12,}.*\@" | |
5796 ;; compensation for TDMA dated mail addresses: | |
5797 (25.0 . "-dated-[0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9]+.*@") | |
5798 ;; | |
5799 (-20.0 . "\\.fsf@") ;; Gnus | |
5800 (-20.0 . "^slrn") | |
5801 (-20.0 . "^Pine") | |
5802 (-20.0 . "_-_") ;; Subject change in thread | |
5803 ;; | |
5804 (-20.0 . "\\.ln@") ;; leafnode | |
5805 (-30.0 . "@ID-[0-9]+\\.[a-zA-Z]+\\.dfncis\\.de") | |
5806 (-30.0 . "@4[Aa][Xx]\\.com") ;; Forte Agent | |
5807 ;; | |
5808 ;; (5.0 . "") ;; $local_part_len <= 7 | |
5809 (10.0 . "^[^0-9]+@") | |
5810 (3.0 . "^[^0-9]+[0-9][0-9]?[0-9]?@") | |
5811 ;; ^[^0-9]+[0-9]{1,3}\@ digits only at end of local part | |
5812 (3.0 . "\@stud") | |
5813 ;; | |
5814 (2.0 . "[a-z][a-z][._-][A-Z][a-z].*@") | |
5815 ;; | |
5816 (0.5 . "^[A-Z][a-z]") | |
5817 (0.5 . "^[A-Z][a-z][a-z]") | |
5818 (1.5 . "^[A-Z][a-z][A-Z][a-z][^a-z]") ;; ^[A-Z][a-z]{3,3} | |
5819 (2.0 . "^[A-Z][a-z][A-Z][a-z][a-z][^a-z]")) ;; ^[A-Z][a-z]{4,4} | |
5820 "An alist of \(RATE . REGEXP\) pairs for `gnus-button-mid-or-mail-heuristic'. | |
5821 | |
5822 A negative RATE indicates a message IDs, whereas a positive indicates a mail | |
5823 address. The REGEXP is processed with `case-fold-search' set to nil." | |
5824 :group 'gnus-article-buttons | |
5825 :type '(repeat (cons (number :tag "Rate") | |
5826 (regexp :tag "Regexp")))) | |
5827 | |
5828 (defun gnus-button-mid-or-mail-heuristic (mid-or-mail) | |
5829 "Guess whether MID-OR-MAIL is a message ID or a mail address. | |
5830 Returns `mid' if MID-OR-MAIL is a message IDs, `mail' if it's a mail | |
5831 address, `ask' if unsure and `invalid' if the string is invalid." | |
5832 (let ((case-fold-search nil) | |
5833 (list gnus-button-mid-or-mail-heuristic-alist) | |
5834 (result 0) rate regexp lpartlen elem) | |
5835 (setq lpartlen | |
5836 (length (gnus-replace-in-string mid-or-mail "^\\(.*\\)@.*$" "\\1"))) | |
5837 (gnus-message 8 "`%s', length of local part=`%s'." mid-or-mail lpartlen) | |
5838 ;; Certain special cases... | |
5839 (when (string-match | |
5840 (concat | |
5841 "^0[0-9]+-[0-9][0-9][0-9][0-9]@t-online\\.de$\\|" | |
5842 "^[0-9]+\\.[0-9]+@compuserve\\|" | |
5843 "@public\\.gmane\\.org") | |
5844 mid-or-mail) | |
5845 (gnus-message 8 "`%s' is a known mail address." mid-or-mail) | |
5846 (setq result 'mail)) | |
5847 (when (string-match "@.*@\\| " mid-or-mail) | |
5848 (gnus-message 8 "`%s' is invalid." mid-or-mail) | |
5849 (setq result 'invalid)) | |
5850 ;; Nothing more to do, if result is not a number here... | |
5851 (when (numberp result) | |
5852 (while list | |
5853 (setq elem (car list) | |
5854 rate (car elem) | |
5855 regexp (cdr elem) | |
5856 list (cdr list)) | |
5857 (when (string-match regexp mid-or-mail) | |
5858 (setq result (+ result rate)) | |
5859 (gnus-message | |
5860 9 "`%s' matched `%s', rate `%s', result `%s'." | |
5861 mid-or-mail regexp rate result))) | |
5862 (when (<= lpartlen 7) | |
5863 (setq result (+ result 5.0)) | |
5864 (gnus-message 9 "`%s' matched (<= lpartlen 7), result `%s'." | |
5865 mid-or-mail result)) | |
5866 (when (>= lpartlen 12) | |
5867 (gnus-message 9 "`%s' matched (>= lpartlen 12)" mid-or-mail) | |
5868 (cond | |
5869 ((string-match "[0-9][^0-9]+[0-9].*@" mid-or-mail) | |
5870 ;; Long local part should contain realname if e-mail address, | |
5871 ;; too many digits: message-id. | |
5872 ;; $score -= 5.0 + 0.1 * $local_part_len; | |
5873 (setq rate (* -1.0 (+ 5.0 (* 0.1 lpartlen)))) | |
5874 (setq result (+ result rate)) | |
5875 (gnus-message | |
5876 9 "Many digits in `%s', rate `%s', result `%s'." | |
5877 mid-or-mail rate result)) | |
5878 ((string-match "[^aeiouy][^aeiouy][^aeiouy][^aeiouy]+.*\@" | |
5879 mid-or-mail) | |
5880 ;; Too few vowels [^aeiouy]{4,}.*\@ | |
5881 (setq result (+ result -5.0)) | |
5882 (gnus-message | |
5883 9 "Few vowels in `%s', rate `%s', result `%s'." | |
5884 mid-or-mail -5.0 result)) | |
5885 (t | |
5886 (setq result (+ result 5.0)) | |
5887 (gnus-message | |
5888 9 "`%s', rate `%s', result `%s'." mid-or-mail 5.0 result))))) | |
5889 (gnus-message 8 "`%s': Final rate is `%s'." mid-or-mail result) | |
5890 ;; Maybe we should make this a customizable alist: (condition . 'result) | |
5891 (cond | |
5892 ((symbolp result) result) | |
5893 ;; Now convert number into proper results: | |
5894 ((< result -10.0) 'mid) | |
5895 ((> result 10.0) 'mail) | |
5896 (t 'ask)))) | |
5897 | |
5898 (defun gnus-button-handle-mid-or-mail (mid-or-mail) | |
5899 (let* ((pref gnus-button-prefer-mid-or-mail) guessed | |
5900 (url-mid (concat "news" ":" mid-or-mail)) | |
5901 (url-mailto (concat "mailto" ":" mid-or-mail))) | |
5902 (gnus-message 9 "mid-or-mail=%s" mid-or-mail) | |
5903 (when (fboundp pref) | |
5904 (setq guessed | |
5905 ;; get rid of surrounding angles... | |
5906 (funcall pref | |
5907 (gnus-replace-in-string mid-or-mail "^<\\|>$" ""))) | |
5908 (if (or (eq 'mid guessed) (eq 'mail guessed)) | |
5909 (setq pref guessed) | |
5910 (setq pref 'ask))) | |
5911 (if (eq pref 'ask) | |
5912 (save-window-excursion | |
5913 (if (y-or-n-p (concat "Is <" mid-or-mail "> a mail address? ")) | |
5914 (setq pref 'mail) | |
5915 (setq pref 'mid)))) | |
5916 (cond ((eq pref 'mid) | |
5917 (gnus-message 8 "calling `gnus-button-handle-news' %s" url-mid) | |
5918 (gnus-button-handle-news url-mid)) | |
5919 ((eq pref 'mail) | |
5920 (gnus-message 8 "calling `gnus-url-mailto' %s" url-mailto) | |
5921 (gnus-url-mailto url-mailto)) | |
5922 (t (gnus-message 3 "Invalid string."))))) | |
5923 | |
5924 (defun gnus-button-handle-custom (url) | |
5925 "Follow a Custom URL." | |
5926 (customize-apropos (gnus-url-unhex-string url))) | |
5927 | |
5928 (defvar gnus-button-handle-describe-prefix "^\\(C-h\\|<?[Ff]1>?\\)") | |
5929 | |
5930 ;; FIXME: Maybe we should merge some of the functions that do quite similar | |
5931 ;; stuff? | |
5932 | |
5933 (defun gnus-button-handle-describe-function (url) | |
5934 "Call `describe-function' when pushing the corresponding URL button." | |
5935 (describe-function | |
5936 (intern | |
5937 (gnus-replace-in-string url gnus-button-handle-describe-prefix "")))) | |
5938 | |
5939 (defun gnus-button-handle-describe-variable (url) | |
5940 "Call `describe-variable' when pushing the corresponding URL button." | |
5941 (describe-variable | |
5942 (intern | |
5943 (gnus-replace-in-string url gnus-button-handle-describe-prefix "")))) | |
5944 | |
5945 (defun gnus-button-handle-symbol (url) | |
5946 "Display help on variable or function. | |
5947 Calls `describe-variable' or `describe-function'." | |
5948 (let ((sym (intern url))) | |
5949 (cond | |
5950 ((fboundp sym) (describe-function sym)) | |
5951 ((boundp sym) (describe-variable sym)) | |
5952 (t (gnus-message 3 "`%s' is not a known function of variable." url))))) | |
5953 | |
5954 (defun gnus-button-handle-describe-key (url) | |
5955 "Call `describe-key' when pushing the corresponding URL button." | |
5956 (let* ((key-string | |
5957 (gnus-replace-in-string url gnus-button-handle-describe-prefix "")) | |
5958 (keys (ignore-errors (eval `(kbd ,key-string))))) | |
5959 (if keys | |
5960 (describe-key keys) | |
5961 (gnus-message 3 "Invalid key sequence in button: %s" key-string)))) | |
5962 | |
5963 (defun gnus-button-handle-apropos (url) | |
5964 "Call `apropos' when pushing the corresponding URL button." | |
5965 (apropos (gnus-replace-in-string url gnus-button-handle-describe-prefix ""))) | |
5966 | |
5967 (defun gnus-button-handle-apropos-command (url) | |
5968 "Call `apropos' when pushing the corresponding URL button." | |
5969 (apropos-command | |
5970 (gnus-replace-in-string url gnus-button-handle-describe-prefix ""))) | |
5971 | |
5972 (defun gnus-button-handle-apropos-variable (url) | |
5973 "Call `apropos' when pushing the corresponding URL button." | |
5974 (funcall | |
5975 (if (fboundp 'apropos-variable) 'apropos-variable 'apropos) | |
5976 (gnus-replace-in-string url gnus-button-handle-describe-prefix ""))) | |
5977 | |
5978 (defun gnus-button-handle-apropos-documentation (url) | |
5979 "Call `apropos' when pushing the corresponding URL button." | |
5980 (funcall | |
5981 (if (fboundp 'apropos-documentation) 'apropos-documentation 'apropos) | |
5982 (gnus-replace-in-string url gnus-button-handle-describe-prefix ""))) | |
5983 | |
5984 (defun gnus-button-handle-library (url) | |
5985 "Call `locate-library' when pushing the corresponding URL button." | |
5986 (gnus-message 9 "url=`%s'" url) | |
5987 (let* ((lib (locate-library url)) | |
5988 (file (gnus-replace-in-string (or lib "") "\.elc" ".el"))) | |
5989 (if (not lib) | |
5990 (gnus-message 1 "Cannot locale library `%s'." url) | |
5991 (find-file-read-only file)))) | |
5992 | |
5993 (defun gnus-button-handle-ctan (url) | |
5994 "Call `browse-url' when pushing a CTAN URL button." | |
5995 (funcall | |
5996 gnus-button-ctan-handler | |
5997 (concat | |
5998 gnus-ctan-url | |
5999 (gnus-replace-in-string url gnus-button-handle-ctan-bogus-regexp "")))) | |
6000 | |
6001 (defcustom gnus-button-tex-level 5 | |
6002 "*Integer that says how many TeX-related buttons Gnus will show. | |
6003 The higher the number, the more buttons will appear and the more false | |
6004 positives are possible. Note that you can set this variable local to | |
6005 specific groups. Setting it higher in TeX groups is probably a good idea. | |
6006 See Info node `(gnus)Group Parameters' and the variable `gnus-parameters' on | |
6007 how to set variables in specific groups." | |
6008 :group 'gnus-article-buttons | |
6009 :link '(custom-manual "(gnus)Group Parameters") | |
6010 :type 'integer) | |
6011 | |
6012 (defcustom gnus-button-man-level 5 | |
6013 "*Integer that says how many man-related buttons Gnus will show. | |
6014 The higher the number, the more buttons will appear and the more false | |
6015 positives are possible. Note that you can set this variable local to | |
6016 specific groups. Setting it higher in Unix groups is probably a good idea. | |
6017 See Info node `(gnus)Group Parameters' and the variable `gnus-parameters' on | |
6018 how to set variables in specific groups." | |
6019 :group 'gnus-article-buttons | |
6020 :link '(custom-manual "(gnus)Group Parameters") | |
6021 :type 'integer) | |
6022 | |
6023 (defcustom gnus-button-emacs-level 5 | |
6024 "*Integer that says how many emacs-related buttons Gnus will show. | |
6025 The higher the number, the more buttons will appear and the more false | |
6026 positives are possible. Note that you can set this variable local to | |
6027 specific groups. Setting it higher in Emacs or Gnus related groups is | |
6028 probably a good idea. See Info node `(gnus)Group Parameters' and the variable | |
6029 `gnus-parameters' on how to set variables in specific groups." | |
6030 :group 'gnus-article-buttons | |
6031 :link '(custom-manual "(gnus)Group Parameters") | |
6032 :type 'integer) | |
6033 | |
6034 (defcustom gnus-button-message-level 5 | |
6035 "*Integer that says how many buttons for news or mail messages will appear. | |
6036 The higher the number, the more buttons will appear and the more false | |
6037 positives are possible." | |
6038 ;; mail addresses, MIDs, URLs for news, ... | |
6039 :group 'gnus-article-buttons | |
6040 :type 'integer) | |
6041 | |
6042 (defcustom gnus-button-browse-level 5 | |
6043 "*Integer that says how many buttons for browsing will appear. | |
6044 The higher the number, the more buttons will appear and the more false | |
6045 positives are possible." | |
6046 ;; stuff handled by `browse-url' or `gnus-button-embedded-url' | |
6047 :group 'gnus-article-buttons | |
6048 :type 'integer) | |
6049 | |
4277 (defcustom gnus-button-alist | 6050 (defcustom gnus-button-alist |
4278 `(("<\\(url:[>\n\t ]*?\\)?news:[>\n\t ]*\\([^>\n\t ]*@[^>\n\t ]*\\)>" | 6051 '(("<\\(url:[>\n\t ]*?\\)?\\(nntp\\|news\\):[>\n\t ]*\\([^>\n\t ]*@[^>\n\t ]*\\)>" |
4279 0 t gnus-button-message-id 2) | 6052 0 (>= gnus-button-message-level 0) gnus-button-handle-news 3) |
4280 ("\\bnews:\\([^>\n\t ]*@[^>)!;:,\n\t ]*\\)" 0 t gnus-button-message-id 1) | 6053 ("\\b\\(nntp\\|news\\):\\([^>\n\t ]*@[^>)!;:,\n\t ]*\\)" 0 t |
4281 ("\\(\\b<\\(url:[>\n\t ]*\\)?news:[>\n\t ]*\\(//\\)?\\([^>\n\t ]*\\)>\\)" | 6054 gnus-button-handle-news 2) |
4282 1 t | 6055 ("\\(\\b<\\(url:[>\n\t ]*\\)?\\(nntp\\|news\\):[>\n\t ]*\\(//\\)?\\([^>\n\t ]*\\)>\\)" |
4283 gnus-button-fetch-group 4) | 6056 1 (>= gnus-button-message-level 0) gnus-button-fetch-group 5) |
4284 ("\\bnews:\\(//\\)?\\([^'\">\n\t ]+\\)" 0 t gnus-button-fetch-group 2) | 6057 ("\\b\\(nntp\\|news\\):\\(//\\)?\\([^'\">\n\t ]+\\)" |
4285 ("\\bin\\( +article\\| +message\\)? +\\(<\\([^\n @<>]+@[^\n @<>]+\\)>\\)" 2 | 6058 0 (>= gnus-button-message-level 0) gnus-button-fetch-group 3) |
4286 t gnus-button-message-id 3) | 6059 ;; RFC 2392 (Don't allow `/' in domain part --> CID) |
4287 ("\\(<URL: *\\)mailto: *\\([^> \n\t]+\\)>" 0 t gnus-url-mailto 2) | 6060 ("\\bmid:\\(//\\)?\\([^'\">\n\t ]+@[^'\">\n\t /]+\\)" |
4288 ("mailto:\\([-a-zA-Z.@_+0-9%]+\\)" 0 t gnus-url-mailto 1) | 6061 0 (>= gnus-button-message-level 0) gnus-button-message-id 2) |
4289 ("\\bmailto:\\([^ \n\t]+\\)" 0 t gnus-url-mailto 1) | 6062 ("\\bin\\( +article\\| +message\\)? +\\(<\\([^\n @<>]+@[^\n @<>]+\\)>\\)" |
4290 ;; This is how URLs _should_ be embedded in text... | 6063 2 (>= gnus-button-message-level 0) gnus-button-message-id 3) |
4291 ("<URL: *\\([^<>]*\\)>" 0 t gnus-button-embedded-url 1) | 6064 ("\\(<URL: *\\)mailto: *\\([^> \n\t]+\\)>" |
4292 ;; Info manual references. | 6065 0 (>= gnus-button-message-level 0) gnus-url-mailto 2) |
4293 ("(\\(info\\|Info-goto-node\\)[ \n\t]+\"\\(([^)\"\n]+)[^\"\n]+\\)\")" | 6066 ;; RFC 2368 (The mailto URL scheme) |
4294 0 t Info-goto-node 2) | 6067 ("mailto:\\([-a-z.@_+0-9%=?&]+\\)" |
6068 0 (>= gnus-button-message-level 0) gnus-url-mailto 1) | |
6069 ("\\bmailto:\\([^ \n\t]+\\)" | |
6070 0 (>= gnus-button-message-level 0) gnus-url-mailto 1) | |
6071 ;; CTAN | |
6072 ((concat "\\bCTAN:[ \t\n]?[^>)!;:,'\n\t ]*\\(" | |
6073 gnus-button-ctan-directory-regexp | |
6074 "[^][>)!;:,'\n\t ]+\\)") | |
6075 0 (>= gnus-button-tex-level 1) gnus-button-handle-ctan 1) | |
6076 ((concat "\\btex-archive/\\(" | |
6077 gnus-button-ctan-directory-regexp | |
6078 "/[-_.a-z0-9/]+[-_./a-z0-9]+[/a-z0-9]\\)") | |
6079 1 (>= gnus-button-tex-level 6) gnus-button-handle-ctan 1) | |
6080 ((concat | |
6081 "\\b\\(" | |
6082 gnus-button-ctan-directory-regexp | |
6083 "/[-_.a-z0-9]+/[-_./a-z0-9]+[/a-z0-9]\\)") | |
6084 1 (>= gnus-button-tex-level 8) gnus-button-handle-ctan 1) | |
6085 ;; This is info (home-grown style) <info://foo/bar+baz> | |
6086 ("\\binfo://\\([^'\">\n\t ]+\\)" | |
6087 0 (>= gnus-button-emacs-level 1) gnus-button-handle-info-url 1) | |
6088 ;; Info GNOME style <info:foo#bar_baz> | |
6089 ("\\binfo:\\([^('\n\t\r \"><][^'\n\t\r \"><]*\\)" | |
6090 0 (>= gnus-button-emacs-level 1) gnus-button-handle-info-url-gnome 1) | |
6091 ;; Info KDE style <info:(foo)bar baz> | |
6092 ("<\\(info:\\(([^)]+)[^>\n\r]*\\)\\)>" | |
6093 1 (>= gnus-button-emacs-level 1) gnus-button-handle-info-url-kde 2) | |
6094 ("\\((Info-goto-node\\|(info\\)[ \t\n]*\\(\"[^\"]*\"\\))" 0 | |
6095 (>= gnus-button-emacs-level 1) gnus-button-handle-info-url 2) | |
6096 ("\\b\\(C-h\\|<?[Ff]1>?\\)[ \t\n]+i[ \t\n]+d?[ \t\n]?m[ \t\n]+\\([^ ]+ ?[^ ]+\\)[ \t\n]+RET" | |
6097 ;; Info links like `C-h i d m CC Mode RET' | |
6098 0 (>= gnus-button-emacs-level 1) gnus-button-handle-info-keystrokes 2) | |
6099 ;; This is custom | |
6100 ("\\bcustom:\\(//\\)?\\([^'\">\n\t ]+\\)" | |
6101 0 (>= gnus-button-emacs-level 5) gnus-button-handle-custom 2) | |
6102 ("M-x[ \t\n]customize-[^ ]+[ \t\n]RET[ \t\n]\\([^ ]+\\)[ \t\n]RET" 0 | |
6103 (>= gnus-button-emacs-level 1) gnus-button-handle-custom 1) | |
6104 ;; Emacs help commands | |
6105 ("M-x[ \t\n]+apropos[ \t\n]+RET[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET" | |
6106 ;; regexp doesn't match arguments containing ` '. | |
6107 0 (>= gnus-button-emacs-level 1) gnus-button-handle-apropos 1) | |
6108 ("M-x[ \t\n]+apropos-command[ \t\n]+RET[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET" | |
6109 0 (>= gnus-button-emacs-level 1) gnus-button-handle-apropos-command 1) | |
6110 ("M-x[ \t\n]+apropos-variable[ \t\n]+RET[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET" | |
6111 0 (>= gnus-button-emacs-level 1) gnus-button-handle-apropos-variable 1) | |
6112 ("M-x[ \t\n]+apropos-documentation[ \t\n]+RET[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET" | |
6113 0 (>= gnus-button-emacs-level 1) gnus-button-handle-apropos-documentation 1) | |
6114 ;; The following entries may lead to many false positives so don't enable | |
6115 ;; them by default (use a high button level): | |
6116 ("/\\([a-z][-a-z0-9]+\\.el\\)\\>" | |
6117 1 (>= gnus-button-emacs-level 8) gnus-button-handle-library 1) | |
6118 ("`\\([a-z][-a-z0-9]+\\.el\\)'" | |
6119 1 (>= gnus-button-emacs-level 8) gnus-button-handle-library 1) | |
6120 ("`\\([a-z][a-z0-9]+-[a-z]+-[-a-z]+\\|\\(gnus\\|message\\)-[-a-z]+\\)'" | |
6121 0 (>= gnus-button-emacs-level 8) gnus-button-handle-symbol 1) | |
6122 ("`\\([a-z][a-z0-9]+-[a-z]+\\)'" | |
6123 0 (>= gnus-button-emacs-level 9) gnus-button-handle-symbol 1) | |
6124 ("(setq[ \t\n]+\\([a-z][a-z0-9]+-[-a-z0-9]+\\)[ \t\n]+.+)" | |
6125 1 (>= gnus-button-emacs-level 7) gnus-button-handle-describe-variable 1) | |
6126 ("\\bM-x[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET" | |
6127 1 (>= gnus-button-emacs-level 7) gnus-button-handle-describe-function 1) | |
6128 ("\\b\\(C-h\\|<?[Ff]1>?\\)[ \t\n]+f[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET" | |
6129 0 (>= gnus-button-emacs-level 1) gnus-button-handle-describe-function 2) | |
6130 ("\\b\\(C-h\\|<?[Ff]1>?\\)[ \t\n]+v[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET" | |
6131 0 (>= gnus-button-emacs-level 1) gnus-button-handle-describe-variable 2) | |
6132 ("`\\(\\b\\(C-h\\|<?[Ff]1>?\\)[ \t\n]+k[ \t\n]+\\([^']+\\)\\)'" | |
6133 ;; Unlike the other regexps we really have to require quoting | |
6134 ;; here to determine where it ends. | |
6135 1 (>= gnus-button-emacs-level 1) gnus-button-handle-describe-key 3) | |
6136 ;; This is how URLs _should_ be embedded in text (RFC 1738, RFC 2396)... | |
6137 ("<URL: *\\([^<>]*\\)>" | |
6138 1 (>= gnus-button-browse-level 0) gnus-button-embedded-url 1) | |
6139 ;; RFC 2396 (2.4.3., delims) ... | |
6140 ("\"URL: *\\([^\"]*\\)\"" | |
6141 1 (>= gnus-button-browse-level 0) gnus-button-embedded-url 1) | |
6142 ;; RFC 2396 (2.4.3., delims) ... | |
6143 ("\"URL: *\\([^\"]*\\)\"" | |
6144 1 (>= gnus-button-browse-level 0) gnus-button-embedded-url 1) | |
4295 ;; Raw URLs. | 6145 ;; Raw URLs. |
4296 (,gnus-button-url-regexp 0 t browse-url 0)) | 6146 (gnus-button-url-regexp |
6147 0 (>= gnus-button-browse-level 0) browse-url 0) | |
6148 ;; man pages | |
6149 ("\\b\\([a-z][a-z]+\\)([1-9])\\W" | |
6150 0 (and (>= gnus-button-man-level 1) (< gnus-button-man-level 3)) | |
6151 gnus-button-handle-man 1) | |
6152 ;; more man pages: resolv.conf(5), iso_8859-1(7), xterm(1x) | |
6153 ("\\b\\([a-z][-_.a-z0-9]+\\)([1-9])\\W" | |
6154 0 (and (>= gnus-button-man-level 3) (< gnus-button-man-level 5)) | |
6155 gnus-button-handle-man 1) | |
6156 ;; even more: Apache::PerlRun(3pm), PDL::IO::FastRaw(3pm), | |
6157 ;; SoWWWAnchor(3iv), XSelectInput(3X11), X(1), X(7) | |
6158 ("\\b\\([a-z][-+_.:a-z0-9]+\\)([1-9][X1a-z]*)\\W\\|\\b\\(X\\)([1-9])\\W" | |
6159 0 (>= gnus-button-man-level 5) gnus-button-handle-man 1) | |
6160 ;; MID or mail: To avoid too many false positives we don't try to catch | |
6161 ;; all kind of allowed MIDs or mail addresses. Domain part must contain | |
6162 ;; at least one dot. TLD must contain two or three chars or be a know TLD | |
6163 ;; (info|name|...). Put this entry near the _end_ of `gnus-button-alist' | |
6164 ;; so that non-ambiguous entries (see above) match first. | |
6165 (gnus-button-mid-or-mail-regexp | |
6166 0 (>= gnus-button-message-level 5) gnus-button-handle-mid-or-mail 1)) | |
4297 "*Alist of regexps matching buttons in article bodies. | 6167 "*Alist of regexps matching buttons in article bodies. |
4298 | 6168 |
4299 Each entry has the form (REGEXP BUTTON FORM CALLBACK PAR...), where | 6169 Each entry has the form (REGEXP BUTTON FORM CALLBACK PAR...), where |
4300 REGEXP: is the string matching text around the button, | 6170 REGEXP: is the string (case insensitive) matching text around the button (can |
6171 also be Lisp expression evaluating to a string), | |
4301 BUTTON: is the number of the regexp grouping actually matching the button, | 6172 BUTTON: is the number of the regexp grouping actually matching the button, |
4302 FORM: is a Lisp expression which must eval to true for the button to | 6173 FORM: is a Lisp expression which must eval to true for the button to |
4303 be added, | 6174 be added, |
4304 CALLBACK: is the function to call when the user push this button, and each | 6175 CALLBACK: is the function to call when the user push this button, and each |
4305 PAR: is a number of a regexp grouping whose text will be passed to CALLBACK. | 6176 PAR: is a number of a regexp grouping whose text will be passed to CALLBACK. |
4306 | 6177 |
4307 CALLBACK can also be a variable, in that case the value of that | 6178 CALLBACK can also be a variable, in that case the value of that |
4308 variable it the real callback function." | 6179 variable it the real callback function." |
4309 :group 'gnus-article-buttons | 6180 :group 'gnus-article-buttons |
4310 :type '(repeat (list regexp | 6181 :type '(repeat (list (choice regexp variable sexp) |
4311 (integer :tag "Button") | 6182 (integer :tag "Button") |
4312 (sexp :tag "Form") | 6183 (sexp :tag "Form") |
4313 (function :tag "Callback") | 6184 (function :tag "Callback") |
4314 (repeat :tag "Par" | 6185 (repeat :tag "Par" |
4315 :inline t | 6186 :inline t |
4316 (integer :tag "Regexp group"))))) | 6187 (integer :tag "Regexp group"))))) |
4317 | 6188 |
4318 (defcustom gnus-header-button-alist | 6189 (defcustom gnus-header-button-alist |
4319 `(("^\\(References\\|Message-I[Dd]\\):" "<[^>]+>" | 6190 '(("^\\(References\\|Message-I[Dd]\\|^In-Reply-To\\):" "<[^<>]+>" |
4320 0 t gnus-button-message-id 0) | 6191 0 (>= gnus-button-message-level 0) gnus-button-message-id 0) |
4321 ("^\\(From\\|Reply-To\\):" ": *\\(.+\\)$" 1 t gnus-button-reply 1) | 6192 ("^\\(From\\|Reply-To\\):" ": *\\(.+\\)$" |
6193 1 (>= gnus-button-message-level 0) gnus-button-reply 1) | |
4322 ("^\\(Cc\\|To\\):" "[^ \t\n<>,()\"]+@[^ \t\n<>,()\"]+" | 6194 ("^\\(Cc\\|To\\):" "[^ \t\n<>,()\"]+@[^ \t\n<>,()\"]+" |
4323 0 t gnus-button-mailto 0) | 6195 0 (>= gnus-button-message-level 0) gnus-button-mailto 0) |
4324 ("^X-[Uu][Rr][Ll]:" ,gnus-button-url-regexp 0 t browse-url 0) | 6196 ("^X-[Uu][Rr][Ll]:" gnus-button-url-regexp |
4325 ("^Subject:" ,gnus-button-url-regexp 0 t browse-url 0) | 6197 0 (>= gnus-button-browse-level 0) browse-url 0) |
4326 ("^[^:]+:" ,gnus-button-url-regexp 0 t browse-url 0) | 6198 ("^Subject:" gnus-button-url-regexp |
4327 ("^[^:]+:" "\\(<\\(url: \\)?news:\\([^>\n ]*\\)>\\)" 1 t | 6199 0 (>= gnus-button-browse-level 0) browse-url 0) |
4328 gnus-button-message-id 3)) | 6200 ("^[^:]+:" gnus-button-url-regexp |
6201 0 (>= gnus-button-browse-level 0) browse-url 0) | |
6202 ("^[^:]+:" "\\bmailto:\\([-a-z.@_+0-9%=?&]+\\)" | |
6203 0 (>= gnus-button-message-level 0) gnus-url-mailto 1) | |
6204 ("^[^:]+:" "\\(<\\(url: \\)?\\(nntp\\|news\\):\\([^>\n ]*\\)>\\)" | |
6205 1 (>= gnus-button-message-level 0) gnus-button-message-id 4)) | |
4329 "*Alist of headers and regexps to match buttons in article heads. | 6206 "*Alist of headers and regexps to match buttons in article heads. |
4330 | 6207 |
4331 This alist is very similar to `gnus-button-alist', except that each | 6208 This alist is very similar to `gnus-button-alist', except that each |
4332 alist has an additional HEADER element first in each entry: | 6209 alist has an additional HEADER element first in each entry: |
4333 | 6210 |
4336 HEADER is a regexp to match a header. For a fuller explanation, see | 6213 HEADER is a regexp to match a header. For a fuller explanation, see |
4337 `gnus-button-alist'." | 6214 `gnus-button-alist'." |
4338 :group 'gnus-article-buttons | 6215 :group 'gnus-article-buttons |
4339 :group 'gnus-article-headers | 6216 :group 'gnus-article-headers |
4340 :type '(repeat (list (regexp :tag "Header") | 6217 :type '(repeat (list (regexp :tag "Header") |
4341 regexp | 6218 (choice regexp variable) |
4342 (integer :tag "Button") | 6219 (integer :tag "Button") |
4343 (sexp :tag "Form") | 6220 (sexp :tag "Form") |
4344 (function :tag "Callback") | 6221 (function :tag "Callback") |
4345 (repeat :tag "Par" | 6222 (repeat :tag "Par" |
4346 :inline t | 6223 :inline t |
4360 If the text under the mouse pointer has a `gnus-callback' property, | 6237 If the text under the mouse pointer has a `gnus-callback' property, |
4361 call it with the value of the `gnus-data' text property." | 6238 call it with the value of the `gnus-data' text property." |
4362 (interactive "e") | 6239 (interactive "e") |
4363 (set-buffer (window-buffer (posn-window (event-start event)))) | 6240 (set-buffer (window-buffer (posn-window (event-start event)))) |
4364 (let* ((pos (posn-point (event-start event))) | 6241 (let* ((pos (posn-point (event-start event))) |
4365 (data (get-text-property pos 'gnus-data)) | 6242 (data (get-text-property pos 'gnus-data)) |
4366 (fun (get-text-property pos 'gnus-callback))) | 6243 (fun (get-text-property pos 'gnus-callback))) |
4367 (goto-char pos) | 6244 (goto-char pos) |
4368 (when fun | 6245 (when fun |
4369 (funcall fun data)))) | 6246 (funcall fun data)))) |
4370 | 6247 |
4371 (defun gnus-article-press-button () | 6248 (defun gnus-article-press-button () |
4372 "Check text at point for a callback function. | 6249 "Check text at point for a callback function. |
4373 If the text at point has a `gnus-callback' property, | 6250 If the text at point has a `gnus-callback' property, |
4374 call it with the value of the `gnus-data' text property." | 6251 call it with the value of the `gnus-data' text property." |
4375 (interactive) | 6252 (interactive) |
4376 (let* ((data (get-text-property (point) 'gnus-data)) | 6253 (let ((data (get-text-property (point) 'gnus-data)) |
4377 (fun (get-text-property (point) 'gnus-callback))) | 6254 (fun (get-text-property (point) 'gnus-callback))) |
4378 (when fun | 6255 (when fun |
4379 (funcall fun data)))) | 6256 (funcall fun data)))) |
4380 | 6257 |
4381 (defun gnus-article-highlight (&optional force) | 6258 (defun gnus-article-highlight (&optional force) |
4382 "Highlight current article. | 6259 "Highlight current article. |
4406 (interactive) | 6283 (interactive) |
4407 (save-excursion | 6284 (save-excursion |
4408 (set-buffer gnus-article-buffer) | 6285 (set-buffer gnus-article-buffer) |
4409 (save-restriction | 6286 (save-restriction |
4410 (let ((alist gnus-header-face-alist) | 6287 (let ((alist gnus-header-face-alist) |
4411 (inhibit-read-only t) | 6288 (buffer-read-only nil) |
4412 (case-fold-search t) | 6289 (case-fold-search t) |
4413 (inhibit-point-motion-hooks t) | 6290 (inhibit-point-motion-hooks t) |
4414 entry regexp header-face field-face from hpoints fpoints) | 6291 entry regexp header-face field-face from hpoints fpoints) |
4415 (article-narrow-to-head) | 6292 (article-narrow-to-head) |
4416 (while (setq entry (pop alist)) | 6293 (while (setq entry (pop alist)) |
4445 It does this by highlighting everything after | 6322 It does this by highlighting everything after |
4446 `gnus-signature-separator' using `gnus-signature-face'." | 6323 `gnus-signature-separator' using `gnus-signature-face'." |
4447 (interactive) | 6324 (interactive) |
4448 (save-excursion | 6325 (save-excursion |
4449 (set-buffer gnus-article-buffer) | 6326 (set-buffer gnus-article-buffer) |
4450 (let ((inhibit-read-only t) | 6327 (let ((buffer-read-only nil) |
4451 (inhibit-point-motion-hooks t)) | 6328 (inhibit-point-motion-hooks t)) |
4452 (save-restriction | 6329 (save-restriction |
4453 (when (and gnus-signature-face | 6330 (when (and gnus-signature-face |
4454 (gnus-article-narrow-to-signature)) | 6331 (gnus-article-narrow-to-signature)) |
4455 (gnus-overlay-put (gnus-make-overlay (point-min) (point-max)) | 6332 (gnus-overlay-put (gnus-make-overlay (point-min) (point-max)) |
4470 \"External references\" are things like Message-IDs and URLs, as | 6347 \"External references\" are things like Message-IDs and URLs, as |
4471 specified by `gnus-button-alist'." | 6348 specified by `gnus-button-alist'." |
4472 (interactive (list 'force)) | 6349 (interactive (list 'force)) |
4473 (save-excursion | 6350 (save-excursion |
4474 (set-buffer gnus-article-buffer) | 6351 (set-buffer gnus-article-buffer) |
4475 (let ((inhibit-read-only t) | 6352 (let ((buffer-read-only nil) |
4476 (inhibit-point-motion-hooks t) | 6353 (inhibit-point-motion-hooks t) |
4477 (case-fold-search t) | 6354 (case-fold-search t) |
4478 (alist gnus-button-alist) | 6355 (alist gnus-button-alist) |
4479 beg entry regexp) | 6356 beg entry regexp) |
4480 ;; Remove all old markers. | 6357 ;; Remove all old markers. |
4491 (setq gnus-button-marker-list new-list)) | 6368 (setq gnus-button-marker-list new-list)) |
4492 ;; We skip the headers. | 6369 ;; We skip the headers. |
4493 (article-goto-body) | 6370 (article-goto-body) |
4494 (setq beg (point)) | 6371 (setq beg (point)) |
4495 (while (setq entry (pop alist)) | 6372 (while (setq entry (pop alist)) |
4496 (setq regexp (car entry)) | 6373 (setq regexp (eval (car entry))) |
4497 (goto-char beg) | 6374 (goto-char beg) |
4498 (while (re-search-forward regexp nil t) | 6375 (while (re-search-forward regexp nil t) |
4499 (let* ((start (and entry (match-beginning (nth 1 entry)))) | 6376 (let* ((start (and entry (match-beginning (nth 1 entry)))) |
4500 (end (and entry (match-end (nth 1 entry)))) | 6377 (end (and entry (match-end (nth 1 entry)))) |
4501 (from (match-beginning 0))) | 6378 (from (match-beginning 0))) |
4515 "Add buttons to the head of the article." | 6392 "Add buttons to the head of the article." |
4516 (interactive) | 6393 (interactive) |
4517 (save-excursion | 6394 (save-excursion |
4518 (set-buffer gnus-article-buffer) | 6395 (set-buffer gnus-article-buffer) |
4519 (save-restriction | 6396 (save-restriction |
4520 (let ((inhibit-read-only t) | 6397 (let ((buffer-read-only nil) |
4521 (inhibit-point-motion-hooks t) | 6398 (inhibit-point-motion-hooks t) |
4522 (case-fold-search t) | 6399 (case-fold-search t) |
4523 (alist gnus-header-button-alist) | 6400 (alist gnus-header-button-alist) |
4524 entry beg end) | 6401 entry beg end) |
4525 (article-narrow-to-head) | 6402 (article-narrow-to-head) |
4533 (setq beg (match-beginning 0)) | 6410 (setq beg (match-beginning 0)) |
4534 (setq end (or (and (re-search-forward "^[^ \t]" nil t) | 6411 (setq end (or (and (re-search-forward "^[^ \t]" nil t) |
4535 (match-beginning 0)) | 6412 (match-beginning 0)) |
4536 (point-max))) | 6413 (point-max))) |
4537 (goto-char beg) | 6414 (goto-char beg) |
4538 (while (re-search-forward (nth 1 entry) end t) | 6415 (while (re-search-forward (eval (nth 1 entry)) end t) |
4539 ;; Each match within a header. | 6416 ;; Each match within a header. |
4540 (let* ((entry (cdr entry)) | 6417 (let* ((entry (cdr entry)) |
4541 (start (match-beginning (nth 1 entry))) | 6418 (start (match-beginning (nth 1 entry))) |
4542 (end (match-end (nth 1 entry))) | 6419 (end (match-end (nth 1 entry))) |
4543 (form (nth 2 entry))) | 6420 (form (nth 2 entry))) |
4573 (gnus-set-global-variables))) | 6450 (gnus-set-global-variables))) |
4574 | 6451 |
4575 (defun gnus-signature-toggle (end) | 6452 (defun gnus-signature-toggle (end) |
4576 (save-excursion | 6453 (save-excursion |
4577 (set-buffer gnus-article-buffer) | 6454 (set-buffer gnus-article-buffer) |
4578 (let ((inhibit-read-only t) | 6455 (let ((buffer-read-only nil) |
4579 (inhibit-point-motion-hooks t)) | 6456 (inhibit-point-motion-hooks t)) |
4580 (if (text-property-any end (point-max) 'article-type 'signature) | 6457 (if (text-property-any end (point-max) 'article-type 'signature) |
4581 (gnus-remove-text-properties-when | 6458 (progn |
4582 'article-type 'signature end (point-max) | 6459 (gnus-delete-wash-type 'signature) |
4583 (cons 'article-type (cons 'signature | 6460 (gnus-remove-text-properties-when |
4584 gnus-hidden-properties))) | 6461 'article-type 'signature end (point-max) |
6462 (cons 'article-type (cons 'signature | |
6463 gnus-hidden-properties)))) | |
6464 (gnus-add-wash-type 'signature) | |
4585 (gnus-add-text-properties-when | 6465 (gnus-add-text-properties-when |
4586 'article-type nil end (point-max) | 6466 'article-type nil end (point-max) |
4587 (cons 'article-type (cons 'signature | 6467 (cons 'article-type (cons 'signature |
4588 gnus-hidden-properties))))))) | 6468 gnus-hidden-properties))))) |
6469 (let ((gnus-article-mime-handle-alist-1 gnus-article-mime-handle-alist)) | |
6470 (gnus-set-mode-line 'article)))) | |
4589 | 6471 |
4590 (defun gnus-button-entry () | 6472 (defun gnus-button-entry () |
4591 ;; Return the first entry in `gnus-button-alist' matching this place. | 6473 ;; Return the first entry in `gnus-button-alist' matching this place. |
4592 (let ((alist gnus-button-alist) | 6474 (let ((alist gnus-button-alist) |
4593 (entry nil)) | 6475 (entry nil)) |
4594 (while alist | 6476 (while alist |
4595 (setq entry (pop alist)) | 6477 (setq entry (pop alist)) |
4596 (if (looking-at (car entry)) | 6478 (if (looking-at (eval (car entry))) |
4597 (setq alist nil) | 6479 (setq alist nil) |
4598 (setq entry nil))) | 6480 (setq entry nil))) |
4599 entry)) | 6481 entry)) |
4600 | 6482 |
4601 (defun gnus-button-push (marker) | 6483 (defun gnus-button-push (marker) |
4619 (apply (symbol-value fun) args)) | 6501 (apply (symbol-value fun) args)) |
4620 (t | 6502 (t |
4621 (gnus-message 1 "You must define `%S' to use this button" | 6503 (gnus-message 1 "You must define `%S' to use this button" |
4622 (cons fun args))))))) | 6504 (cons fun args))))))) |
4623 | 6505 |
6506 (defun gnus-parse-news-url (url) | |
6507 (let (scheme server group message-id articles) | |
6508 (with-temp-buffer | |
6509 (insert url) | |
6510 (goto-char (point-min)) | |
6511 (when (looking-at "\\([A-Za-z]+\\):") | |
6512 (setq scheme (match-string 1)) | |
6513 (goto-char (match-end 0))) | |
6514 (when (looking-at "//\\([^/]+\\)/") | |
6515 (setq server (match-string 1)) | |
6516 (goto-char (match-end 0))) | |
6517 | |
6518 (cond | |
6519 ((looking-at "\\(.*@.*\\)") | |
6520 (setq message-id (match-string 1))) | |
6521 ((looking-at "\\([^/]+\\)/\\([-0-9]+\\)") | |
6522 (setq group (match-string 1) | |
6523 articles (split-string (match-string 2) "-"))) | |
6524 ((looking-at "\\([^/]+\\)/?") | |
6525 (setq group (match-string 1))) | |
6526 (t | |
6527 (error "Unknown news URL syntax")))) | |
6528 (list scheme server group message-id articles))) | |
6529 | |
6530 (defun gnus-button-handle-news (url) | |
6531 "Fetch a news URL." | |
6532 (destructuring-bind (scheme server group message-id articles) | |
6533 (gnus-parse-news-url url) | |
6534 (cond | |
6535 (message-id | |
6536 (save-excursion | |
6537 (set-buffer gnus-summary-buffer) | |
6538 (if server | |
6539 (let ((gnus-refer-article-method (list (list 'nntp server)))) | |
6540 (gnus-summary-refer-article message-id)) | |
6541 (gnus-summary-refer-article message-id)))) | |
6542 (group | |
6543 (gnus-button-fetch-group url))))) | |
6544 | |
6545 (defun gnus-button-handle-man (url) | |
6546 "Fetch a man page." | |
6547 (funcall gnus-button-man-handler url)) | |
6548 | |
6549 (defun gnus-button-handle-info-url (url) | |
6550 "Fetch an info URL." | |
6551 (setq url (mm-subst-char-in-string ?+ ?\ url)) | |
6552 (cond | |
6553 ((string-match "^\\([^:/]+\\)?/\\(.*\\)" url) | |
6554 (gnus-info-find-node | |
6555 (concat "(" (or (gnus-url-unhex-string (match-string 1 url)) | |
6556 "Gnus") | |
6557 ")" (gnus-url-unhex-string (match-string 2 url))))) | |
6558 ((string-match "([^)\"]+)[^\"]+" url) | |
6559 (setq url | |
6560 (gnus-replace-in-string | |
6561 (gnus-replace-in-string url "[\n\t ]+" " ") "\"" "")) | |
6562 (gnus-info-find-node url)) | |
6563 (t (error "Can't parse %s" url)))) | |
6564 | |
6565 (defun gnus-button-handle-info-url-gnome (url) | |
6566 "Fetch GNOME style info URL." | |
6567 (setq url (mm-subst-char-in-string ?_ ?\ url)) | |
6568 (if (string-match "\\([^#]+\\)#?\\(.*\\)" url) | |
6569 (gnus-info-find-node | |
6570 (concat "(" | |
6571 (gnus-url-unhex-string | |
6572 (match-string 1 url)) | |
6573 ")" | |
6574 (or (gnus-url-unhex-string | |
6575 (match-string 2 url)) | |
6576 "Top"))) | |
6577 (error "Can't parse %s" url))) | |
6578 | |
6579 (defun gnus-button-handle-info-url-kde (url) | |
6580 "Fetch KDE style info URL." | |
6581 (gnus-info-find-node (gnus-url-unhex-string url))) | |
6582 | |
6583 (defun gnus-button-handle-info-keystrokes (url) | |
6584 "Call `info' when pushing the corresponding URL button." | |
6585 ;; For links like `C-h i d m gnus RET', `C-h i d m CC Mode RET'. | |
6586 (info) | |
6587 (Info-directory) | |
6588 (Info-menu url)) | |
6589 | |
4624 (defun gnus-button-message-id (message-id) | 6590 (defun gnus-button-message-id (message-id) |
4625 "Fetch MESSAGE-ID." | 6591 "Fetch MESSAGE-ID." |
4626 (save-excursion | 6592 (save-excursion |
4627 (set-buffer gnus-summary-buffer) | 6593 (set-buffer gnus-summary-buffer) |
4628 (gnus-summary-refer-article message-id))) | 6594 (gnus-summary-refer-article message-id))) |
4630 (defun gnus-button-fetch-group (address) | 6596 (defun gnus-button-fetch-group (address) |
4631 "Fetch GROUP specified by ADDRESS." | 6597 "Fetch GROUP specified by ADDRESS." |
4632 (if (not (string-match "[:/]" address)) | 6598 (if (not (string-match "[:/]" address)) |
4633 ;; This is just a simple group url. | 6599 ;; This is just a simple group url. |
4634 (gnus-group-read-ephemeral-group address gnus-select-method) | 6600 (gnus-group-read-ephemeral-group address gnus-select-method) |
4635 (if (not (string-match "^\\([^:/]+\\)\\(:\\([^/]+\\)/\\)?\\(.*\\)$" | 6601 (if (not |
4636 address)) | 6602 (string-match |
6603 "^\\([^:/]+\\)\\(:\\([^/]+\\)\\)?/\\([^/]+\\)\\(/\\([0-9]+\\)\\)?" | |
6604 address)) | |
4637 (error "Can't parse %s" address) | 6605 (error "Can't parse %s" address) |
4638 (gnus-group-read-ephemeral-group | 6606 (gnus-group-read-ephemeral-group |
4639 (match-string 4 address) | 6607 (match-string 4 address) |
4640 `(nntp ,(match-string 1 address) | 6608 `(nntp ,(match-string 1 address) |
4641 (nntp-address ,(match-string 1 address)) | 6609 (nntp-address ,(match-string 1 address)) |
4642 (nntp-port-number ,(if (match-end 3) | 6610 (nntp-port-number ,(if (match-end 3) |
4643 (match-string 3 address) | 6611 (match-string 3 address) |
4644 "nntp"))))))) | 6612 "nntp"))) |
6613 nil nil nil | |
6614 (and (match-end 6) (list (string-to-int (match-string 6 address)))))))) | |
4645 | 6615 |
4646 (defun gnus-url-parse-query-string (query &optional downcase) | 6616 (defun gnus-url-parse-query-string (query &optional downcase) |
4647 (let (retval pairs cur key val) | 6617 (let (retval pairs cur key val) |
4648 (setq pairs (split-string query "&")) | 6618 (setq pairs (split-string query "&")) |
4649 (while pairs | 6619 (while pairs |
4650 (setq cur (car pairs) | 6620 (setq cur (car pairs) |
4651 pairs (cdr pairs)) | 6621 pairs (cdr pairs)) |
4652 (if (not (string-match "=" cur)) | 6622 (if (not (string-match "=" cur)) |
4653 nil ; Grace | 6623 nil ; Grace |
4654 (setq key (gnus-url-unhex-string (substring cur 0 (match-beginning 0))) | 6624 (setq key (gnus-url-unhex-string (substring cur 0 (match-beginning 0))) |
4655 val (gnus-url-unhex-string (substring cur (match-end 0) nil))) | 6625 val (gnus-url-unhex-string (substring cur (match-end 0) nil) t)) |
4656 (if downcase | 6626 (if downcase |
4657 (setq key (downcase key))) | 6627 (setq key (downcase key))) |
4658 (setq cur (assoc key retval)) | 6628 (setq cur (assoc key retval)) |
4659 (if cur | 6629 (if cur |
4660 (setcdr cur (cons val (cdr cur))) | 6630 (setcdr cur (cons val (cdr cur))) |
4661 (setq retval (cons (list key val) retval))))) | 6631 (setq retval (cons (list key val) retval))))) |
4662 retval)) | 6632 retval)) |
4663 | |
4664 (defun gnus-url-unhex (x) | |
4665 (if (> x ?9) | |
4666 (if (>= x ?a) | |
4667 (+ 10 (- x ?a)) | |
4668 (+ 10 (- x ?A))) | |
4669 (- x ?0))) | |
4670 | |
4671 (defun gnus-url-unhex-string (str &optional allow-newlines) | |
4672 "Remove %XXX embedded spaces, etc in a url. | |
4673 If optional second argument ALLOW-NEWLINES is non-nil, then allow the | |
4674 decoding of carriage returns and line feeds in the string, which is normally | |
4675 forbidden in URL encoding." | |
4676 (setq str (or str "")) | |
4677 (let ((tmp "") | |
4678 (case-fold-search t)) | |
4679 (while (string-match "%[0-9a-f][0-9a-f]" str) | |
4680 (let* ((start (match-beginning 0)) | |
4681 (ch1 (gnus-url-unhex (elt str (+ start 1)))) | |
4682 (code (+ (* 16 ch1) | |
4683 (gnus-url-unhex (elt str (+ start 2)))))) | |
4684 (setq tmp (concat | |
4685 tmp (substring str 0 start) | |
4686 (cond | |
4687 (allow-newlines | |
4688 (char-to-string code)) | |
4689 ((or (= code ?\n) (= code ?\r)) | |
4690 " ") | |
4691 (t (char-to-string code)))) | |
4692 str (substring str (match-end 0))))) | |
4693 (setq tmp (concat tmp str)) | |
4694 tmp)) | |
4695 | 6633 |
4696 (defun gnus-url-mailto (url) | 6634 (defun gnus-url-mailto (url) |
4697 ;; Send mail to someone | 6635 ;; Send mail to someone |
4698 (when (string-match "mailto:/*\\(.*\\)" url) | 6636 (when (string-match "mailto:/*\\(.*\\)" url) |
4699 (setq url (substring url (match-beginning 1) nil))) | 6637 (setq url (substring url (match-beginning 1) nil))) |
4700 (let (to args subject func) | 6638 (let (to args subject func) |
4701 (if (string-match (regexp-quote "?") url) | 6639 (setq args (gnus-url-parse-query-string |
4702 (setq to (gnus-url-unhex-string (substring url 0 (match-beginning 0))) | 6640 (if (string-match "^\\?" url) |
4703 args (gnus-url-parse-query-string | 6641 (substring url 1) |
4704 (substring url (match-end 0) nil) t)) | 6642 (if (string-match "^\\([^?]+\\)\\?\\(.*\\)" url) |
4705 (setq to (gnus-url-unhex-string url))) | 6643 (concat "to=" (match-string 1 url) "&" |
4706 (setq args (cons (list "to" to) args) | 6644 (match-string 2 url)) |
4707 subject (cdr-safe (assoc "subject" args))) | 6645 (concat "to=" url))) |
4708 (message-mail) | 6646 t) |
6647 subject (cdr-safe (assoc "subject" args))) | |
6648 (gnus-msg-mail) | |
4709 (while args | 6649 (while args |
4710 (setq func (intern-soft (concat "message-goto-" (downcase (caar args))))) | 6650 (setq func (intern-soft (concat "message-goto-" (downcase (caar args))))) |
4711 (if (fboundp func) | 6651 (if (fboundp func) |
4712 (funcall func) | 6652 (funcall func) |
4713 (message-position-on-field (caar args))) | 6653 (message-position-on-field (caar args))) |
4714 (insert (mapconcat 'identity (cdar args) ", ")) | 6654 (insert (gnus-replace-in-string |
6655 (mapconcat 'identity (reverse (cdar args)) ", ") | |
6656 "\r\n" "\n" t)) | |
4715 (setq args (cdr args))) | 6657 (setq args (cdr args))) |
4716 (if subject | 6658 (if subject |
4717 (message-goto-body) | 6659 (message-goto-body) |
4718 (message-goto-subject)))) | 6660 (message-goto-subject)))) |
4719 | |
4720 (defun gnus-button-mailto (address) | |
4721 "Mail to ADDRESS." | |
4722 (set-buffer (gnus-copy-article-buffer)) | |
4723 (message-reply address)) | |
4724 | |
4725 (defalias 'gnus-button-reply 'message-reply) | |
4726 | 6661 |
4727 (defun gnus-button-embedded-url (address) | 6662 (defun gnus-button-embedded-url (address) |
4728 "Activate ADDRESS with `browse-url'." | 6663 "Activate ADDRESS with `browse-url'." |
4729 (browse-url (gnus-strip-whitespace address))) | 6664 (browse-url (gnus-strip-whitespace address))) |
4730 | 6665 |
4731 ;;; Next/prev buttons in the article buffer. | 6666 ;;; Next/prev buttons in the article buffer. |
4732 | 6667 |
4733 (defvar gnus-next-page-line-format "%{%(Next page...%)%}\n") | 6668 (defvar gnus-next-page-line-format "%{%(Next page...%)%}\n") |
4734 (defvar gnus-prev-page-line-format "%{%(Previous page...%)%}\n") | 6669 (defvar gnus-prev-page-line-format "%{%(Previous page...%)%}\n") |
4735 | 6670 |
4736 (defvar gnus-prev-page-map nil) | 6671 (defvar gnus-prev-page-map |
4737 (unless gnus-prev-page-map | 6672 (let ((map (make-sparse-keymap))) |
4738 (setq gnus-prev-page-map (make-sparse-keymap)) | 6673 (unless (>= emacs-major-version 21) |
4739 (define-key gnus-prev-page-map gnus-mouse-2 'gnus-button-prev-page) | 6674 ;; XEmacs doesn't care. |
4740 (define-key gnus-prev-page-map "\r" 'gnus-button-prev-page)) | 6675 (set-keymap-parent map gnus-article-mode-map)) |
6676 (define-key map gnus-mouse-2 'gnus-button-prev-page) | |
6677 (define-key map "\r" 'gnus-button-prev-page) | |
6678 map)) | |
4741 | 6679 |
4742 (defun gnus-insert-prev-page-button () | 6680 (defun gnus-insert-prev-page-button () |
4743 (let ((inhibit-read-only t)) | 6681 (let ((b (point)) |
6682 (buffer-read-only nil)) | |
4744 (gnus-eval-format | 6683 (gnus-eval-format |
4745 gnus-prev-page-line-format nil | 6684 gnus-prev-page-line-format nil |
4746 `(gnus-prev t local-map ,gnus-prev-page-map | 6685 `(,@(gnus-local-map-property gnus-prev-page-map) |
4747 gnus-callback gnus-article-button-prev-page | 6686 gnus-prev t |
4748 article-type annotation)))) | 6687 gnus-callback gnus-article-button-prev-page |
4749 | 6688 article-type annotation)) |
4750 (defvar gnus-next-page-map nil) | 6689 (widget-convert-button |
4751 (unless gnus-next-page-map | 6690 'link b (if (bolp) |
4752 (setq gnus-next-page-map (make-keymap)) | 6691 ;; Exclude a newline. |
4753 (suppress-keymap gnus-prev-page-map) | 6692 (1- (point)) |
4754 (define-key gnus-next-page-map gnus-mouse-2 'gnus-button-next-page) | 6693 (point)) |
4755 (define-key gnus-next-page-map "\r" 'gnus-button-next-page)) | 6694 :action 'gnus-button-prev-page |
4756 | 6695 :button-keymap gnus-prev-page-map))) |
4757 (defun gnus-button-next-page () | 6696 |
6697 (defvar gnus-prev-page-map | |
6698 (let ((map (make-sparse-keymap))) | |
6699 (unless (>= emacs-major-version 21) | |
6700 ;; XEmacs doesn't care. | |
6701 (set-keymap-parent map gnus-article-mode-map)) | |
6702 (define-key map gnus-mouse-2 'gnus-button-prev-page) | |
6703 (define-key map "\r" 'gnus-button-prev-page) | |
6704 map)) | |
6705 | |
6706 (defvar gnus-next-page-map | |
6707 (let ((map (make-sparse-keymap))) | |
6708 (unless (>= emacs-major-version 21) | |
6709 ;; XEmacs doesn't care. | |
6710 (set-keymap-parent map gnus-article-mode-map)) | |
6711 (define-key map gnus-mouse-2 'gnus-button-next-page) | |
6712 (define-key map "\r" 'gnus-button-next-page) | |
6713 map)) | |
6714 | |
6715 (defun gnus-button-next-page (&optional args more-args) | |
4758 "Go to the next page." | 6716 "Go to the next page." |
4759 (interactive) | 6717 (interactive) |
4760 (let ((win (selected-window))) | 6718 (let ((win (selected-window))) |
4761 (select-window (get-buffer-window gnus-article-buffer t)) | 6719 (select-window (gnus-get-buffer-window gnus-article-buffer t)) |
4762 (gnus-article-next-page) | 6720 (gnus-article-next-page) |
4763 (select-window win))) | 6721 (select-window win))) |
4764 | 6722 |
4765 (defun gnus-button-prev-page () | 6723 (defun gnus-button-prev-page (&optional args more-args) |
4766 "Go to the prev page." | 6724 "Go to the prev page." |
4767 (interactive) | 6725 (interactive) |
4768 (let ((win (selected-window))) | 6726 (let ((win (selected-window))) |
4769 (select-window (get-buffer-window gnus-article-buffer t)) | 6727 (select-window (gnus-get-buffer-window gnus-article-buffer t)) |
4770 (gnus-article-prev-page) | 6728 (gnus-article-prev-page) |
4771 (select-window win))) | 6729 (select-window win))) |
4772 | 6730 |
4773 (defun gnus-insert-next-page-button () | 6731 (defun gnus-insert-next-page-button () |
4774 (let ((inhibit-read-only t)) | 6732 (let ((b (point)) |
6733 (buffer-read-only nil)) | |
4775 (gnus-eval-format gnus-next-page-line-format nil | 6734 (gnus-eval-format gnus-next-page-line-format nil |
4776 `(gnus-next | 6735 `(,@(gnus-local-map-property gnus-next-page-map) |
4777 t local-map ,gnus-next-page-map | 6736 gnus-next t |
4778 gnus-callback gnus-article-button-next-page | 6737 gnus-callback gnus-article-button-next-page |
4779 article-type annotation)))) | 6738 article-type annotation)) |
6739 (widget-convert-button | |
6740 'link b (if (bolp) | |
6741 ;; Exclude a newline. | |
6742 (1- (point)) | |
6743 (point)) | |
6744 :action 'gnus-button-next-page | |
6745 :button-keymap gnus-next-page-map))) | |
4780 | 6746 |
4781 (defun gnus-article-button-next-page (arg) | 6747 (defun gnus-article-button-next-page (arg) |
4782 "Go to the next page." | 6748 "Go to the next page." |
4783 (interactive "P") | 6749 (interactive "P") |
4784 (let ((win (selected-window))) | 6750 (let ((win (selected-window))) |
4785 (select-window (get-buffer-window gnus-article-buffer t)) | 6751 (select-window (gnus-get-buffer-window gnus-article-buffer t)) |
4786 (gnus-article-next-page) | 6752 (gnus-article-next-page) |
4787 (select-window win))) | 6753 (select-window win))) |
4788 | 6754 |
4789 (defun gnus-article-button-prev-page (arg) | 6755 (defun gnus-article-button-prev-page (arg) |
4790 "Go to the prev page." | 6756 "Go to the prev page." |
4791 (interactive "P") | 6757 (interactive "P") |
4792 (let ((win (selected-window))) | 6758 (let ((win (selected-window))) |
4793 (select-window (get-buffer-window gnus-article-buffer t)) | 6759 (select-window (gnus-get-buffer-window gnus-article-buffer t)) |
4794 (gnus-article-prev-page) | 6760 (gnus-article-prev-page) |
4795 (select-window win))) | 6761 (select-window win))) |
4796 | 6762 |
4797 (defvar gnus-decode-header-methods | 6763 (defvar gnus-decode-header-methods |
4798 '(mail-decode-encoded-word-region) | 6764 '(mail-decode-encoded-word-region) |
4799 "List of methods used to decode headers. | 6765 "List of methods used to decode headers. |
4800 | 6766 |
4801 This variable is a list of FUNCTION or (REGEXP . FUNCTION). If item | 6767 This variable is a list of FUNCTION or (REGEXP . FUNCTION). If item |
4802 is FUNCTION, FUNCTION will be applied to all newsgroups. If item is a | 6768 is FUNCTION, FUNCTION will be apply to all newsgroups. If item is a |
4803 \(REGEXP . FUNCTION), FUNCTION will be only applied to these newsgroups | 6769 \(REGEXP . FUNCTION), FUNCTION will be only apply to the newsgroups |
4804 whose names match REGEXP. | 6770 whose names match REGEXP. |
4805 | 6771 |
4806 For example: | 6772 For example: |
4807 \((\"chinese\" . gnus-decode-encoded-word-region-by-guess) | 6773 \((\"chinese\" . gnus-decode-encoded-word-region-by-guess) |
4808 mail-decode-encoded-word-region | 6774 mail-decode-encoded-word-region |
4848 (when (string-match (pop list) type) | 6814 (when (string-match (pop list) type) |
4849 (throw 'found t))))))) | 6815 (throw 'found t))))))) |
4850 (highlightp (gnus-visual-p 'article-highlight 'highlight)) | 6816 (highlightp (gnus-visual-p 'article-highlight 'highlight)) |
4851 val elem) | 6817 val elem) |
4852 (gnus-run-hooks 'gnus-part-display-hook) | 6818 (gnus-run-hooks 'gnus-part-display-hook) |
4853 (while (setq elem (pop alist)) | 6819 (dolist (elem alist) |
4854 (setq val | 6820 (setq val |
4855 (save-excursion | 6821 (save-excursion |
4856 (if (gnus-buffer-live-p gnus-summary-buffer) | 6822 (when (gnus-buffer-live-p gnus-summary-buffer) |
4857 (set-buffer gnus-summary-buffer)) | 6823 (set-buffer gnus-summary-buffer)) |
4858 (symbol-value (car elem)))) | 6824 (symbol-value (car elem)))) |
4859 (when (and (or (consp val) | 6825 (when (and (or (consp val) |
4860 treated-type) | 6826 treated-type) |
4861 (gnus-treat-predicate val) | 6827 (gnus-treat-predicate val) |
4862 (or (not (get (car elem) 'highlight)) | 6828 (or (not (get (car elem) 'highlight)) |
4874 | 6840 |
4875 (defun gnus-treat-predicate (val) | 6841 (defun gnus-treat-predicate (val) |
4876 (cond | 6842 (cond |
4877 ((null val) | 6843 ((null val) |
4878 nil) | 6844 nil) |
6845 (condition | |
6846 (eq condition val)) | |
4879 ((and (listp val) | 6847 ((and (listp val) |
4880 (stringp (car val))) | 6848 (stringp (car val))) |
4881 (apply 'gnus-or (mapcar `(lambda (s) | 6849 (apply 'gnus-or (mapcar `(lambda (s) |
4882 (string-match s ,(or gnus-newsgroup-name ""))) | 6850 (string-match s ,(or gnus-newsgroup-name ""))) |
4883 val))) | 6851 val))) |
4892 (not (gnus-treat-predicate (car val)))) | 6860 (not (gnus-treat-predicate (car val)))) |
4893 ((eq pred 'typep) | 6861 ((eq pred 'typep) |
4894 (equal (car val) type)) | 6862 (equal (car val) type)) |
4895 (t | 6863 (t |
4896 (error "%S is not a valid predicate" pred))))) | 6864 (error "%S is not a valid predicate" pred))))) |
4897 (condition | |
4898 (eq condition val)) | |
4899 ((eq val t) | 6865 ((eq val t) |
4900 t) | 6866 t) |
4901 ((eq val 'head) | 6867 ((eq val 'head) |
4902 nil) | 6868 nil) |
4903 ((eq val 'last) | 6869 ((eq val 'last) |
4905 ((numberp val) | 6871 ((numberp val) |
4906 (< length val)) | 6872 (< length val)) |
4907 (t | 6873 (t |
4908 (error "%S is not a valid value" val)))) | 6874 (error "%S is not a valid value" val)))) |
4909 | 6875 |
6876 (defun gnus-article-encrypt-body (protocol &optional n) | |
6877 "Encrypt the article body." | |
6878 (interactive | |
6879 (list | |
6880 (or gnus-article-encrypt-protocol | |
6881 (completing-read "Encrypt protocol: " | |
6882 gnus-article-encrypt-protocol-alist | |
6883 nil t)) | |
6884 current-prefix-arg)) | |
6885 (let ((func (cdr (assoc protocol gnus-article-encrypt-protocol-alist)))) | |
6886 (unless func | |
6887 (error (format "Can't find the encrypt protocol %s" protocol))) | |
6888 (if (member gnus-newsgroup-name '("nndraft:delayed" | |
6889 "nndraft:drafts" | |
6890 "nndraft:queue")) | |
6891 (error "Can't encrypt the article in group %s" | |
6892 gnus-newsgroup-name)) | |
6893 (gnus-summary-iterate n | |
6894 (save-excursion | |
6895 (set-buffer gnus-summary-buffer) | |
6896 (let ((mail-parse-charset gnus-newsgroup-charset) | |
6897 (mail-parse-ignored-charsets gnus-newsgroup-ignored-charsets) | |
6898 (summary-buffer gnus-summary-buffer) | |
6899 references point) | |
6900 (gnus-set-global-variables) | |
6901 (when (gnus-group-read-only-p) | |
6902 (error "The current newsgroup does not support article encrypt")) | |
6903 (gnus-summary-show-article t) | |
6904 (setq references | |
6905 (or (mail-header-references gnus-current-headers) "")) | |
6906 (set-buffer gnus-article-buffer) | |
6907 (let* ((buffer-read-only nil) | |
6908 (headers | |
6909 (mapcar (lambda (field) | |
6910 (and (save-restriction | |
6911 (message-narrow-to-head) | |
6912 (goto-char (point-min)) | |
6913 (search-forward field nil t)) | |
6914 (prog2 | |
6915 (message-narrow-to-field) | |
6916 (buffer-string) | |
6917 (delete-region (point-min) (point-max)) | |
6918 (widen)))) | |
6919 '("Content-Type:" "Content-Transfer-Encoding:" | |
6920 "Content-Disposition:")))) | |
6921 (message-narrow-to-head) | |
6922 (message-remove-header "MIME-Version") | |
6923 (goto-char (point-max)) | |
6924 (setq point (point)) | |
6925 (insert (apply 'concat headers)) | |
6926 (widen) | |
6927 (narrow-to-region point (point-max)) | |
6928 (let ((message-options message-options)) | |
6929 (message-options-set 'message-sender user-mail-address) | |
6930 (message-options-set 'message-recipients user-mail-address) | |
6931 (message-options-set 'message-sign-encrypt 'not) | |
6932 (funcall func)) | |
6933 (goto-char (point-min)) | |
6934 (insert "MIME-Version: 1.0\n") | |
6935 (widen) | |
6936 (gnus-summary-edit-article-done | |
6937 references nil summary-buffer t)) | |
6938 (when gnus-keep-backlog | |
6939 (gnus-backlog-remove-article | |
6940 (car gnus-article-current) (cdr gnus-article-current))) | |
6941 (save-excursion | |
6942 (when (get-buffer gnus-original-article-buffer) | |
6943 (set-buffer gnus-original-article-buffer) | |
6944 (setq gnus-original-article nil))) | |
6945 (when gnus-use-cache | |
6946 (gnus-cache-update-article | |
6947 (car gnus-article-current) (cdr gnus-article-current)))))))) | |
6948 | |
6949 (defvar gnus-mime-security-button-line-format "%{%([[%t:%i]%D]%)%}\n" | |
6950 "The following specs can be used: | |
6951 %t The security MIME type | |
6952 %i Additional info | |
6953 %d Details | |
6954 %D Details if button is pressed") | |
6955 | |
6956 (defvar gnus-mime-security-button-end-line-format "%{%([[End of %t]%D]%)%}\n" | |
6957 "The following specs can be used: | |
6958 %t The security MIME type | |
6959 %i Additional info | |
6960 %d Details | |
6961 %D Details if button is pressed") | |
6962 | |
6963 (defvar gnus-mime-security-button-line-format-alist | |
6964 '((?t gnus-tmp-type ?s) | |
6965 (?i gnus-tmp-info ?s) | |
6966 (?d gnus-tmp-details ?s) | |
6967 (?D gnus-tmp-pressed-details ?s))) | |
6968 | |
6969 (defvar gnus-mime-security-button-map | |
6970 (let ((map (make-sparse-keymap))) | |
6971 (unless (>= (string-to-number emacs-version) 21) | |
6972 (set-keymap-parent map gnus-article-mode-map)) | |
6973 (define-key map gnus-mouse-2 'gnus-article-push-button) | |
6974 (define-key map "\r" 'gnus-article-press-button) | |
6975 map)) | |
6976 | |
6977 (defvar gnus-mime-security-details-buffer nil) | |
6978 | |
6979 (defvar gnus-mime-security-button-pressed nil) | |
6980 | |
6981 (defvar gnus-mime-security-show-details-inline t | |
6982 "If non-nil, show details in the article buffer.") | |
6983 | |
6984 (defun gnus-mime-security-verify-or-decrypt (handle) | |
6985 (mm-remove-parts (cdr handle)) | |
6986 (let ((region (mm-handle-multipart-ctl-parameter handle 'gnus-region)) | |
6987 point buffer-read-only) | |
6988 (if region | |
6989 (goto-char (car region))) | |
6990 (save-restriction | |
6991 (narrow-to-region (point) (point)) | |
6992 (with-current-buffer (mm-handle-multipart-original-buffer handle) | |
6993 (let* ((mm-verify-option 'known) | |
6994 (mm-decrypt-option 'known) | |
6995 (nparts (mm-possibly-verify-or-decrypt (cdr handle) handle))) | |
6996 (unless (eq nparts (cdr handle)) | |
6997 (mm-destroy-parts (cdr handle)) | |
6998 (setcdr handle nparts)))) | |
6999 (setq point (point)) | |
7000 (gnus-mime-display-security handle) | |
7001 (goto-char (point-max))) | |
7002 (when region | |
7003 (delete-region (point) (cdr region)) | |
7004 (set-marker (car region) nil) | |
7005 (set-marker (cdr region) nil)) | |
7006 (goto-char point))) | |
7007 | |
7008 (defun gnus-mime-security-show-details (handle) | |
7009 (let ((details (mm-handle-multipart-ctl-parameter handle 'gnus-details))) | |
7010 (if (not details) | |
7011 (gnus-message 5 "No details.") | |
7012 (if gnus-mime-security-show-details-inline | |
7013 (let ((gnus-mime-security-button-pressed | |
7014 (not (get-text-property (point) 'gnus-mime-details))) | |
7015 (gnus-mime-security-button-line-format | |
7016 (get-text-property (point) 'gnus-line-format)) | |
7017 buffer-read-only) | |
7018 (forward-char -1) | |
7019 (while (eq (get-text-property (point) 'gnus-line-format) | |
7020 gnus-mime-security-button-line-format) | |
7021 (forward-char -1)) | |
7022 (forward-char) | |
7023 (save-restriction | |
7024 (narrow-to-region (point) (point)) | |
7025 (gnus-insert-mime-security-button handle)) | |
7026 (delete-region (point) | |
7027 (or (text-property-not-all | |
7028 (point) (point-max) | |
7029 'gnus-line-format | |
7030 gnus-mime-security-button-line-format) | |
7031 (point-max)))) | |
7032 ;; Not inlined. | |
7033 (if (gnus-buffer-live-p gnus-mime-security-details-buffer) | |
7034 (with-current-buffer gnus-mime-security-details-buffer | |
7035 (erase-buffer) | |
7036 t) | |
7037 (setq gnus-mime-security-details-buffer | |
7038 (gnus-get-buffer-create "*MIME Security Details*"))) | |
7039 (with-current-buffer gnus-mime-security-details-buffer | |
7040 (insert details) | |
7041 (goto-char (point-min))) | |
7042 (pop-to-buffer gnus-mime-security-details-buffer))))) | |
7043 | |
7044 (defun gnus-mime-security-press-button (handle) | |
7045 (save-excursion | |
7046 (if (mm-handle-multipart-ctl-parameter handle 'gnus-info) | |
7047 (gnus-mime-security-show-details handle) | |
7048 (gnus-mime-security-verify-or-decrypt handle)))) | |
7049 | |
7050 (defun gnus-insert-mime-security-button (handle &optional displayed) | |
7051 (let* ((protocol (mm-handle-multipart-ctl-parameter handle 'protocol)) | |
7052 (gnus-tmp-type | |
7053 (concat | |
7054 (or (nth 2 (assoc protocol mm-verify-function-alist)) | |
7055 (nth 2 (assoc protocol mm-decrypt-function-alist)) | |
7056 "Unknown") | |
7057 (if (equal (car handle) "multipart/signed") | |
7058 " Signed" " Encrypted") | |
7059 " Part")) | |
7060 (gnus-tmp-info | |
7061 (or (mm-handle-multipart-ctl-parameter handle 'gnus-info) | |
7062 "Undecided")) | |
7063 (gnus-tmp-details | |
7064 (mm-handle-multipart-ctl-parameter handle 'gnus-details)) | |
7065 gnus-tmp-pressed-details | |
7066 b e) | |
7067 (setq gnus-tmp-details | |
7068 (if gnus-tmp-details | |
7069 (concat "\n" gnus-tmp-details) | |
7070 "")) | |
7071 (setq gnus-tmp-pressed-details | |
7072 (if gnus-mime-security-button-pressed gnus-tmp-details "")) | |
7073 (unless (bolp) | |
7074 (insert "\n")) | |
7075 (setq b (point)) | |
7076 (gnus-eval-format | |
7077 gnus-mime-security-button-line-format | |
7078 gnus-mime-security-button-line-format-alist | |
7079 `(,@(gnus-local-map-property gnus-mime-security-button-map) | |
7080 gnus-callback gnus-mime-security-press-button | |
7081 gnus-line-format ,gnus-mime-security-button-line-format | |
7082 gnus-mime-details ,gnus-mime-security-button-pressed | |
7083 article-type annotation | |
7084 gnus-data ,handle)) | |
7085 (setq e (if (bolp) | |
7086 ;; Exclude a newline. | |
7087 (1- (point)) | |
7088 (point))) | |
7089 (widget-convert-button | |
7090 'link b e | |
7091 :mime-handle handle | |
7092 :action 'gnus-widget-press-button | |
7093 :button-keymap gnus-mime-security-button-map | |
7094 :help-echo | |
7095 (lambda (widget/window &optional overlay pos) | |
7096 ;; Needed to properly clear the message due to a bug in | |
7097 ;; wid-edit (XEmacs only). | |
7098 (when (boundp 'help-echo-owns-message) | |
7099 (setq help-echo-owns-message t)) | |
7100 (format | |
7101 "%S: show detail" | |
7102 (aref gnus-mouse-2 0)))))) | |
7103 | |
7104 (defun gnus-mime-display-security (handle) | |
7105 (save-restriction | |
7106 (narrow-to-region (point) (point)) | |
7107 (unless (gnus-unbuttonized-mime-type-p (car handle)) | |
7108 (gnus-insert-mime-security-button handle)) | |
7109 (gnus-mime-display-mixed (cdr handle)) | |
7110 (unless (bolp) | |
7111 (insert "\n")) | |
7112 (unless (gnus-unbuttonized-mime-type-p (car handle)) | |
7113 (let ((gnus-mime-security-button-line-format | |
7114 gnus-mime-security-button-end-line-format)) | |
7115 (gnus-insert-mime-security-button handle))) | |
7116 (mm-set-handle-multipart-parameter | |
7117 handle 'gnus-region | |
7118 (cons (set-marker (make-marker) (point-min)) | |
7119 (set-marker (make-marker) (point-max)))))) | |
7120 | |
4910 (gnus-ems-redefine) | 7121 (gnus-ems-redefine) |
4911 | 7122 |
4912 (provide 'gnus-art) | 7123 (provide 'gnus-art) |
4913 | 7124 |
4914 (run-hooks 'gnus-art-load-hook) | 7125 (run-hooks 'gnus-art-load-hook) |