Mercurial > emacs
annotate lisp/gnus/gnus-art.el @ 19969:5f1ab3dd344d
*** empty log message ***
author | Lars Magne Ingebrigtsen <larsi@gnus.org> |
---|---|
date | Wed, 24 Sep 1997 01:50:24 +0000 |
parents | 2a7342ecf59d |
children | 2c30b1fb6409 |
rev | line source |
---|---|
17493 | 1 ;;; gnus-art.el --- article mode commands for Gnus |
2 ;; Copyright (C) 1996,97 Free Software Foundation, Inc. | |
3 | |
4 ;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> | |
5 ;; Keywords: news | |
6 | |
7 ;; This file is part of GNU Emacs. | |
8 | |
9 ;; GNU Emacs is free software; you can redistribute it and/or modify | |
10 ;; it under the terms of the GNU General Public License as published by | |
11 ;; the Free Software Foundation; either version 2, or (at your option) | |
12 ;; any later version. | |
13 | |
14 ;; GNU Emacs is distributed in the hope that it will be useful, | |
15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
17 ;; GNU General Public License for more details. | |
18 | |
19 ;; You should have received a copy of the GNU General Public License | |
20 ;; along with GNU Emacs; see the file COPYING. If not, write to the | |
21 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
22 ;; Boston, MA 02111-1307, USA. | |
23 | |
24 ;;; Commentary: | |
25 | |
26 ;;; Code: | |
27 | |
19521
6f6cf9184e93
Require cl at compile time.
Richard M. Stallman <rms@gnu.org>
parents:
17493
diff
changeset
|
28 (eval-when-compile (require 'cl)) |
6f6cf9184e93
Require cl at compile time.
Richard M. Stallman <rms@gnu.org>
parents:
17493
diff
changeset
|
29 |
17493 | 30 (require 'custom) |
31 (require 'gnus) | |
32 (require 'gnus-sum) | |
33 (require 'gnus-spec) | |
34 (require 'gnus-int) | |
35 (require 'browse-url) | |
36 | |
37 (defgroup gnus-article nil | |
38 "Article display." | |
39 :link '(custom-manual "(gnus)The Article Buffer") | |
40 :group 'gnus) | |
41 | |
42 (defgroup gnus-article-hiding nil | |
43 "Hiding article parts." | |
44 :link '(custom-manual "(gnus)Article Hiding") | |
45 :group 'gnus-article) | |
46 | |
47 (defgroup gnus-article-highlight nil | |
48 "Article highlighting." | |
49 :link '(custom-manual "(gnus)Article Highlighting") | |
50 :group 'gnus-article | |
51 :group 'gnus-visual) | |
52 | |
53 (defgroup gnus-article-signature nil | |
54 "Article signatures." | |
55 :link '(custom-manual "(gnus)Article Signature") | |
56 :group 'gnus-article) | |
57 | |
58 (defgroup gnus-article-headers nil | |
59 "Article headers." | |
60 :link '(custom-manual "(gnus)Hiding Headers") | |
61 :group 'gnus-article) | |
62 | |
63 (defgroup gnus-article-washing nil | |
64 "Special commands on articles." | |
65 :link '(custom-manual "(gnus)Article Washing") | |
66 :group 'gnus-article) | |
67 | |
68 (defgroup gnus-article-emphasis nil | |
69 "Fontisizing articles." | |
70 :link '(custom-manual "(gnus)Article Fontisizing") | |
71 :group 'gnus-article) | |
72 | |
73 (defgroup gnus-article-saving nil | |
74 "Saving articles." | |
75 :link '(custom-manual "(gnus)Saving Articles") | |
76 :group 'gnus-article) | |
77 | |
78 (defgroup gnus-article-mime nil | |
79 "Worshiping the MIME wonder." | |
80 :link '(custom-manual "(gnus)Using MIME") | |
81 :group 'gnus-article) | |
82 | |
83 (defgroup gnus-article-buttons nil | |
84 "Pushable buttons in the article buffer." | |
85 :link '(custom-manual "(gnus)Article Buttons") | |
86 :group 'gnus-article) | |
87 | |
88 (defgroup gnus-article-various nil | |
89 "Other article options." | |
90 :link '(custom-manual "(gnus)Misc Article") | |
91 :group 'gnus-article) | |
92 | |
93 (defcustom gnus-ignored-headers | |
94 '("^Path:" "^Posting-Version:" "^Article-I.D.:" "^Expires:" | |
95 "^Date-Received:" "^References:" "^Control:" "^Xref:" "^Lines:" | |
96 "^Posted:" "^Relay-Version:" "^Message-ID:" "^Nf-ID:" "^Nf-From:" | |
97 "^Approved:" "^Sender:" "^Received:" "^Mail-from:") | |
98 "All headers that match this regexp will be hidden. | |
99 This variable can also be a list of regexps of headers to be ignored. | |
100 If `gnus-visible-headers' is non-nil, this variable will be ignored." | |
101 :type '(choice :custom-show nil | |
102 regexp | |
103 (repeat regexp)) | |
104 :group 'gnus-article-hiding) | |
105 | |
106 (defcustom gnus-visible-headers | |
107 "^From:\\|^Newsgroups:\\|^Subject:\\|^Date:\\|^Followup-To:\\|^Reply-To:\\|^Organization:\\|^Summary:\\|^Keywords:\\|^To:\\|^Cc:\\|^Posted-To:\\|^Mail-Copies-To:\\|^Apparently-To:\\|^Gnus-Warning:\\|^Resent-From" | |
108 "All headers that do not match this regexp will be hidden. | |
109 This variable can also be a list of regexp of headers to remain visible. | |
110 If this variable is non-nil, `gnus-ignored-headers' will be ignored." | |
111 :type '(repeat :value-to-internal (lambda (widget value) | |
112 (custom-split-regexp-maybe value)) | |
113 :match (lambda (widget value) | |
114 (or (stringp value) | |
115 (widget-editable-list-match widget value))) | |
116 regexp) | |
117 :group 'gnus-article-hiding) | |
118 | |
119 (defcustom gnus-sorted-header-list | |
120 '("^From:" "^Subject:" "^Summary:" "^Keywords:" "^Newsgroups:" | |
121 "^Followup-To:" "^To:" "^Cc:" "^Date:" "^Organization:") | |
122 "This variable is a list of regular expressions. | |
123 If it is non-nil, headers that match the regular expressions will | |
124 be placed first in the article buffer in the sequence specified by | |
125 this list." | |
126 :type '(repeat regexp) | |
127 :group 'gnus-article-hiding) | |
128 | |
129 (defcustom gnus-boring-article-headers '(empty followup-to reply-to) | |
130 "Headers that are only to be displayed if they have interesting data. | |
131 Possible values in this list are `empty', `newsgroups', `followup-to', | |
132 `reply-to', and `date'." | |
133 :type '(set (const :tag "Headers with no content." empty) | |
134 (const :tag "Newsgroups with only one group." newsgroups) | |
135 (const :tag "Followup-to identical to newsgroups." followup-to) | |
136 (const :tag "Reply-to identical to from." reply-to) | |
137 (const :tag "Date less than four days old." date)) | |
138 :group 'gnus-article-hiding) | |
139 | |
140 (defcustom gnus-signature-separator '("^-- $" "^-- *$") | |
141 "Regexp matching signature separator. | |
142 This can also be a list of regexps. In that case, it will be checked | |
143 from head to tail looking for a separator. Searches will be done from | |
144 the end of the buffer." | |
145 :type '(repeat string) | |
146 :group 'gnus-article-signature) | |
147 | |
148 (defcustom gnus-signature-limit nil | |
149 "Provide a limit to what is considered a signature. | |
150 If it is a number, no signature may not be longer (in characters) than | |
151 that number. If it is a floating point number, no signature may be | |
152 longer (in lines) than that number. If it is a function, the function | |
153 will be called without any parameters, and if it returns nil, there is | |
154 no signature in the buffer. If it is a string, it will be used as a | |
155 regexp. If it matches, the text in question is not a signature." | |
156 :type '(choice integer number function regexp) | |
157 :group 'gnus-article-signature) | |
158 | |
159 (defcustom gnus-hidden-properties '(invisible t intangible t) | |
160 "Property list to use for hiding text." | |
161 :type 'sexp | |
162 :group 'gnus-article-hiding) | |
163 | |
164 (defcustom gnus-article-x-face-command | |
165 "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | xv -quit -" | |
166 "String or function to be executed to display an X-Face header. | |
167 If it is a string, the command will be executed in a sub-shell | |
168 asynchronously. The compressed face will be piped to this command." | |
169 :type 'string ;Leave function case to Lisp. | |
170 :group 'gnus-article-washing) | |
171 | |
172 (defcustom gnus-article-x-face-too-ugly nil | |
173 "Regexp matching posters whose face shouldn't be shown automatically." | |
174 :type 'regexp | |
175 :group 'gnus-article-washing) | |
176 | |
177 (defcustom gnus-emphasis-alist | |
178 (let ((format | |
179 "\\(\\s-\\|^\\|[-\"]\\|\\s(\\|\\s)\\)\\(%s\\(\\w+\\(\\s-+\\w+\\)*[.,]?\\)%s\\)\\(\\s-\\|[-?!.,;:\"]\\|\\s(\\|\\s)\\)") | |
180 (types | |
181 '(("_" "_" underline) | |
182 ("/" "/" italic) | |
183 ("\\*" "\\*" bold) | |
184 ("_/" "/_" underline-italic) | |
185 ("_\\*" "\\*_" underline-bold) | |
186 ("\\*/" "/\\*" bold-italic) | |
187 ("_\\*/" "/\\*_" underline-bold-italic)))) | |
188 `(("\\(\\s-\\|^\\)\\(_\\(\\(\\w\\|_[^_]\\)+\\)_\\)\\(\\s-\\|[?!.,;]\\)" | |
189 2 3 gnus-emphasis-underline) | |
190 ,@(mapcar | |
191 (lambda (spec) | |
192 (list | |
193 (format format (car spec) (cadr spec)) | |
19969
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
194 2 3 (intern (format "gnus-emphasis-%s" (caddr spec))))) |
17493 | 195 types))) |
196 "Alist that says how to fontify certain phrases. | |
197 Each item looks like this: | |
198 | |
199 (\"_\\\\(\\\\w+\\\\)_\" 0 1 'underline) | |
200 | |
201 The first element is a regular expression to be matched. The second | |
202 is a number that says what regular expression grouping used to find | |
203 the entire emphasized word. The third is a number that says what | |
204 regexp grouping should be displayed and highlighted. The fourth | |
205 is the face used for highlighting." | |
206 :type '(repeat (list :value ("" 0 0 default) | |
207 regexp | |
208 (integer :tag "Match group") | |
209 (integer :tag "Emphasize group") | |
210 face)) | |
211 :group 'gnus-article-emphasis) | |
212 | |
213 (defface gnus-emphasis-bold '((t (:bold t))) | |
214 "Face used for displaying strong emphasized text (*word*)." | |
215 :group 'gnus-article-emphasis) | |
216 | |
217 (defface gnus-emphasis-italic '((t (:italic t))) | |
218 "Face used for displaying italic emphasized text (/word/)." | |
219 :group 'gnus-article-emphasis) | |
220 | |
221 (defface gnus-emphasis-underline '((t (:underline t))) | |
222 "Face used for displaying underlined emphasized text (_word_)." | |
223 :group 'gnus-article-emphasis) | |
224 | |
225 (defface gnus-emphasis-underline-bold '((t (:bold t :underline t))) | |
226 "Face used for displaying underlined bold emphasized text (_*word*_)." | |
227 :group 'gnus-article-emphasis) | |
228 | |
229 (defface gnus-emphasis-underline-italic '((t (:italic t :underline t))) | |
230 "Face used for displaying underlined italic emphasized text (_*word*_)." | |
231 :group 'gnus-article-emphasis) | |
232 | |
233 (defface gnus-emphasis-bold-italic '((t (:bold t :italic t))) | |
234 "Face used for displaying bold italic emphasized text (/*word*/)." | |
235 :group 'gnus-article-emphasis) | |
236 | |
237 (defface gnus-emphasis-underline-bold-italic | |
238 '((t (:bold t :italic t :underline t))) | |
239 "Face used for displaying underlined bold italic emphasized text. | |
240 Esample: (_/*word*/_)." | |
241 :group 'gnus-article-emphasis) | |
242 | |
243 (defcustom gnus-article-time-format "%a, %b %d %Y %T %Z" | |
244 "Format for display of Date headers in article bodies. | |
245 See `format-time-zone' for the possible values." | |
246 :type 'string | |
247 :link '(custom-manual "(gnus)Article Date") | |
248 :group 'gnus-article-washing) | |
249 | |
250 (eval-and-compile | |
251 (autoload 'hexl-hex-string-to-integer "hexl") | |
252 (autoload 'timezone-make-date-arpa-standard "timezone") | |
253 (autoload 'mail-extract-address-components "mail-extr")) | |
254 | |
255 (defcustom gnus-save-all-headers t | |
256 "*If non-nil, don't remove any headers before saving." | |
257 :group 'gnus-article-saving | |
258 :type 'boolean) | |
259 | |
260 (defcustom gnus-prompt-before-saving 'always | |
261 "*This variable says how much prompting is to be done when saving articles. | |
262 If it is nil, no prompting will be done, and the articles will be | |
263 saved to the default files. If this variable is `always', each and | |
264 every article that is saved will be preceded by a prompt, even when | |
265 saving large batches of articles. If this variable is neither nil not | |
266 `always', there the user will be prompted once for a file name for | |
267 each invocation of the saving commands." | |
268 :group 'gnus-article-saving | |
269 :type '(choice (item always) | |
270 (item :tag "never" nil) | |
271 (sexp :tag "once" :format "%t"))) | |
272 | |
273 (defcustom gnus-saved-headers gnus-visible-headers | |
274 "Headers to keep if `gnus-save-all-headers' is nil. | |
275 If `gnus-save-all-headers' is non-nil, this variable will be ignored. | |
276 If that variable is nil, however, all headers that match this regexp | |
277 will be kept while the rest will be deleted before saving." | |
278 :group 'gnus-article-saving | |
279 :type '(repeat string)) | |
280 | |
281 (defcustom gnus-default-article-saver 'gnus-summary-save-in-rmail | |
282 "A function to save articles in your favourite format. | |
283 The function must be interactively callable (in other words, it must | |
284 be an Emacs command). | |
285 | |
286 Gnus provides the following functions: | |
287 | |
288 * gnus-summary-save-in-rmail (Rmail format) | |
289 * gnus-summary-save-in-mail (Unix mail format) | |
290 * gnus-summary-save-in-folder (MH folder) | |
291 * gnus-summary-save-in-file (article format) | |
292 * gnus-summary-save-in-vm (use VM's folder format) | |
293 * gnus-summary-write-to-file (article format -- overwrite)." | |
294 :group 'gnus-article-saving | |
295 :type '(radio (function-item gnus-summary-save-in-rmail) | |
296 (function-item gnus-summary-save-in-mail) | |
297 (function-item gnus-summary-save-in-folder) | |
298 (function-item gnus-summary-save-in-file) | |
299 (function-item gnus-summary-save-in-vm) | |
300 (function-item gnus-summary-write-to-file))) | |
301 | |
302 (defcustom gnus-rmail-save-name 'gnus-plain-save-name | |
303 "A function generating a file name to save articles in Rmail format. | |
304 The function is called with NEWSGROUP, HEADERS, and optional LAST-FILE." | |
305 :group 'gnus-article-saving | |
306 :type 'function) | |
307 | |
308 (defcustom gnus-mail-save-name 'gnus-plain-save-name | |
309 "A function generating a file name to save articles in Unix mail format. | |
310 The function is called with NEWSGROUP, HEADERS, and optional LAST-FILE." | |
311 :group 'gnus-article-saving | |
312 :type 'function) | |
313 | |
314 (defcustom gnus-folder-save-name 'gnus-folder-save-name | |
315 "A function generating a file name to save articles in MH folder. | |
316 The function is called with NEWSGROUP, HEADERS, and optional LAST-FOLDER." | |
317 :group 'gnus-article-saving | |
318 :type 'function) | |
319 | |
320 (defcustom gnus-file-save-name 'gnus-numeric-save-name | |
321 "A function generating a file name to save articles in article format. | |
322 The function is called with NEWSGROUP, HEADERS, and optional | |
323 LAST-FILE." | |
324 :group 'gnus-article-saving | |
325 :type 'function) | |
326 | |
327 (defcustom gnus-split-methods | |
328 '((gnus-article-archive-name) | |
329 (gnus-article-nndoc-name)) | |
330 "Variable used to suggest where articles are to be saved. | |
331 For instance, if you would like to save articles related to Gnus in | |
332 the file \"gnus-stuff\", and articles related to VM in \"vm-stuff\", | |
333 you could set this variable to something like: | |
334 | |
335 '((\"^Subject:.*gnus\\|^Newsgroups:.*gnus\" \"gnus-stuff\") | |
336 (\"^Subject:.*vm\\|^Xref:.*vm\" \"vm-stuff\")) | |
337 | |
338 This variable is an alist where the where the key is the match and the | |
339 value is a list of possible files to save in if the match is non-nil. | |
340 | |
341 If the match is a string, it is used as a regexp match on the | |
342 article. If the match is a symbol, that symbol will be funcalled | |
343 from the buffer of the article to be saved with the newsgroup as the | |
344 parameter. If it is a list, it will be evaled in the same buffer. | |
345 | |
346 If this form or function returns a string, this string will be used as | |
347 a possible file name; and if it returns a non-nil list, that list will | |
348 be used as possible file names." | |
349 :group 'gnus-article-saving | |
350 :type '(repeat (choice (list function) | |
351 (cons regexp (repeat string)) | |
352 sexp))) | |
353 | |
354 (defcustom gnus-strict-mime t | |
355 "*If nil, MIME-decode even if there is no Mime-Version header." | |
356 :group 'gnus-article-mime | |
357 :type 'boolean) | |
358 | |
359 (defcustom gnus-show-mime-method 'metamail-buffer | |
360 "Function to process a MIME message. | |
361 The function is called from the article buffer." | |
362 :group 'gnus-article-mime | |
363 :type 'function) | |
364 | |
365 (defcustom gnus-decode-encoded-word-method 'gnus-article-de-quoted-unreadable | |
366 "*Function to decode MIME encoded words. | |
367 The function is called from the article buffer." | |
368 :group 'gnus-article-mime | |
369 :type 'function) | |
370 | |
371 (defcustom gnus-page-delimiter "^\^L" | |
372 "*Regexp describing what to use as article page delimiters. | |
373 The default value is \"^\^L\", which is a form linefeed at the | |
374 beginning of a line." | |
375 :type 'regexp | |
376 :group 'gnus-article-various) | |
377 | |
378 (defcustom gnus-article-mode-line-format "Gnus: %%b %S" | |
379 "*The format specification for the article mode line. | |
380 See `gnus-summary-mode-line-format' for a closer description." | |
381 :type 'string | |
382 :group 'gnus-article-various) | |
383 | |
384 (defcustom gnus-article-mode-hook nil | |
385 "*A hook for Gnus article mode." | |
386 :type 'hook | |
387 :group 'gnus-article-various) | |
388 | |
389 (defcustom gnus-article-menu-hook nil | |
390 "*Hook run after the creation of the article mode menu." | |
391 :type 'hook | |
392 :group 'gnus-article-various) | |
393 | |
394 (defcustom gnus-article-prepare-hook nil | |
395 "*A hook called after an article has been prepared in the article buffer. | |
396 If you want to run a special decoding program like nkf, use this hook." | |
397 :type 'hook | |
398 :group 'gnus-article-various) | |
399 | |
19969
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
400 (defcustom gnus-article-hide-pgp-hook nil |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
401 "*A hook called after successfully hiding a PGP signature." |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
402 :type 'hook |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
403 :group 'gnus-article-various) |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
404 |
17493 | 405 (defcustom gnus-article-button-face 'bold |
406 "Face used for highlighting buttons in the article buffer. | |
407 | |
408 An article button is a piece of text that you can activate by pressing | |
409 `RET' or `mouse-2' above it." | |
410 :type 'face | |
411 :group 'gnus-article-buttons) | |
412 | |
413 (defcustom gnus-article-mouse-face 'highlight | |
414 "Face used for mouse highlighting in the article buffer. | |
415 | |
416 Article buttons will be displayed in this face when the cursor is | |
417 above them." | |
418 :type 'face | |
419 :group 'gnus-article-buttons) | |
420 | |
19969
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
421 (defcustom gnus-signature-face 'gnus-signature-face |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
422 "Face used for highlighting a signature in the article buffer. |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
423 Obsolete; use the face `gnus-signature-face' for customizations instead." |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
424 :type 'face |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
425 :group 'gnus-article-highlight |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
426 :group 'gnus-article-signature) |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
427 |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
428 (defface gnus-signature-face |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
429 '((((type x)) |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
430 (:italic t))) |
17493 | 431 "Face used for highlighting a signature in the article buffer." |
432 :group 'gnus-article-highlight | |
433 :group 'gnus-article-signature) | |
434 | |
435 (defface gnus-header-from-face | |
436 '((((class color) | |
437 (background dark)) | |
438 (:foreground "spring green" :bold t)) | |
439 (((class color) | |
440 (background light)) | |
441 (:foreground "red3" :bold t)) | |
442 (t | |
443 (:bold t :italic t))) | |
444 "Face used for displaying from headers." | |
445 :group 'gnus-article-headers | |
446 :group 'gnus-article-highlight) | |
447 | |
448 (defface gnus-header-subject-face | |
449 '((((class color) | |
450 (background dark)) | |
451 (:foreground "SeaGreen3" :bold t)) | |
452 (((class color) | |
453 (background light)) | |
454 (:foreground "red4" :bold t)) | |
455 (t | |
456 (:bold t :italic t))) | |
457 "Face used for displaying subject headers." | |
458 :group 'gnus-article-headers | |
459 :group 'gnus-article-highlight) | |
460 | |
461 (defface gnus-header-newsgroups-face | |
462 '((((class color) | |
463 (background dark)) | |
464 (:foreground "yellow" :bold t :italic t)) | |
465 (((class color) | |
466 (background light)) | |
467 (:foreground "MidnightBlue" :bold t :italic t)) | |
468 (t | |
469 (:bold t :italic t))) | |
470 "Face used for displaying newsgroups headers." | |
471 :group 'gnus-article-headers | |
472 :group 'gnus-article-highlight) | |
473 | |
474 (defface gnus-header-name-face | |
475 '((((class color) | |
476 (background dark)) | |
477 (:foreground "SeaGreen")) | |
478 (((class color) | |
479 (background light)) | |
480 (:foreground "maroon")) | |
481 (t | |
482 (:bold t))) | |
483 "Face used for displaying header names." | |
484 :group 'gnus-article-headers | |
485 :group 'gnus-article-highlight) | |
486 | |
487 (defface gnus-header-content-face | |
488 '((((class color) | |
489 (background dark)) | |
490 (:foreground "forest green" :italic t)) | |
491 (((class color) | |
492 (background light)) | |
493 (:foreground "indianred4" :italic t)) | |
494 (t | |
495 (:italic t))) "Face used for displaying header content." | |
496 :group 'gnus-article-headers | |
497 :group 'gnus-article-highlight) | |
498 | |
499 (defcustom gnus-header-face-alist | |
500 '(("From" nil gnus-header-from-face) | |
501 ("Subject" nil gnus-header-subject-face) | |
502 ("Newsgroups:.*," nil gnus-header-newsgroups-face) | |
503 ("" gnus-header-name-face gnus-header-content-face)) | |
504 "Controls highlighting of article header. | |
505 | |
506 An alist of the form (HEADER NAME CONTENT). | |
507 | |
508 HEADER is a regular expression which should match the name of an | |
509 header header and NAME and CONTENT are either face names or nil. | |
510 | |
511 The name of each header field will be displayed using the face | |
512 specified by the first element in the list where HEADER match the | |
513 header name and NAME is non-nil. Similarly, the content will be | |
514 displayed by the first non-nil matching CONTENT face." | |
515 :group 'gnus-article-headers | |
516 :group 'gnus-article-highlight | |
517 :type '(repeat (list (regexp :tag "Header") | |
518 (choice :tag "Name" | |
519 (item :tag "skip" nil) | |
520 (face :value default)) | |
521 (choice :tag "Content" | |
522 (item :tag "skip" nil) | |
523 (face :value default))))) | |
524 | |
525 ;;; Internal variables | |
526 | |
527 (defvar gnus-article-mode-syntax-table | |
528 (let ((table (copy-syntax-table text-mode-syntax-table))) | |
529 (modify-syntax-entry ?- "w" table) | |
530 (modify-syntax-entry ?> ")" table) | |
531 (modify-syntax-entry ?< "(" table) | |
532 table) | |
533 "Syntax table used in article mode buffers. | |
534 Initialized from `text-mode-syntax-table.") | |
535 | |
536 (defvar gnus-save-article-buffer nil) | |
537 | |
538 (defvar gnus-article-mode-line-format-alist | |
539 (nconc '((?w (gnus-article-wash-status) ?s)) | |
540 gnus-summary-mode-line-format-alist)) | |
541 | |
542 (defvar gnus-number-of-articles-to-be-saved nil) | |
543 | |
544 (defvar gnus-inhibit-hiding nil) | |
545 | |
546 (defsubst gnus-article-hide-text (b e props) | |
547 "Set text PROPS on the B to E region, extending `intangible' 1 past B." | |
548 (add-text-properties b e props) | |
549 (when (memq 'intangible props) | |
550 (put-text-property | |
551 (max (1- b) (point-min)) | |
552 b 'intangible (cddr (memq 'intangible props))))) | |
553 | |
554 (defsubst gnus-article-unhide-text (b e) | |
555 "Remove hidden text properties from region between B and E." | |
556 (remove-text-properties b e gnus-hidden-properties) | |
557 (when (memq 'intangible gnus-hidden-properties) | |
558 (put-text-property (max (1- b) (point-min)) | |
559 b 'intangible nil))) | |
560 | |
561 (defun gnus-article-hide-text-type (b e type) | |
562 "Hide text of TYPE between B and E." | |
563 (gnus-article-hide-text | |
564 b e (cons 'article-type (cons type gnus-hidden-properties)))) | |
565 | |
566 (defun gnus-article-unhide-text-type (b e type) | |
567 "Hide text of TYPE between B and E." | |
568 (remove-text-properties | |
569 b e (cons 'article-type (cons type gnus-hidden-properties))) | |
570 (when (memq 'intangible gnus-hidden-properties) | |
571 (put-text-property (max (1- b) (point-min)) | |
572 b 'intangible nil))) | |
573 | |
574 (defun gnus-article-hide-text-of-type (type) | |
575 "Hide text of TYPE in the current buffer." | |
576 (save-excursion | |
577 (let ((b (point-min)) | |
578 (e (point-max))) | |
579 (while (setq b (text-property-any b e 'article-type type)) | |
580 (add-text-properties b (incf b) gnus-hidden-properties))))) | |
581 | |
582 (defun gnus-article-delete-text-of-type (type) | |
583 "Delete text of TYPE in the current buffer." | |
584 (save-excursion | |
19969
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
585 (let ((b (point-min))) |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
586 (while (setq b (text-property-any b (point-max) 'article-type type)) |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
587 (delete-region |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
588 b (or (text-property-not-all b (point-max) 'article-type type) |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
589 (point-max))))))) |
17493 | 590 |
591 (defun gnus-article-delete-invisible-text () | |
592 "Delete all invisible text in the current buffer." | |
593 (save-excursion | |
19969
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
594 (let ((b (point-min))) |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
595 (while (setq b (text-property-any b (point-max) 'invisible t)) |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
596 (delete-region |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
597 b (or (text-property-not-all b (point-max) 'invisible t) |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
598 (point-max))))))) |
17493 | 599 |
600 (defun gnus-article-text-type-exists-p (type) | |
601 "Say whether any text of type TYPE exists in the buffer." | |
602 (text-property-any (point-min) (point-max) 'article-type type)) | |
603 | |
604 (defsubst gnus-article-header-rank () | |
605 "Give the rank of the string HEADER as given by `gnus-sorted-header-list'." | |
606 (let ((list gnus-sorted-header-list) | |
607 (i 0)) | |
608 (while list | |
609 (when (looking-at (car list)) | |
610 (setq list nil)) | |
611 (setq list (cdr list)) | |
612 (incf i)) | |
613 i)) | |
614 | |
615 (defun article-hide-headers (&optional arg delete) | |
616 "Toggle whether to hide unwanted headers and possibly sort them as well. | |
617 If given a negative prefix, always show; if given a positive prefix, | |
618 always hide." | |
619 (interactive (gnus-article-hidden-arg)) | |
620 (if (gnus-article-check-hidden-text 'headers arg) | |
621 ;; Show boring headers as well. | |
622 (gnus-article-show-hidden-text 'boring-headers) | |
623 ;; This function might be inhibited. | |
624 (unless gnus-inhibit-hiding | |
625 (save-excursion | |
626 (save-restriction | |
627 (let ((buffer-read-only nil) | |
628 (props (nconc (list 'article-type 'headers) | |
629 gnus-hidden-properties)) | |
630 (max (1+ (length gnus-sorted-header-list))) | |
631 (ignored (when (not gnus-visible-headers) | |
632 (cond ((stringp gnus-ignored-headers) | |
633 gnus-ignored-headers) | |
634 ((listp gnus-ignored-headers) | |
635 (mapconcat 'identity gnus-ignored-headers | |
636 "\\|"))))) | |
637 (visible | |
638 (cond ((stringp gnus-visible-headers) | |
639 gnus-visible-headers) | |
640 ((and gnus-visible-headers | |
641 (listp gnus-visible-headers)) | |
642 (mapconcat 'identity gnus-visible-headers "\\|")))) | |
643 (inhibit-point-motion-hooks t) | |
644 want-list beg) | |
645 ;; First we narrow to just the headers. | |
646 (widen) | |
647 (goto-char (point-min)) | |
648 ;; Hide any "From " lines at the beginning of (mail) articles. | |
649 (while (looking-at "From ") | |
650 (forward-line 1)) | |
651 (unless (bobp) | |
652 (if delete | |
653 (delete-region (point-min) (point)) | |
654 (gnus-article-hide-text (point-min) (point) props))) | |
655 ;; Then treat the rest of the header lines. | |
656 (narrow-to-region | |
657 (point) | |
658 (if (search-forward "\n\n" nil t) ; if there's a body | |
659 (progn (forward-line -1) (point)) | |
660 (point-max))) | |
661 ;; Then we use the two regular expressions | |
662 ;; `gnus-ignored-headers' and `gnus-visible-headers' to | |
663 ;; select which header lines is to remain visible in the | |
664 ;; article buffer. | |
665 (goto-char (point-min)) | |
666 (while (re-search-forward "^[^ \t]*:" nil t) | |
667 (beginning-of-line) | |
668 ;; Mark the rank of the header. | |
669 (put-text-property | |
670 (point) (1+ (point)) 'message-rank | |
671 (if (or (and visible (looking-at visible)) | |
672 (and ignored | |
673 (not (looking-at ignored)))) | |
674 (gnus-article-header-rank) | |
675 (+ 2 max))) | |
676 (forward-line 1)) | |
677 (message-sort-headers-1) | |
678 (when (setq beg (text-property-any | |
679 (point-min) (point-max) 'message-rank (+ 2 max))) | |
680 ;; We make the unwanted headers invisible. | |
681 (if delete | |
682 (delete-region beg (point-max)) | |
683 ;; Suggested by Sudish Joseph <joseph@cis.ohio-state.edu>. | |
684 (gnus-article-hide-text-type beg (point-max) 'headers)) | |
685 ;; Work around XEmacs lossage. | |
686 (put-text-property (point-min) beg 'invisible nil)))))))) | |
687 | |
688 (defun article-hide-boring-headers (&optional arg) | |
689 "Toggle hiding of headers that aren't very interesting. | |
690 If given a negative prefix, always show; if given a positive prefix, | |
691 always hide." | |
692 (interactive (gnus-article-hidden-arg)) | |
693 (when (and (not (gnus-article-check-hidden-text 'boring-headers arg)) | |
694 (not gnus-show-all-headers)) | |
695 (save-excursion | |
696 (save-restriction | |
697 (let ((buffer-read-only nil) | |
698 (list gnus-boring-article-headers) | |
699 (inhibit-point-motion-hooks t) | |
700 elem) | |
701 (nnheader-narrow-to-headers) | |
702 (while list | |
703 (setq elem (pop list)) | |
704 (goto-char (point-min)) | |
705 (cond | |
706 ;; Hide empty headers. | |
707 ((eq elem 'empty) | |
708 (while (re-search-forward "^[^:]+:[ \t]*\n[^ \t]" nil t) | |
709 (forward-line -1) | |
710 (gnus-article-hide-text-type | |
711 (progn (beginning-of-line) (point)) | |
712 (progn | |
713 (end-of-line) | |
714 (if (re-search-forward "^[^ \t]" nil t) | |
715 (match-beginning 0) | |
716 (point-max))) | |
717 'boring-headers))) | |
718 ;; Hide boring Newsgroups header. | |
719 ((eq elem 'newsgroups) | |
720 (when (equal (gnus-fetch-field "newsgroups") | |
721 (gnus-group-real-name | |
722 (if (boundp 'gnus-newsgroup-name) | |
723 gnus-newsgroup-name | |
724 ""))) | |
725 (gnus-article-hide-header "newsgroups"))) | |
726 ((eq elem 'followup-to) | |
727 (when (equal (message-fetch-field "followup-to") | |
728 (message-fetch-field "newsgroups")) | |
729 (gnus-article-hide-header "followup-to"))) | |
730 ((eq elem 'reply-to) | |
731 (let ((from (message-fetch-field "from")) | |
732 (reply-to (message-fetch-field "reply-to"))) | |
733 (when (and | |
734 from reply-to | |
735 (ignore-errors | |
736 (equal | |
737 (nth 1 (mail-extract-address-components from)) | |
738 (nth 1 (mail-extract-address-components reply-to))))) | |
739 (gnus-article-hide-header "reply-to")))) | |
740 ((eq elem 'date) | |
741 (let ((date (message-fetch-field "date"))) | |
742 (when (and date | |
743 (< (gnus-days-between (current-time-string) date) | |
744 4)) | |
745 (gnus-article-hide-header "date"))))))))))) | |
746 | |
747 (defun gnus-article-hide-header (header) | |
748 (save-excursion | |
749 (goto-char (point-min)) | |
750 (when (re-search-forward (concat "^" header ":") nil t) | |
751 (gnus-article-hide-text-type | |
752 (progn (beginning-of-line) (point)) | |
753 (progn | |
754 (end-of-line) | |
755 (if (re-search-forward "^[^ \t]" nil t) | |
756 (match-beginning 0) | |
757 (point-max))) | |
758 'boring-headers)))) | |
759 | |
760 ;; Written by Per Abrahamsen <amanda@iesd.auc.dk>. | |
761 (defun article-treat-overstrike () | |
762 "Translate overstrikes into bold text." | |
763 (interactive) | |
764 (save-excursion | |
765 (goto-char (point-min)) | |
766 (when (search-forward "\n\n" nil t) | |
767 (let ((buffer-read-only nil)) | |
768 (while (search-forward "\b" nil t) | |
769 (let ((next (following-char)) | |
770 (previous (char-after (- (point) 2)))) | |
771 ;; We do the boldification/underlining by hiding the | |
772 ;; overstrikes and putting the proper text property | |
773 ;; on the letters. | |
774 (cond | |
775 ((eq next previous) | |
776 (gnus-article-hide-text-type (- (point) 2) (point) 'overstrike) | |
777 (put-text-property (point) (1+ (point)) 'face 'bold)) | |
778 ((eq next ?_) | |
779 (gnus-article-hide-text-type | |
780 (1- (point)) (1+ (point)) 'overstrike) | |
781 (put-text-property | |
782 (- (point) 2) (1- (point)) 'face 'underline)) | |
783 ((eq previous ?_) | |
784 (gnus-article-hide-text-type (- (point) 2) (point) 'overstrike) | |
785 (put-text-property | |
786 (point) (1+ (point)) 'face 'underline))))))))) | |
787 | |
788 (defun article-fill () | |
789 "Format too long lines." | |
790 (interactive) | |
791 (save-excursion | |
792 (let ((buffer-read-only nil)) | |
793 (widen) | |
794 (goto-char (point-min)) | |
795 (search-forward "\n\n" nil t) | |
796 (end-of-line 1) | |
797 (let ((paragraph-start "^[>|#:<;* ]*[ \t]*$") | |
798 (adaptive-fill-regexp "[ \t]*\\([|#:<;>*]+ *\\)?") | |
799 (adaptive-fill-mode t)) | |
800 (while (not (eobp)) | |
801 (and (>= (current-column) (min fill-column (window-width))) | |
802 (/= (preceding-char) ?:) | |
803 (fill-paragraph nil)) | |
804 (end-of-line 2)))))) | |
805 | |
806 (defun article-remove-cr () | |
807 "Remove carriage returns from an article." | |
808 (interactive) | |
809 (save-excursion | |
810 (let ((buffer-read-only nil)) | |
811 (goto-char (point-min)) | |
812 (while (search-forward "\r" nil t) | |
813 (replace-match "" t t))))) | |
814 | |
815 (defun article-remove-trailing-blank-lines () | |
816 "Remove all trailing blank lines from the article." | |
817 (interactive) | |
818 (save-excursion | |
819 (let ((buffer-read-only nil)) | |
820 (goto-char (point-max)) | |
821 (delete-region | |
822 (point) | |
823 (progn | |
824 (while (and (not (bobp)) | |
825 (looking-at "^[ \t]*$")) | |
826 (forward-line -1)) | |
827 (forward-line 1) | |
828 (point)))))) | |
829 | |
830 (defun article-display-x-face (&optional force) | |
831 "Look for an X-Face header and display it if present." | |
832 (interactive (list 'force)) | |
833 (save-excursion | |
834 ;; Delete the old process, if any. | |
835 (when (process-status "article-x-face") | |
836 (delete-process "article-x-face")) | |
837 (let ((inhibit-point-motion-hooks t) | |
838 (case-fold-search nil) | |
839 from) | |
840 (save-restriction | |
841 (nnheader-narrow-to-headers) | |
842 (setq from (message-fetch-field "from")) | |
843 (goto-char (point-min)) | |
19969
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
844 (while (and gnus-article-x-face-command |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
845 (or force |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
846 ;; Check whether this face is censored. |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
847 (not gnus-article-x-face-too-ugly) |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
848 (and gnus-article-x-face-too-ugly from |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
849 (not (string-match gnus-article-x-face-too-ugly |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
850 from)))) |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
851 ;; Has to be present. |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
852 (re-search-forward "^X-Face: " nil t)) |
17493 | 853 ;; We now have the area of the buffer where the X-Face is stored. |
19969
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
854 (save-excursion |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
855 (let ((beg (point)) |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
856 (end (1- (re-search-forward "^\\($\\|[^ \t]\\)" nil t)))) |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
857 ;; We display the face. |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
858 (if (symbolp gnus-article-x-face-command) |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
859 ;; The command is a lisp function, so we call it. |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
860 (if (gnus-functionp gnus-article-x-face-command) |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
861 (funcall gnus-article-x-face-command beg end) |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
862 (error "%s is not a function" gnus-article-x-face-command)) |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
863 ;; The command is a string, so we interpret the command |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
864 ;; as a, well, command, and fork it off. |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
865 (let ((process-connection-type nil)) |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
866 (process-kill-without-query |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
867 (start-process |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
868 "article-x-face" nil shell-file-name shell-command-switch |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
869 gnus-article-x-face-command)) |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
870 (process-send-region "article-x-face" beg end) |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
871 (process-send-eof "article-x-face")))))))))) |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
872 |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
873 (defun gnus-hack-decode-rfc1522 () |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
874 "Emergency hack function for avoiding problems when decoding." |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
875 (let ((buffer-read-only nil)) |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
876 (goto-char (point-min)) |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
877 ;; Remove encoded TABs. |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
878 (while (search-forward "=09" nil t) |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
879 (replace-match " " t t)) |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
880 ;; Remove encoded newlines. |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
881 (goto-char (point-min)) |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
882 (while (search-forward "=10" nil t) |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
883 (replace-match " " t t)))) |
17493 | 884 |
885 (defalias 'gnus-decode-rfc1522 'article-decode-rfc1522) | |
886 (defalias 'gnus-article-decode-rfc1522 'article-decode-rfc1522) | |
887 (defun article-decode-rfc1522 () | |
888 "Hack to remove QP encoding from headers." | |
889 (let ((case-fold-search t) | |
890 (inhibit-point-motion-hooks t) | |
891 (buffer-read-only nil) | |
892 string) | |
893 (save-restriction | |
894 (narrow-to-region | |
895 (goto-char (point-min)) | |
896 (or (search-forward "\n\n" nil t) (point-max))) | |
897 (goto-char (point-min)) | |
898 (while (re-search-forward | |
899 "=\\?iso-8859-1\\?q\\?\\([^?\t\n]*\\)\\?=" nil t) | |
900 (setq string (match-string 1)) | |
901 (save-restriction | |
902 (narrow-to-region (match-beginning 0) (match-end 0)) | |
903 (delete-region (point-min) (point-max)) | |
904 (insert string) | |
905 (article-mime-decode-quoted-printable | |
906 (goto-char (point-min)) (point-max)) | |
907 (subst-char-in-region (point-min) (point-max) ?_ ? ) | |
908 (goto-char (point-max))) | |
909 (goto-char (point-min)))))) | |
910 | |
911 (defun article-de-quoted-unreadable (&optional force) | |
912 "Do a naive translation of a quoted-printable-encoded article. | |
913 This is in no way, shape or form meant as a replacement for real MIME | |
914 processing, but is simply a stop-gap measure until MIME support is | |
915 written. | |
916 If FORCE, decode the article whether it is marked as quoted-printable | |
917 or not." | |
918 (interactive (list 'force)) | |
919 (save-excursion | |
920 (let ((case-fold-search t) | |
921 (buffer-read-only nil) | |
922 (type (gnus-fetch-field "content-transfer-encoding"))) | |
923 (gnus-article-decode-rfc1522) | |
924 (when (or force | |
925 (and type (string-match "quoted-printable" (downcase type)))) | |
926 (goto-char (point-min)) | |
927 (search-forward "\n\n" nil 'move) | |
928 (article-mime-decode-quoted-printable (point) (point-max)))))) | |
929 | |
930 (defun article-mime-decode-quoted-printable-buffer () | |
931 "Decode Quoted-Printable in the current buffer." | |
932 (article-mime-decode-quoted-printable (point-min) (point-max))) | |
933 | |
934 (defun article-mime-decode-quoted-printable (from to) | |
935 "Decode Quoted-Printable in the region between FROM and TO." | |
936 (interactive "r") | |
937 (goto-char from) | |
938 (while (search-forward "=" to t) | |
939 (cond ((eq (following-char) ?\n) | |
940 (delete-char -1) | |
941 (delete-char 1)) | |
942 ((looking-at "[0-9A-F][0-9A-F]") | |
943 (subst-char-in-region | |
944 (1- (point)) (point) ?= | |
945 (hexl-hex-string-to-integer | |
946 (buffer-substring (point) (+ 2 (point))))) | |
947 (delete-char 2)) | |
948 ((looking-at "=") | |
949 (delete-char 1)) | |
950 ((gnus-message 3 "Malformed MIME quoted-printable message"))))) | |
951 | |
952 (defun article-hide-pgp (&optional arg) | |
953 "Toggle hiding of any PGP headers and signatures in the current article. | |
954 If given a negative prefix, always show; if given a positive prefix, | |
955 always hide." | |
956 (interactive (gnus-article-hidden-arg)) | |
957 (unless (gnus-article-check-hidden-text 'pgp arg) | |
958 (save-excursion | |
959 (let ((inhibit-point-motion-hooks t) | |
960 buffer-read-only beg end) | |
961 (widen) | |
962 (goto-char (point-min)) | |
963 ;; Hide the "header". | |
964 (when (search-forward "\n-----BEGIN PGP SIGNED MESSAGE-----\n" nil t) | |
965 (gnus-article-hide-text-type (1+ (match-beginning 0)) | |
19969
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
966 (match-end 0) 'pgp) |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
967 (setq beg (point)) |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
968 ;; Hide the actual signature. |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
969 (and (search-forward "\n-----BEGIN PGP SIGNATURE-----\n" nil t) |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
970 (setq end (1+ (match-beginning 0))) |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
971 (gnus-article-hide-text-type |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
972 end |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
973 (if (search-forward "\n-----END PGP SIGNATURE-----\n" nil t) |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
974 (match-end 0) |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
975 ;; Perhaps we shouldn't hide to the end of the buffer |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
976 ;; if there is no end to the signature? |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
977 (point-max)) |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
978 'pgp)) |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
979 ;; Hide "- " PGP quotation markers. |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
980 (when (and beg end) |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
981 (narrow-to-region beg end) |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
982 (goto-char (point-min)) |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
983 (while (re-search-forward "^- " nil t) |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
984 (gnus-article-hide-text-type |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
985 (match-beginning 0) (match-end 0) 'pgp)) |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
986 (widen)) |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
987 (run-hooks 'gnus-article-hide-pgp-hook)))))) |
17493 | 988 |
989 (defun article-hide-pem (&optional arg) | |
990 "Toggle hiding of any PEM headers and signatures in the current article. | |
991 If given a negative prefix, always show; if given a positive prefix, | |
992 always hide." | |
993 (interactive (gnus-article-hidden-arg)) | |
994 (unless (gnus-article-check-hidden-text 'pem arg) | |
995 (save-excursion | |
996 (let (buffer-read-only end) | |
997 (widen) | |
998 (goto-char (point-min)) | |
999 ;; hide the horrendously ugly "header". | |
1000 (and (search-forward "\n-----BEGIN PRIVACY-ENHANCED MESSAGE-----\n" | |
1001 nil | |
1002 t) | |
1003 (setq end (1+ (match-beginning 0))) | |
1004 (gnus-article-hide-text-type | |
1005 end | |
1006 (if (search-forward "\n\n" nil t) | |
1007 (match-end 0) | |
1008 (point-max)) | |
1009 'pem)) | |
1010 ;; hide the trailer as well | |
1011 (and (search-forward "\n-----END PRIVACY-ENHANCED MESSAGE-----\n" | |
1012 nil | |
1013 t) | |
1014 (gnus-article-hide-text-type | |
1015 (match-beginning 0) (match-end 0) 'pem)))))) | |
1016 | |
1017 (defun article-hide-signature (&optional arg) | |
1018 "Hide the signature in the current article. | |
1019 If given a negative prefix, always show; if given a positive prefix, | |
1020 always hide." | |
1021 (interactive (gnus-article-hidden-arg)) | |
1022 (unless (gnus-article-check-hidden-text 'signature arg) | |
1023 (save-excursion | |
1024 (save-restriction | |
1025 (let ((buffer-read-only nil)) | |
1026 (when (gnus-article-narrow-to-signature) | |
1027 (gnus-article-hide-text-type | |
1028 (point-min) (point-max) 'signature))))))) | |
1029 | |
1030 (defun article-strip-leading-blank-lines () | |
1031 "Remove all blank lines from the beginning of the article." | |
1032 (interactive) | |
1033 (save-excursion | |
1034 (let ((inhibit-point-motion-hooks t) | |
1035 buffer-read-only) | |
1036 (goto-char (point-min)) | |
1037 (when (search-forward "\n\n" nil t) | |
1038 (while (and (not (eobp)) | |
1039 (looking-at "[ \t]*$")) | |
1040 (gnus-delete-line)))))) | |
1041 | |
1042 (defun article-strip-multiple-blank-lines () | |
1043 "Replace consecutive blank lines with one empty line." | |
1044 (interactive) | |
1045 (save-excursion | |
1046 (let ((inhibit-point-motion-hooks t) | |
1047 buffer-read-only) | |
1048 ;; First make all blank lines empty. | |
1049 (goto-char (point-min)) | |
1050 (search-forward "\n\n" nil t) | |
1051 (while (re-search-forward "^[ \t]+$" nil t) | |
1052 (replace-match "" nil t)) | |
1053 ;; Then replace multiple empty lines with a single empty line. | |
1054 (goto-char (point-min)) | |
1055 (search-forward "\n\n" nil t) | |
1056 (while (re-search-forward "\n\n\n+" nil t) | |
1057 (replace-match "\n\n" t t))))) | |
1058 | |
1059 (defun article-strip-leading-space () | |
1060 "Remove all white space from the beginning of the lines in the article." | |
1061 (interactive) | |
1062 (save-excursion | |
1063 (let ((inhibit-point-motion-hooks t) | |
1064 buffer-read-only) | |
1065 (goto-char (point-min)) | |
1066 (search-forward "\n\n" nil t) | |
1067 (while (re-search-forward "^[ \t]+" nil t) | |
1068 (replace-match "" t t))))) | |
1069 | |
1070 (defun article-strip-blank-lines () | |
1071 "Strip leading, trailing and multiple blank lines." | |
1072 (interactive) | |
1073 (article-strip-leading-blank-lines) | |
1074 (article-remove-trailing-blank-lines) | |
1075 (article-strip-multiple-blank-lines)) | |
1076 | |
1077 (defvar mime::preview/content-list) | |
1078 (defvar mime::preview-content-info/point-min) | |
1079 (defun gnus-article-narrow-to-signature () | |
1080 "Narrow to the signature; return t if a signature is found, else nil." | |
1081 (widen) | |
1082 (when (and (boundp 'mime::preview/content-list) | |
1083 mime::preview/content-list) | |
1084 ;; We have a MIMEish article, so we use the MIME data to narrow. | |
1085 (let ((pcinfo (car (last mime::preview/content-list)))) | |
1086 (ignore-errors | |
1087 (narrow-to-region | |
1088 (funcall (intern "mime::preview-content-info/point-min") pcinfo) | |
1089 (point-max))))) | |
1090 | |
1091 (when (gnus-article-search-signature) | |
1092 (forward-line 1) | |
1093 ;; Check whether we have some limits to what we consider | |
1094 ;; to be a signature. | |
1095 (let ((limits (if (listp gnus-signature-limit) gnus-signature-limit | |
1096 (list gnus-signature-limit))) | |
1097 limit limited) | |
1098 (while (setq limit (pop limits)) | |
1099 (if (or (and (integerp limit) | |
1100 (< (- (point-max) (point)) limit)) | |
1101 (and (floatp limit) | |
1102 (< (count-lines (point) (point-max)) limit)) | |
1103 (and (gnus-functionp limit) | |
1104 (funcall limit)) | |
1105 (and (stringp limit) | |
1106 (not (re-search-forward limit nil t)))) | |
1107 () ; This limit did not succeed. | |
1108 (setq limited t | |
1109 limits nil))) | |
1110 (unless limited | |
1111 (narrow-to-region (point) (point-max)) | |
1112 t)))) | |
1113 | |
1114 (defun gnus-article-search-signature () | |
1115 "Search the current buffer for the signature separator. | |
1116 Put point at the beginning of the signature separator." | |
1117 (let ((cur (point))) | |
1118 (goto-char (point-max)) | |
1119 (if (if (stringp gnus-signature-separator) | |
1120 (re-search-backward gnus-signature-separator nil t) | |
1121 (let ((seps gnus-signature-separator)) | |
1122 (while (and seps | |
1123 (not (re-search-backward (car seps) nil t))) | |
1124 (pop seps)) | |
1125 seps)) | |
1126 t | |
1127 (goto-char cur) | |
1128 nil))) | |
1129 | |
1130 (eval-and-compile | |
19969
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
1131 (autoload 'w3-display "w3-parse") |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
1132 (autoload 'w3-do-setup "w3" "" t)) |
17493 | 1133 |
1134 (defun gnus-article-treat-html () | |
1135 "Render HTML." | |
1136 (interactive) | |
1137 (let ((cbuf (current-buffer))) | |
1138 (set-buffer gnus-article-buffer) | |
1139 (let (buf buffer-read-only b e) | |
19969
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
1140 (w3-do-setup) |
17493 | 1141 (goto-char (point-min)) |
1142 (narrow-to-region | |
1143 (if (search-forward "\n\n" nil t) | |
1144 (setq b (point)) | |
1145 (point-max)) | |
1146 (setq e (point-max))) | |
1147 (nnheader-temp-write nil | |
1148 (insert-buffer-substring gnus-article-buffer b e) | |
19969
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
1149 (require 'url) |
17493 | 1150 (save-window-excursion |
19969
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
1151 (w3-region (point-min) (point-max)) |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
1152 (setq buf (buffer-substring-no-properties (point-min) (point-max))))) |
17493 | 1153 (when buf |
1154 (delete-region (point-min) (point-max)) | |
19969
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
1155 (insert buf)) |
17493 | 1156 (widen) |
1157 (goto-char (point-min)) | |
1158 (set-window-start (get-buffer-window (current-buffer)) (point-min)) | |
1159 (set-buffer cbuf)))) | |
1160 | |
1161 (defun gnus-article-hidden-arg () | |
1162 "Return the current prefix arg as a number, or 0 if no prefix." | |
1163 (list (if current-prefix-arg | |
1164 (prefix-numeric-value current-prefix-arg) | |
1165 0))) | |
1166 | |
1167 (defun gnus-article-check-hidden-text (type arg) | |
1168 "Return nil if hiding is necessary. | |
1169 Arg can be nil or a number. Nil and positive means hide, negative | |
1170 means show, 0 means toggle." | |
1171 (save-excursion | |
1172 (save-restriction | |
1173 (widen) | |
1174 (let ((hide (gnus-article-hidden-text-p type))) | |
1175 (cond | |
1176 ((or (null arg) | |
1177 (> arg 0)) | |
1178 nil) | |
1179 ((< arg 0) | |
1180 (gnus-article-show-hidden-text type)) | |
1181 (t | |
1182 (if (eq hide 'hidden) | |
1183 (gnus-article-show-hidden-text type) | |
1184 nil))))))) | |
1185 | |
1186 (defun gnus-article-hidden-text-p (type) | |
1187 "Say whether the current buffer contains hidden text of type TYPE." | |
1188 (let ((start (point-min)) | |
1189 (pos (text-property-any (point-min) (point-max) 'article-type type))) | |
1190 (while (and pos | |
1191 (not (get-text-property pos 'invisible))) | |
1192 (setq pos | |
1193 (text-property-any (1+ pos) (point-max) 'article-type type))) | |
1194 (if pos | |
1195 'hidden | |
1196 'shown))) | |
1197 | |
1198 (defun gnus-article-show-hidden-text (type &optional hide) | |
1199 "Show all hidden text of type TYPE. | |
1200 If HIDE, hide the text instead." | |
1201 (save-excursion | |
1202 (let ((buffer-read-only nil) | |
1203 (inhibit-point-motion-hooks t) | |
1204 (end (point-min)) | |
1205 beg) | |
1206 (while (setq beg (text-property-any end (point-max) 'article-type type)) | |
1207 (goto-char beg) | |
1208 (setq end (or | |
1209 (text-property-not-all beg (point-max) 'article-type type) | |
1210 (point-max))) | |
1211 (if hide | |
1212 (gnus-article-hide-text beg end gnus-hidden-properties) | |
1213 (gnus-article-unhide-text beg end)) | |
1214 (goto-char end)) | |
1215 t))) | |
1216 | |
1217 (defconst article-time-units | |
1218 `((year . ,(* 365.25 24 60 60)) | |
1219 (week . ,(* 7 24 60 60)) | |
1220 (day . ,(* 24 60 60)) | |
1221 (hour . ,(* 60 60)) | |
1222 (minute . 60) | |
1223 (second . 1)) | |
1224 "Mapping from time units to seconds.") | |
1225 | |
1226 (defun article-date-ut (&optional type highlight header) | |
1227 "Convert DATE date to universal time in the current article. | |
1228 If TYPE is `local', convert to local time; if it is `lapsed', output | |
1229 how much time has lapsed since DATE." | |
1230 (interactive (list 'ut t)) | |
1231 (let* ((header (or header | |
1232 (mail-header-date gnus-current-headers) | |
1233 (message-fetch-field "date") | |
1234 "")) | |
1235 (date (if (vectorp header) (mail-header-date header) | |
1236 header)) | |
1237 (date-regexp "^Date:[ \t]\\|^X-Sent:[ \t]") | |
1238 (inhibit-point-motion-hooks t) | |
1239 bface eface) | |
1240 (when (and date (not (string= date ""))) | |
1241 (save-excursion | |
1242 (save-restriction | |
1243 (nnheader-narrow-to-headers) | |
1244 (let ((buffer-read-only nil)) | |
1245 ;; Delete any old Date headers. | |
1246 (if (re-search-forward date-regexp nil t) | |
1247 (progn | |
1248 (setq bface (get-text-property (gnus-point-at-bol) 'face) | |
1249 eface (get-text-property (1- (gnus-point-at-eol)) | |
1250 'face)) | |
1251 (message-remove-header date-regexp t) | |
1252 (beginning-of-line)) | |
1253 (goto-char (point-max))) | |
1254 (insert (article-make-date-line date type)) | |
1255 ;; Do highlighting. | |
1256 (forward-line -1) | |
1257 (when (looking-at "\\([^:]+\\): *\\(.*\\)$") | |
1258 (put-text-property (match-beginning 1) (match-end 1) | |
1259 'face bface) | |
1260 (put-text-property (match-beginning 2) (match-end 2) | |
1261 'face eface)))))))) | |
1262 | |
1263 (defun article-make-date-line (date type) | |
1264 "Return a DATE line of TYPE." | |
1265 (cond | |
1266 ;; Convert to the local timezone. We have to slap a | |
1267 ;; `condition-case' round the calls to the timezone | |
1268 ;; functions since they aren't particularly resistant to | |
1269 ;; buggy dates. | |
1270 ((eq type 'local) | |
1271 (concat "Date: " (condition-case () | |
1272 (timezone-make-date-arpa-standard date) | |
1273 (error date)) | |
1274 "\n")) | |
1275 ;; Convert to Universal Time. | |
1276 ((eq type 'ut) | |
1277 (concat "Date: " | |
1278 (condition-case () | |
1279 (timezone-make-date-arpa-standard date nil "UT") | |
1280 (error date)) | |
1281 "\n")) | |
1282 ;; Get the original date from the article. | |
1283 ((eq type 'original) | |
1284 (concat "Date: " date "\n")) | |
1285 ;; Let the user define the format. | |
1286 ((eq type 'user) | |
1287 (concat | |
1288 "Date: " | |
1289 (format-time-string gnus-article-time-format | |
1290 (ignore-errors | |
1291 (gnus-encode-date | |
1292 (timezone-make-date-arpa-standard | |
1293 date nil "UT")))) | |
1294 "\n")) | |
1295 ;; Do an X-Sent lapsed format. | |
1296 ((eq type 'lapsed) | |
1297 ;; If the date is seriously mangled, the timezone functions are | |
1298 ;; liable to bug out, so we ignore all errors. | |
1299 (let* ((now (current-time)) | |
1300 (real-time | |
1301 (ignore-errors | |
1302 (gnus-time-minus | |
1303 (gnus-encode-date | |
1304 (timezone-make-date-arpa-standard | |
1305 (current-time-string now) | |
1306 (current-time-zone now) "UT")) | |
1307 (gnus-encode-date | |
1308 (timezone-make-date-arpa-standard | |
1309 date nil "UT"))))) | |
1310 (real-sec (and real-time | |
1311 (+ (* (float (car real-time)) 65536) | |
1312 (cadr real-time)))) | |
1313 (sec (and real-time (abs real-sec))) | |
1314 num prev) | |
1315 (cond | |
1316 ((null real-time) | |
1317 "X-Sent: Unknown\n") | |
1318 ((zerop sec) | |
1319 "X-Sent: Now\n") | |
1320 (t | |
1321 (concat | |
1322 "X-Sent: " | |
1323 ;; This is a bit convoluted, but basically we go | |
1324 ;; through the time units for years, weeks, etc, | |
1325 ;; and divide things to see whether that results | |
1326 ;; in positive answers. | |
1327 (mapconcat | |
1328 (lambda (unit) | |
1329 (if (zerop (setq num (ffloor (/ sec (cdr unit))))) | |
1330 ;; The (remaining) seconds are too few to | |
1331 ;; be divided into this time unit. | |
1332 "" | |
1333 ;; It's big enough, so we output it. | |
1334 (setq sec (- sec (* num (cdr unit)))) | |
1335 (prog1 | |
1336 (concat (if prev ", " "") (int-to-string | |
1337 (floor num)) | |
1338 " " (symbol-name (car unit)) | |
1339 (if (> num 1) "s" "")) | |
1340 (setq prev t)))) | |
1341 article-time-units "") | |
1342 ;; If dates are odd, then it might appear like the | |
1343 ;; article was sent in the future. | |
1344 (if (> real-sec 0) | |
1345 " ago\n" | |
1346 " in the future\n")))))) | |
1347 (t | |
1348 (error "Unknown conversion type: %s" type)))) | |
1349 | |
1350 (defun article-date-local (&optional highlight) | |
1351 "Convert the current article date to the local timezone." | |
1352 (interactive (list t)) | |
1353 (article-date-ut 'local highlight)) | |
1354 | |
1355 (defun article-date-original (&optional highlight) | |
1356 "Convert the current article date to what it was originally. | |
1357 This is only useful if you have used some other date conversion | |
1358 function and want to see what the date was before converting." | |
1359 (interactive (list t)) | |
1360 (article-date-ut 'original highlight)) | |
1361 | |
1362 (defun article-date-lapsed (&optional highlight) | |
1363 "Convert the current article date to time lapsed since it was sent." | |
1364 (interactive (list t)) | |
1365 (article-date-ut 'lapsed highlight)) | |
1366 | |
1367 (defun article-date-user (&optional highlight) | |
1368 "Convert the current article date to the user-defined format. | |
1369 This format is defined by the `gnus-article-time-format' variable." | |
1370 (interactive (list t)) | |
1371 (article-date-ut 'user highlight)) | |
1372 | |
1373 (defun article-show-all () | |
1374 "Show all hidden text in the article buffer." | |
1375 (interactive) | |
1376 (save-excursion | |
1377 (let ((buffer-read-only nil)) | |
1378 (gnus-article-unhide-text (point-min) (point-max))))) | |
1379 | |
1380 (defun article-emphasize (&optional arg) | |
1381 "Emphasize text according to `gnus-emphasis-alist'." | |
1382 (interactive (gnus-article-hidden-arg)) | |
1383 (unless (gnus-article-check-hidden-text 'emphasis arg) | |
1384 (save-excursion | |
1385 (let ((alist gnus-emphasis-alist) | |
1386 (buffer-read-only nil) | |
1387 (props (append '(article-type emphasis) | |
1388 gnus-hidden-properties)) | |
1389 regexp elem beg invisible visible face) | |
1390 (goto-char (point-min)) | |
1391 (search-forward "\n\n" nil t) | |
1392 (setq beg (point)) | |
1393 (while (setq elem (pop alist)) | |
1394 (goto-char beg) | |
1395 (setq regexp (car elem) | |
1396 invisible (nth 1 elem) | |
1397 visible (nth 2 elem) | |
1398 face (nth 3 elem)) | |
1399 (while (re-search-forward regexp nil t) | |
1400 (when (and (match-beginning visible) (match-beginning invisible)) | |
1401 (gnus-article-hide-text | |
1402 (match-beginning invisible) (match-end invisible) props) | |
1403 (gnus-article-unhide-text-type | |
1404 (match-beginning visible) (match-end visible) 'emphasis) | |
1405 (gnus-put-text-property-excluding-newlines | |
1406 (match-beginning visible) (match-end visible) 'face face) | |
1407 (goto-char (match-end invisible))))))))) | |
1408 | |
1409 (defvar gnus-summary-article-menu) | |
1410 (defvar gnus-summary-post-menu) | |
1411 | |
1412 ;;; Saving functions. | |
1413 | |
1414 (defun gnus-article-save (save-buffer file &optional num) | |
1415 "Save the currently selected article." | |
1416 (unless gnus-save-all-headers | |
1417 ;; Remove headers according to `gnus-saved-headers'. | |
1418 (let ((gnus-visible-headers | |
1419 (or gnus-saved-headers gnus-visible-headers)) | |
1420 (gnus-article-buffer save-buffer)) | |
1421 (gnus-article-hide-headers 1 t))) | |
1422 (save-window-excursion | |
1423 (if (not gnus-default-article-saver) | |
19969
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
1424 (error "No default saver is defined") |
17493 | 1425 ;; !!! Magic! The saving functions all save |
1426 ;; `gnus-original-article-buffer' (or so they think), but we | |
1427 ;; bind that variable to our save-buffer. | |
1428 (set-buffer gnus-article-buffer) | |
1429 (let* ((gnus-save-article-buffer save-buffer) | |
1430 (filename | |
1431 (cond | |
1432 ((not gnus-prompt-before-saving) 'default) | |
1433 ((eq gnus-prompt-before-saving 'always) nil) | |
1434 (t file))) | |
1435 (gnus-number-of-articles-to-be-saved | |
1436 (when (eq gnus-prompt-before-saving t) | |
1437 num))) ; Magic | |
1438 (set-buffer gnus-summary-buffer) | |
1439 (funcall gnus-default-article-saver filename))))) | |
1440 | |
1441 (defun gnus-read-save-file-name (prompt &optional filename | |
1442 function group headers variable) | |
1443 (let ((default-name | |
1444 (funcall function group headers (symbol-value variable))) | |
1445 result) | |
1446 (setq | |
1447 result | |
1448 (cond | |
1449 ((eq filename 'default) | |
1450 default-name) | |
1451 ((eq filename t) | |
1452 default-name) | |
1453 (filename filename) | |
1454 (t | |
1455 (let* ((split-name (gnus-get-split-value gnus-split-methods)) | |
1456 (prompt | |
1457 (format prompt | |
1458 (if (and gnus-number-of-articles-to-be-saved | |
1459 (> gnus-number-of-articles-to-be-saved 1)) | |
1460 (format "these %d articles" | |
1461 gnus-number-of-articles-to-be-saved) | |
1462 "this article"))) | |
1463 (file | |
1464 ;; Let the split methods have their say. | |
1465 (cond | |
1466 ;; No split name was found. | |
1467 ((null split-name) | |
1468 (read-file-name | |
1469 (concat prompt " (default " | |
1470 (file-name-nondirectory default-name) ") ") | |
1471 (file-name-directory default-name) | |
1472 default-name)) | |
1473 ;; A single group name is returned. | |
1474 ((stringp split-name) | |
1475 (setq default-name | |
1476 (funcall function split-name headers | |
1477 (symbol-value variable))) | |
1478 (read-file-name | |
1479 (concat prompt " (default " | |
1480 (file-name-nondirectory default-name) ") ") | |
1481 (file-name-directory default-name) | |
1482 default-name)) | |
1483 ;; A single split name was found | |
1484 ((= 1 (length split-name)) | |
19969
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
1485 (let* ((name (expand-file-name |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
1486 (car split-name) gnus-article-save-directory)) |
17493 | 1487 (dir (cond ((file-directory-p name) |
1488 (file-name-as-directory name)) | |
1489 ((file-exists-p name) name) | |
1490 (t gnus-article-save-directory)))) | |
1491 (read-file-name | |
1492 (concat prompt " (default " name ") ") | |
1493 dir name))) | |
1494 ;; A list of splits was found. | |
1495 (t | |
1496 (setq split-name (nreverse split-name)) | |
1497 (let (result) | |
1498 (let ((file-name-history | |
1499 (nconc split-name file-name-history))) | |
1500 (setq result | |
1501 (expand-file-name | |
1502 (read-file-name | |
1503 (concat prompt " (`M-p' for defaults) ") | |
1504 gnus-article-save-directory | |
1505 (car split-name)) | |
1506 gnus-article-save-directory))) | |
1507 (car (push result file-name-history))))))) | |
1508 ;; Create the directory. | |
1509 (gnus-make-directory (file-name-directory file)) | |
1510 ;; If we have read a directory, we append the default file name. | |
1511 (when (file-directory-p file) | |
1512 (setq file (concat (file-name-as-directory file) | |
1513 (file-name-nondirectory default-name)))) | |
1514 ;; Possibly translate some characters. | |
1515 (nnheader-translate-file-chars file))))) | |
1516 (gnus-make-directory (file-name-directory result)) | |
1517 (set variable result))) | |
1518 | |
1519 (defun gnus-article-archive-name (group) | |
1520 "Return the first instance of an \"Archive-name\" in the current buffer." | |
1521 (let ((case-fold-search t)) | |
1522 (when (re-search-forward "archive-name: *\\([^ \n\t]+\\)[ \t]*$" nil t) | |
1523 (nnheader-concat gnus-article-save-directory | |
1524 (match-string 1))))) | |
1525 | |
1526 (defun gnus-article-nndoc-name (group) | |
1527 "If GROUP is an nndoc group, return the name of the parent group." | |
1528 (when (eq (car (gnus-find-method-for-group group)) 'nndoc) | |
1529 (gnus-group-get-parameter group 'save-article-group))) | |
1530 | |
1531 (defun gnus-summary-save-in-rmail (&optional filename) | |
1532 "Append this article to Rmail file. | |
1533 Optional argument FILENAME specifies file name. | |
1534 Directory to save to is default to `gnus-article-save-directory'." | |
1535 (interactive) | |
1536 (gnus-set-global-variables) | |
1537 (setq filename (gnus-read-save-file-name | |
1538 "Save %s in rmail file:" filename | |
1539 gnus-rmail-save-name gnus-newsgroup-name | |
1540 gnus-current-headers 'gnus-newsgroup-last-rmail)) | |
1541 (gnus-eval-in-buffer-window gnus-save-article-buffer | |
1542 (save-excursion | |
1543 (save-restriction | |
1544 (widen) | |
1545 (gnus-output-to-rmail filename))))) | |
1546 | |
1547 (defun gnus-summary-save-in-mail (&optional filename) | |
1548 "Append this article to Unix mail file. | |
1549 Optional argument FILENAME specifies file name. | |
1550 Directory to save to is default to `gnus-article-save-directory'." | |
1551 (interactive) | |
1552 (gnus-set-global-variables) | |
1553 (setq filename (gnus-read-save-file-name | |
1554 "Save %s in Unix mail file:" filename | |
1555 gnus-mail-save-name gnus-newsgroup-name | |
1556 gnus-current-headers 'gnus-newsgroup-last-mail)) | |
1557 (gnus-eval-in-buffer-window gnus-save-article-buffer | |
1558 (save-excursion | |
1559 (save-restriction | |
1560 (widen) | |
1561 (if (and (file-readable-p filename) | |
1562 (mail-file-babyl-p filename)) | |
1563 (gnus-output-to-rmail filename t) | |
1564 (gnus-output-to-mail filename)))))) | |
1565 | |
1566 (defun gnus-summary-save-in-file (&optional filename overwrite) | |
1567 "Append this article to file. | |
1568 Optional argument FILENAME specifies file name. | |
1569 Directory to save to is default to `gnus-article-save-directory'." | |
1570 (interactive) | |
1571 (gnus-set-global-variables) | |
1572 (setq filename (gnus-read-save-file-name | |
1573 "Save %s in file:" filename | |
1574 gnus-file-save-name gnus-newsgroup-name | |
1575 gnus-current-headers 'gnus-newsgroup-last-file)) | |
1576 (gnus-eval-in-buffer-window gnus-save-article-buffer | |
1577 (save-excursion | |
1578 (save-restriction | |
1579 (widen) | |
1580 (when (and overwrite | |
1581 (file-exists-p filename)) | |
1582 (delete-file filename)) | |
1583 (gnus-output-to-file filename))))) | |
1584 | |
1585 (defun gnus-summary-write-to-file (&optional filename) | |
1586 "Write this article to a file. | |
1587 Optional argument FILENAME specifies file name. | |
1588 The directory to save in defaults to `gnus-article-save-directory'." | |
1589 (interactive) | |
1590 (gnus-summary-save-in-file nil t)) | |
1591 | |
1592 (defun gnus-summary-save-body-in-file (&optional filename) | |
1593 "Append this article body to a file. | |
1594 Optional argument FILENAME specifies file name. | |
1595 The directory to save in defaults to `gnus-article-save-directory'." | |
1596 (interactive) | |
1597 (gnus-set-global-variables) | |
1598 (setq filename (gnus-read-save-file-name | |
1599 "Save %s body in file:" filename | |
1600 gnus-file-save-name gnus-newsgroup-name | |
1601 gnus-current-headers 'gnus-newsgroup-last-file)) | |
1602 (gnus-eval-in-buffer-window gnus-save-article-buffer | |
1603 (save-excursion | |
1604 (save-restriction | |
1605 (widen) | |
1606 (goto-char (point-min)) | |
1607 (when (search-forward "\n\n" nil t) | |
1608 (narrow-to-region (point) (point-max))) | |
1609 (gnus-output-to-file filename))))) | |
1610 | |
1611 (defun gnus-summary-save-in-pipe (&optional command) | |
1612 "Pipe this article to subprocess." | |
1613 (interactive) | |
1614 (gnus-set-global-variables) | |
1615 (setq command | |
1616 (cond ((eq command 'default) | |
1617 gnus-last-shell-command) | |
1618 (command command) | |
1619 (t (read-string | |
1620 (format | |
1621 "Shell command on %s: " | |
1622 (if (and gnus-number-of-articles-to-be-saved | |
1623 (> gnus-number-of-articles-to-be-saved 1)) | |
1624 (format "these %d articles" | |
1625 gnus-number-of-articles-to-be-saved) | |
1626 "this article")) | |
1627 gnus-last-shell-command)))) | |
1628 (when (string-equal command "") | |
1629 (setq command gnus-last-shell-command)) | |
1630 (gnus-eval-in-buffer-window gnus-article-buffer | |
1631 (save-restriction | |
1632 (widen) | |
1633 (shell-command-on-region (point-min) (point-max) command nil))) | |
1634 (setq gnus-last-shell-command command)) | |
1635 | |
1636 ;;; Article file names when saving. | |
1637 | |
1638 (defun gnus-capitalize-newsgroup (newsgroup) | |
1639 "Capitalize NEWSGROUP name." | |
1640 (when (not (zerop (length newsgroup))) | |
1641 (concat (char-to-string (upcase (aref newsgroup 0))) | |
1642 (substring newsgroup 1)))) | |
1643 | |
1644 (defun gnus-Numeric-save-name (newsgroup headers &optional last-file) | |
1645 "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE. | |
1646 If variable `gnus-use-long-file-name' is non-nil, it is ~/News/News.group/num. | |
1647 Otherwise, it is like ~/News/news/group/num." | |
1648 (let ((default | |
1649 (expand-file-name | |
1650 (concat (if (gnus-use-long-file-name 'not-save) | |
1651 (gnus-capitalize-newsgroup newsgroup) | |
1652 (gnus-newsgroup-directory-form newsgroup)) | |
1653 "/" (int-to-string (mail-header-number headers))) | |
1654 gnus-article-save-directory))) | |
1655 (if (and last-file | |
1656 (string-equal (file-name-directory default) | |
1657 (file-name-directory last-file)) | |
1658 (string-match "^[0-9]+$" (file-name-nondirectory last-file))) | |
1659 default | |
1660 (or last-file default)))) | |
1661 | |
1662 (defun gnus-numeric-save-name (newsgroup headers &optional last-file) | |
1663 "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE. | |
1664 If variable `gnus-use-long-file-name' is non-nil, it is | |
1665 ~/News/news.group/num. Otherwise, it is like ~/News/news/group/num." | |
1666 (let ((default | |
1667 (expand-file-name | |
1668 (concat (if (gnus-use-long-file-name 'not-save) | |
1669 newsgroup | |
1670 (gnus-newsgroup-directory-form newsgroup)) | |
1671 "/" (int-to-string (mail-header-number headers))) | |
1672 gnus-article-save-directory))) | |
1673 (if (and last-file | |
1674 (string-equal (file-name-directory default) | |
1675 (file-name-directory last-file)) | |
1676 (string-match "^[0-9]+$" (file-name-nondirectory last-file))) | |
1677 default | |
1678 (or last-file default)))) | |
1679 | |
1680 (defun gnus-Plain-save-name (newsgroup headers &optional last-file) | |
1681 "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE. | |
1682 If variable `gnus-use-long-file-name' is non-nil, it is | |
1683 ~/News/News.group. Otherwise, it is like ~/News/news/group/news." | |
1684 (or last-file | |
1685 (expand-file-name | |
1686 (if (gnus-use-long-file-name 'not-save) | |
1687 (gnus-capitalize-newsgroup newsgroup) | |
1688 (concat (gnus-newsgroup-directory-form newsgroup) "/news")) | |
1689 gnus-article-save-directory))) | |
1690 | |
1691 (defun gnus-plain-save-name (newsgroup headers &optional last-file) | |
1692 "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE. | |
1693 If variable `gnus-use-long-file-name' is non-nil, it is | |
1694 ~/News/news.group. Otherwise, it is like ~/News/news/group/news." | |
1695 (or last-file | |
1696 (expand-file-name | |
1697 (if (gnus-use-long-file-name 'not-save) | |
1698 newsgroup | |
1699 (concat (gnus-newsgroup-directory-form newsgroup) "/news")) | |
1700 gnus-article-save-directory))) | |
1701 | |
1702 (eval-and-compile | |
1703 (mapcar | |
1704 (lambda (func) | |
1705 (let (afunc gfunc) | |
1706 (if (consp func) | |
1707 (setq afunc (car func) | |
1708 gfunc (cdr func)) | |
1709 (setq afunc func | |
1710 gfunc (intern (format "gnus-%s" func)))) | |
1711 (fset gfunc | |
1712 (if (not (fboundp afunc)) | |
1713 nil | |
1714 `(lambda (&optional interactive &rest args) | |
1715 ,(documentation afunc t) | |
1716 (interactive (list t)) | |
1717 (save-excursion | |
1718 (set-buffer gnus-article-buffer) | |
1719 (if interactive | |
1720 (call-interactively ',afunc) | |
1721 (apply ',afunc args)))))))) | |
1722 '(article-hide-headers | |
1723 article-hide-boring-headers | |
1724 article-treat-overstrike | |
1725 (article-fill . gnus-article-word-wrap) | |
1726 article-remove-cr | |
1727 article-display-x-face | |
1728 article-de-quoted-unreadable | |
1729 article-mime-decode-quoted-printable | |
1730 article-hide-pgp | |
1731 article-hide-pem | |
1732 article-hide-signature | |
1733 article-remove-trailing-blank-lines | |
1734 article-strip-leading-blank-lines | |
1735 article-strip-multiple-blank-lines | |
1736 article-strip-leading-space | |
1737 article-strip-blank-lines | |
1738 article-date-local | |
1739 article-date-original | |
1740 article-date-ut | |
1741 article-date-user | |
1742 article-date-lapsed | |
1743 article-emphasize | |
1744 (article-show-all . gnus-article-show-all-headers)))) | |
1745 | |
1746 ;;; | |
1747 ;;; Gnus article mode | |
1748 ;;; | |
1749 | |
1750 (put 'gnus-article-mode 'mode-class 'special) | |
1751 | |
19969
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
1752 (gnus-define-keys gnus-article-mode-map |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
1753 " " gnus-article-goto-next-page |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
1754 "\177" gnus-article-goto-prev-page |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
1755 [delete] gnus-article-goto-prev-page |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
1756 "\C-c^" gnus-article-refer-article |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
1757 "h" gnus-article-show-summary |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
1758 "s" gnus-article-show-summary |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
1759 "\C-c\C-m" gnus-article-mail |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
1760 "?" gnus-article-describe-briefly |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
1761 gnus-mouse-2 gnus-article-push-button |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
1762 "\r" gnus-article-press-button |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
1763 "\t" gnus-article-next-button |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
1764 "\M-\t" gnus-article-prev-button |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
1765 "e" gnus-article-edit |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
1766 "<" beginning-of-buffer |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
1767 ">" end-of-buffer |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
1768 "\C-c\C-i" gnus-info-find-node |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
1769 "\C-c\C-b" gnus-bug |
17493 | 1770 |
19969
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
1771 "\C-d" gnus-article-read-summary-keys |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
1772 "\M-*" gnus-article-read-summary-keys |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
1773 "\M-#" gnus-article-read-summary-keys |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
1774 "\M-^" gnus-article-read-summary-keys |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
1775 "\M-g" gnus-article-read-summary-keys) |
17493 | 1776 |
19969
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
1777 (substitute-key-definition |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
1778 'undefined 'gnus-article-read-summary-keys gnus-article-mode-map) |
17493 | 1779 |
1780 (defun gnus-article-make-menu-bar () | |
1781 (gnus-turn-off-edit-menu 'article) | |
1782 (unless (boundp 'gnus-article-article-menu) | |
1783 (easy-menu-define | |
1784 gnus-article-article-menu gnus-article-mode-map "" | |
1785 '("Article" | |
1786 ["Scroll forwards" gnus-article-goto-next-page t] | |
1787 ["Scroll backwards" gnus-article-goto-prev-page t] | |
1788 ["Show summary" gnus-article-show-summary t] | |
1789 ["Fetch Message-ID at point" gnus-article-refer-article t] | |
1790 ["Mail to address at point" gnus-article-mail t])) | |
1791 | |
1792 (easy-menu-define | |
1793 gnus-article-treatment-menu gnus-article-mode-map "" | |
1794 '("Treatment" | |
1795 ["Hide headers" gnus-article-hide-headers t] | |
1796 ["Hide signature" gnus-article-hide-signature t] | |
1797 ["Hide citation" gnus-article-hide-citation t] | |
1798 ["Treat overstrike" gnus-article-treat-overstrike t] | |
1799 ["Remove carriage return" gnus-article-remove-cr t] | |
1800 ["Remove quoted-unreadable" gnus-article-de-quoted-unreadable t])) | |
1801 | |
1802 (when nil | |
1803 (when (boundp 'gnus-summary-article-menu) | |
1804 (define-key gnus-article-mode-map [menu-bar commands] | |
1805 (cons "Commands" gnus-summary-article-menu)))) | |
1806 | |
1807 (when (boundp 'gnus-summary-post-menu) | |
1808 (define-key gnus-article-mode-map [menu-bar post] | |
1809 (cons "Post" gnus-summary-post-menu))) | |
1810 | |
1811 (run-hooks 'gnus-article-menu-hook))) | |
1812 | |
1813 (defun gnus-article-mode () | |
1814 "Major mode for displaying an article. | |
1815 | |
1816 All normal editing commands are switched off. | |
1817 | |
1818 The following commands are available in addition to all summary mode | |
1819 commands: | |
1820 \\<gnus-article-mode-map> | |
1821 \\[gnus-article-next-page]\t Scroll the article one page forwards | |
1822 \\[gnus-article-prev-page]\t Scroll the article one page backwards | |
1823 \\[gnus-article-refer-article]\t Go to the article referred to by an article id near point | |
1824 \\[gnus-article-show-summary]\t Display the summary buffer | |
1825 \\[gnus-article-mail]\t Send a reply to the address near point | |
1826 \\[gnus-article-describe-briefly]\t Describe the current mode briefly | |
1827 \\[gnus-info-find-node]\t Go to the Gnus info node" | |
1828 (interactive) | |
1829 (when (gnus-visual-p 'article-menu 'menu) | |
1830 (gnus-article-make-menu-bar)) | |
1831 (kill-all-local-variables) | |
1832 (gnus-simplify-mode-line) | |
1833 (setq mode-name "Article") | |
1834 (setq major-mode 'gnus-article-mode) | |
1835 (make-local-variable 'minor-mode-alist) | |
1836 (unless (assq 'gnus-show-mime minor-mode-alist) | |
1837 (push (list 'gnus-show-mime " MIME") minor-mode-alist)) | |
1838 (use-local-map gnus-article-mode-map) | |
1839 (gnus-update-format-specifications nil 'article-mode) | |
1840 (set (make-local-variable 'page-delimiter) gnus-page-delimiter) | |
1841 (set (make-local-variable 'gnus-page-broken) nil) | |
1842 (set (make-local-variable 'gnus-button-marker-list) nil) | |
1843 (gnus-set-default-directory) | |
1844 (buffer-disable-undo (current-buffer)) | |
1845 (setq buffer-read-only t) | |
1846 (set-syntax-table gnus-article-mode-syntax-table) | |
1847 (run-hooks 'gnus-article-mode-hook)) | |
1848 | |
1849 (defun gnus-article-setup-buffer () | |
1850 "Initialize the article buffer." | |
1851 (let* ((name (if gnus-single-article-buffer "*Article*" | |
1852 (concat "*Article " gnus-newsgroup-name "*"))) | |
1853 (original | |
1854 (progn (string-match "\\*Article" name) | |
1855 (concat " *Original Article" | |
1856 (substring name (match-end 0)))))) | |
1857 (setq gnus-article-buffer name) | |
1858 (setq gnus-original-article-buffer original) | |
1859 ;; This might be a variable local to the summary buffer. | |
1860 (unless gnus-single-article-buffer | |
1861 (save-excursion | |
1862 (set-buffer gnus-summary-buffer) | |
1863 (setq gnus-article-buffer name) | |
1864 (setq gnus-original-article-buffer original) | |
1865 (gnus-set-global-variables))) | |
1866 ;; Init original article buffer. | |
1867 (save-excursion | |
1868 (set-buffer (get-buffer-create gnus-original-article-buffer)) | |
1869 (buffer-disable-undo (current-buffer)) | |
1870 (setq major-mode 'gnus-original-article-mode) | |
1871 (gnus-add-current-to-buffer-list) | |
1872 (make-local-variable 'gnus-original-article)) | |
1873 (if (get-buffer name) | |
1874 (save-excursion | |
1875 (set-buffer name) | |
1876 (buffer-disable-undo (current-buffer)) | |
1877 (setq buffer-read-only t) | |
1878 (gnus-add-current-to-buffer-list) | |
1879 (unless (eq major-mode 'gnus-article-mode) | |
1880 (gnus-article-mode)) | |
1881 (current-buffer)) | |
1882 (save-excursion | |
1883 (set-buffer (get-buffer-create name)) | |
1884 (gnus-add-current-to-buffer-list) | |
1885 (gnus-article-mode) | |
1886 (make-local-variable 'gnus-summary-buffer) | |
1887 (current-buffer))))) | |
1888 | |
1889 ;; Set article window start at LINE, where LINE is the number of lines | |
1890 ;; from the head of the article. | |
1891 (defun gnus-article-set-window-start (&optional line) | |
1892 (set-window-start | |
1893 (get-buffer-window gnus-article-buffer t) | |
1894 (save-excursion | |
1895 (set-buffer gnus-article-buffer) | |
1896 (goto-char (point-min)) | |
1897 (if (not line) | |
1898 (point-min) | |
1899 (gnus-message 6 "Moved to bookmark") | |
1900 (search-forward "\n\n" nil t) | |
1901 (forward-line line) | |
1902 (point))))) | |
1903 | |
1904 (defun gnus-article-prepare (article &optional all-headers header) | |
1905 "Prepare ARTICLE in article mode buffer. | |
1906 ARTICLE should either be an article number or a Message-ID. | |
1907 If ARTICLE is an id, HEADER should be the article headers. | |
1908 If ALL-HEADERS is non-nil, no headers are hidden." | |
1909 (save-excursion | |
1910 ;; Make sure we start in a summary buffer. | |
1911 (unless (eq major-mode 'gnus-summary-mode) | |
1912 (set-buffer gnus-summary-buffer)) | |
1913 (setq gnus-summary-buffer (current-buffer)) | |
1914 ;; Make sure the connection to the server is alive. | |
1915 (unless (gnus-server-opened | |
1916 (gnus-find-method-for-group gnus-newsgroup-name)) | |
1917 (gnus-check-server (gnus-find-method-for-group gnus-newsgroup-name)) | |
1918 (gnus-request-group gnus-newsgroup-name t)) | |
1919 (let* ((gnus-article (if header (mail-header-number header) article)) | |
1920 (summary-buffer (current-buffer)) | |
1921 (internal-hook gnus-article-internal-prepare-hook) | |
1922 (group gnus-newsgroup-name) | |
1923 result) | |
1924 (save-excursion | |
1925 (gnus-article-setup-buffer) | |
1926 (set-buffer gnus-article-buffer) | |
1927 ;; Deactivate active regions. | |
1928 (when (and (boundp 'transient-mark-mode) | |
1929 transient-mark-mode) | |
1930 (setq mark-active nil)) | |
1931 (if (not (setq result (let ((buffer-read-only nil)) | |
1932 (gnus-request-article-this-buffer | |
1933 article group)))) | |
1934 ;; There is no such article. | |
1935 (save-excursion | |
1936 (when (and (numberp article) | |
1937 (not (memq article gnus-newsgroup-sparse))) | |
1938 (setq gnus-article-current | |
1939 (cons gnus-newsgroup-name article)) | |
1940 (set-buffer gnus-summary-buffer) | |
1941 (setq gnus-current-article article) | |
1942 (gnus-summary-mark-article article gnus-canceled-mark)) | |
1943 (unless (memq article gnus-newsgroup-sparse) | |
1944 (gnus-error | |
1945 1 "No such article (may have expired or been canceled)"))) | |
1946 (if (or (eq result 'pseudo) (eq result 'nneething)) | |
1947 (progn | |
1948 (save-excursion | |
1949 (set-buffer summary-buffer) | |
1950 (setq gnus-last-article gnus-current-article | |
1951 gnus-newsgroup-history (cons gnus-current-article | |
1952 gnus-newsgroup-history) | |
1953 gnus-current-article 0 | |
1954 gnus-current-headers nil | |
1955 gnus-article-current nil) | |
1956 (if (eq result 'nneething) | |
1957 (gnus-configure-windows 'summary) | |
1958 (gnus-configure-windows 'article)) | |
1959 (gnus-set-global-variables)) | |
1960 (gnus-set-mode-line 'article)) | |
1961 ;; The result from the `request' was an actual article - | |
1962 ;; or at least some text that is now displayed in the | |
1963 ;; article buffer. | |
1964 (when (and (numberp article) | |
1965 (not (eq article gnus-current-article))) | |
1966 ;; Seems like a new article has been selected. | |
1967 ;; `gnus-current-article' must be an article number. | |
1968 (save-excursion | |
1969 (set-buffer summary-buffer) | |
1970 (setq gnus-last-article gnus-current-article | |
1971 gnus-newsgroup-history (cons gnus-current-article | |
1972 gnus-newsgroup-history) | |
1973 gnus-current-article article | |
1974 gnus-current-headers | |
1975 (gnus-summary-article-header gnus-current-article) | |
1976 gnus-article-current | |
1977 (cons gnus-newsgroup-name gnus-current-article)) | |
1978 (unless (vectorp gnus-current-headers) | |
1979 (setq gnus-current-headers nil)) | |
1980 (gnus-summary-show-thread) | |
1981 (run-hooks 'gnus-mark-article-hook) | |
1982 (gnus-set-mode-line 'summary) | |
1983 (when (gnus-visual-p 'article-highlight 'highlight) | |
1984 (run-hooks 'gnus-visual-mark-article-hook)) | |
1985 ;; Set the global newsgroup variables here. | |
1986 ;; Suggested by Jim Sisolak | |
1987 ;; <sisolak@trans4.neep.wisc.edu>. | |
1988 (gnus-set-global-variables) | |
1989 (setq gnus-have-all-headers | |
1990 (or all-headers gnus-show-all-headers)) | |
1991 (and gnus-use-cache | |
1992 (vectorp (gnus-summary-article-header article)) | |
1993 (gnus-cache-possibly-enter-article | |
1994 group article | |
1995 (gnus-summary-article-header article) | |
1996 (memq article gnus-newsgroup-marked) | |
1997 (memq article gnus-newsgroup-dormant) | |
1998 (memq article gnus-newsgroup-unreads))))) | |
1999 (when (or (numberp article) | |
2000 (stringp article)) | |
2001 ;; Hooks for getting information from the article. | |
2002 ;; This hook must be called before being narrowed. | |
2003 (let (buffer-read-only) | |
2004 (run-hooks 'internal-hook) | |
2005 (run-hooks 'gnus-article-prepare-hook) | |
2006 ;; Decode MIME message. | |
2007 (when gnus-show-mime | |
2008 (if (or (not gnus-strict-mime) | |
2009 (gnus-fetch-field "Mime-Version")) | |
2010 (funcall gnus-show-mime-method) | |
2011 (funcall gnus-decode-encoded-word-method))) | |
2012 ;; Perform the article display hooks. | |
2013 (run-hooks 'gnus-article-display-hook)) | |
2014 ;; Do page break. | |
2015 (goto-char (point-min)) | |
2016 (setq gnus-page-broken | |
2017 (when gnus-break-pages | |
2018 (gnus-narrow-to-page) | |
2019 t))) | |
2020 (gnus-set-mode-line 'article) | |
2021 (gnus-configure-windows 'article) | |
2022 (goto-char (point-min)) | |
2023 t)))))) | |
2024 | |
2025 (defun gnus-article-wash-status () | |
2026 "Return a string which display status of article washing." | |
2027 (save-excursion | |
2028 (set-buffer gnus-article-buffer) | |
2029 (let ((cite (gnus-article-hidden-text-p 'cite)) | |
2030 (headers (gnus-article-hidden-text-p 'headers)) | |
2031 (boring (gnus-article-hidden-text-p 'boring-headers)) | |
2032 (pgp (gnus-article-hidden-text-p 'pgp)) | |
2033 (pem (gnus-article-hidden-text-p 'pem)) | |
2034 (signature (gnus-article-hidden-text-p 'signature)) | |
2035 (overstrike (gnus-article-hidden-text-p 'overstrike)) | |
2036 (emphasis (gnus-article-hidden-text-p 'emphasis)) | |
2037 (mime gnus-show-mime)) | |
2038 (format "%c%c%c%c%c%c%c" | |
2039 (if cite ?c ? ) | |
2040 (if (or headers boring) ?h ? ) | |
2041 (if (or pgp pem) ?p ? ) | |
2042 (if signature ?s ? ) | |
2043 (if overstrike ?o ? ) | |
2044 (if mime ?m ? ) | |
2045 (if emphasis ?e ? ))))) | |
2046 | |
2047 (defun gnus-article-hide-headers-if-wanted () | |
2048 "Hide unwanted headers if `gnus-have-all-headers' is nil. | |
2049 Provided for backwards compatibility." | |
2050 (or (save-excursion (set-buffer gnus-summary-buffer) gnus-have-all-headers) | |
2051 gnus-inhibit-hiding | |
2052 (gnus-article-hide-headers))) | |
2053 | |
2054 ;;; Article savers. | |
2055 | |
2056 (defun gnus-output-to-file (file-name) | |
2057 "Append the current article to a file named FILE-NAME." | |
2058 (let ((artbuf (current-buffer))) | |
2059 (nnheader-temp-write nil | |
2060 (insert-buffer-substring artbuf) | |
2061 ;; Append newline at end of the buffer as separator, and then | |
2062 ;; save it to file. | |
2063 (goto-char (point-max)) | |
2064 (insert "\n") | |
19969
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
2065 (append-to-file (point-min) (point-max) file-name) |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
2066 t))) |
17493 | 2067 |
2068 (defun gnus-narrow-to-page (&optional arg) | |
2069 "Narrow the article buffer to a page. | |
2070 If given a numerical ARG, move forward ARG pages." | |
2071 (interactive "P") | |
2072 (setq arg (if arg (prefix-numeric-value arg) 0)) | |
2073 (save-excursion | |
2074 (set-buffer gnus-article-buffer) | |
2075 (goto-char (point-min)) | |
2076 (widen) | |
2077 ;; Remove any old next/prev buttons. | |
2078 (when (gnus-visual-p 'page-marker) | |
2079 (let ((buffer-read-only nil)) | |
2080 (gnus-remove-text-with-property 'gnus-prev) | |
2081 (gnus-remove-text-with-property 'gnus-next))) | |
2082 (when | |
2083 (cond ((< arg 0) | |
2084 (re-search-backward page-delimiter nil 'move (1+ (abs arg)))) | |
2085 ((> arg 0) | |
2086 (re-search-forward page-delimiter nil 'move arg))) | |
2087 (goto-char (match-end 0))) | |
2088 (narrow-to-region | |
2089 (point) | |
2090 (if (re-search-forward page-delimiter nil 'move) | |
2091 (match-beginning 0) | |
2092 (point))) | |
2093 (when (and (gnus-visual-p 'page-marker) | |
2094 (not (= (point-min) 1))) | |
2095 (save-excursion | |
2096 (goto-char (point-min)) | |
2097 (gnus-insert-prev-page-button))) | |
2098 (when (and (gnus-visual-p 'page-marker) | |
2099 (< (+ (point-max) 2) (buffer-size))) | |
2100 (save-excursion | |
2101 (goto-char (point-max)) | |
2102 (gnus-insert-next-page-button))))) | |
2103 | |
2104 ;; Article mode commands | |
2105 | |
2106 (defun gnus-article-goto-next-page () | |
2107 "Show the next page of the article." | |
2108 (interactive) | |
2109 (when (gnus-article-next-page) | |
2110 (goto-char (point-min)) | |
2111 (gnus-article-read-summary-keys nil (gnus-character-to-event ?n)))) | |
2112 | |
2113 (defun gnus-article-goto-prev-page () | |
2114 "Show the next page of the article." | |
2115 (interactive) | |
2116 (if (bobp) (gnus-article-read-summary-keys nil (gnus-character-to-event ?p)) | |
2117 (gnus-article-prev-page nil))) | |
2118 | |
2119 (defun gnus-article-next-page (&optional lines) | |
2120 "Show the next page of the current article. | |
2121 If end of article, return non-nil. Otherwise return nil. | |
2122 Argument LINES specifies lines to be scrolled up." | |
2123 (interactive "p") | |
2124 (move-to-window-line -1) | |
2125 (if (save-excursion | |
2126 (end-of-line) | |
2127 (and (pos-visible-in-window-p) ;Not continuation line. | |
2128 (eobp))) | |
2129 ;; Nothing in this page. | |
2130 (if (or (not gnus-page-broken) | |
2131 (save-excursion | |
2132 (save-restriction | |
2133 (widen) (forward-line 1) (eobp)))) ;Real end-of-buffer? | |
2134 t ;Nothing more. | |
2135 (gnus-narrow-to-page 1) ;Go to next page. | |
2136 nil) | |
2137 ;; More in this page. | |
2138 (let ((scroll-in-place nil)) | |
2139 (condition-case () | |
2140 (scroll-up lines) | |
2141 (end-of-buffer | |
2142 ;; Long lines may cause an end-of-buffer error. | |
2143 (goto-char (point-max))))) | |
2144 (move-to-window-line 0) | |
2145 nil)) | |
2146 | |
2147 (defun gnus-article-prev-page (&optional lines) | |
2148 "Show previous page of current article. | |
2149 Argument LINES specifies lines to be scrolled down." | |
2150 (interactive "p") | |
2151 (move-to-window-line 0) | |
2152 (if (and gnus-page-broken | |
2153 (bobp) | |
2154 (not (save-restriction (widen) (bobp)))) ;Real beginning-of-buffer? | |
2155 (progn | |
2156 (gnus-narrow-to-page -1) ;Go to previous page. | |
2157 (goto-char (point-max)) | |
2158 (recenter -1)) | |
2159 (let ((scroll-in-place nil)) | |
2160 (prog1 | |
2161 (condition-case () | |
2162 (scroll-down lines) | |
2163 (beginning-of-buffer | |
2164 (goto-char (point-min)))) | |
2165 (move-to-window-line 0))))) | |
2166 | |
2167 (defun gnus-article-refer-article () | |
2168 "Read article specified by message-id around point." | |
2169 (interactive) | |
2170 (let ((point (point))) | |
2171 (search-forward ">" nil t) ;Move point to end of "<....>". | |
2172 (if (re-search-backward "\\(<[^<> \t\n]+>\\)" nil t) | |
2173 (let ((message-id (match-string 1))) | |
2174 (goto-char point) | |
2175 (set-buffer gnus-summary-buffer) | |
2176 (gnus-summary-refer-article message-id)) | |
2177 (goto-char (point)) | |
2178 (error "No references around point")))) | |
2179 | |
2180 (defun gnus-article-show-summary () | |
2181 "Reconfigure windows to show summary buffer." | |
2182 (interactive) | |
2183 (if (not (gnus-buffer-live-p gnus-summary-buffer)) | |
2184 (error "There is no summary buffer for this article buffer") | |
19969
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
2185 (gnus-article-set-globals) |
17493 | 2186 (gnus-configure-windows 'article) |
2187 (gnus-summary-goto-subject gnus-current-article))) | |
2188 | |
2189 (defun gnus-article-describe-briefly () | |
2190 "Describe article mode commands briefly." | |
2191 (interactive) | |
2192 (gnus-message 6 | |
2193 (substitute-command-keys "\\<gnus-article-mode-map>\\[gnus-article-goto-next-page]:Next page \\[gnus-article-goto-prev-page]:Prev page \\[gnus-article-show-summary]:Show summary \\[gnus-info-find-node]:Run Info \\[gnus-article-describe-briefly]:This help"))) | |
2194 | |
2195 (defun gnus-article-summary-command () | |
2196 "Execute the last keystroke in the summary buffer." | |
2197 (interactive) | |
2198 (let ((obuf (current-buffer)) | |
2199 (owin (current-window-configuration)) | |
2200 func) | |
2201 (switch-to-buffer gnus-summary-buffer 'norecord) | |
2202 (setq func (lookup-key (current-local-map) (this-command-keys))) | |
2203 (call-interactively func) | |
2204 (set-buffer obuf) | |
2205 (set-window-configuration owin) | |
2206 (set-window-point (get-buffer-window (current-buffer)) (point)))) | |
2207 | |
2208 (defun gnus-article-summary-command-nosave () | |
2209 "Execute the last keystroke in the summary buffer." | |
2210 (interactive) | |
2211 (let (func) | |
2212 (pop-to-buffer gnus-summary-buffer 'norecord) | |
2213 (setq func (lookup-key (current-local-map) (this-command-keys))) | |
2214 (call-interactively func))) | |
2215 | |
2216 (defun gnus-article-read-summary-keys (&optional arg key not-restore-window) | |
2217 "Read a summary buffer key sequence and execute it from the article buffer." | |
2218 (interactive "P") | |
2219 (let ((nosaves | |
2220 '("q" "Q" "c" "r" "R" "\C-c\C-f" "m" "a" "f" "F" | |
2221 "Zc" "ZC" "ZE" "ZQ" "ZZ" "Zn" "ZR" "ZG" "ZN" "ZP" | |
2222 "=" "^" "\M-^" "|")) | |
2223 (nosave-but-article | |
2224 '("A\r")) | |
2225 (nosave-in-article | |
2226 '("\C-d")) | |
2227 keys) | |
2228 (save-excursion | |
2229 (set-buffer gnus-summary-buffer) | |
2230 (let (gnus-pick-mode) | |
2231 (push (or key last-command-event) unread-command-events) | |
2232 (setq keys (read-key-sequence nil)))) | |
2233 (message "") | |
2234 | |
2235 (if (or (member keys nosaves) | |
2236 (member keys nosave-but-article) | |
2237 (member keys nosave-in-article)) | |
2238 (let (func) | |
2239 (save-window-excursion | |
2240 (pop-to-buffer gnus-summary-buffer 'norecord) | |
2241 ;; We disable the pick minor mode commands. | |
2242 (let (gnus-pick-mode) | |
2243 (setq func (lookup-key (current-local-map) keys)))) | |
2244 (if (not func) | |
2245 (ding) | |
2246 (unless (member keys nosave-in-article) | |
2247 (set-buffer gnus-summary-buffer)) | |
2248 (call-interactively func)) | |
2249 (when (member keys nosave-but-article) | |
2250 (pop-to-buffer gnus-article-buffer 'norecord))) | |
2251 ;; These commands should restore window configuration. | |
2252 (let ((obuf (current-buffer)) | |
2253 (owin (current-window-configuration)) | |
2254 (opoint (point)) | |
2255 func in-buffer) | |
2256 (if not-restore-window | |
2257 (pop-to-buffer gnus-summary-buffer 'norecord) | |
2258 (switch-to-buffer gnus-summary-buffer 'norecord)) | |
2259 (setq in-buffer (current-buffer)) | |
2260 ;; We disable the pick minor mode commands. | |
2261 (if (setq func (let (gnus-pick-mode) | |
2262 (lookup-key (current-local-map) keys))) | |
2263 (call-interactively func) | |
2264 (ding)) | |
2265 (when (eq in-buffer (current-buffer)) | |
2266 (set-buffer obuf) | |
2267 (unless not-restore-window | |
2268 (set-window-configuration owin)) | |
2269 (set-window-point (get-buffer-window (current-buffer)) opoint)))))) | |
2270 | |
2271 (defun gnus-article-hide (&optional arg force) | |
2272 "Hide all the gruft in the current article. | |
2273 This means that PGP stuff, signatures, cited text and (some) | |
2274 headers will be hidden. | |
2275 If given a prefix, show the hidden text instead." | |
2276 (interactive (list current-prefix-arg 'force)) | |
2277 (gnus-article-hide-headers arg) | |
2278 (gnus-article-hide-pgp arg) | |
2279 (gnus-article-hide-citation-maybe arg force) | |
2280 (gnus-article-hide-signature arg)) | |
2281 | |
2282 (defun gnus-article-maybe-highlight () | |
2283 "Do some article highlighting if `article-visual' is non-nil." | |
2284 (when (gnus-visual-p 'article-highlight 'highlight) | |
2285 (gnus-article-highlight-some))) | |
2286 | |
2287 (defun gnus-request-article-this-buffer (article group) | |
2288 "Get an article and insert it into this buffer." | |
2289 (let (do-update-line) | |
2290 (prog1 | |
2291 (save-excursion | |
2292 (erase-buffer) | |
2293 (gnus-kill-all-overlays) | |
2294 (setq group (or group gnus-newsgroup-name)) | |
2295 | |
2296 ;; Open server if it has closed. | |
2297 (gnus-check-server (gnus-find-method-for-group group)) | |
2298 | |
2299 ;; Using `gnus-request-article' directly will insert the article into | |
2300 ;; `nntp-server-buffer' - so we'll save some time by not having to | |
2301 ;; copy it from the server buffer into the article buffer. | |
2302 | |
2303 ;; We only request an article by message-id when we do not have the | |
2304 ;; headers for it, so we'll have to get those. | |
2305 (when (stringp article) | |
2306 (let ((gnus-override-method gnus-refer-article-method)) | |
2307 (gnus-read-header article))) | |
2308 | |
2309 ;; If the article number is negative, that means that this article | |
2310 ;; doesn't belong in this newsgroup (possibly), so we find its | |
2311 ;; message-id and request it by id instead of number. | |
2312 (when (and (numberp article) | |
2313 gnus-summary-buffer | |
2314 (get-buffer gnus-summary-buffer) | |
2315 (buffer-name (get-buffer gnus-summary-buffer))) | |
2316 (save-excursion | |
2317 (set-buffer gnus-summary-buffer) | |
2318 (let ((header (gnus-summary-article-header article))) | |
2319 (when (< article 0) | |
2320 (cond | |
2321 ((memq article gnus-newsgroup-sparse) | |
2322 ;; This is a sparse gap article. | |
2323 (setq do-update-line article) | |
2324 (setq article (mail-header-id header)) | |
2325 (let ((gnus-override-method gnus-refer-article-method)) | |
2326 (gnus-read-header article)) | |
2327 (setq gnus-newsgroup-sparse | |
2328 (delq article gnus-newsgroup-sparse))) | |
2329 ((vectorp header) | |
2330 ;; It's a real article. | |
2331 (setq article (mail-header-id header))) | |
2332 (t | |
2333 ;; It is an extracted pseudo-article. | |
2334 (setq article 'pseudo) | |
2335 (gnus-request-pseudo-article header)))) | |
2336 | |
2337 (let ((method (gnus-find-method-for-group | |
2338 gnus-newsgroup-name))) | |
2339 (if (not (eq (car method) 'nneething)) | |
2340 () | |
2341 (let ((dir (concat (file-name-as-directory (nth 1 method)) | |
2342 (mail-header-subject header)))) | |
2343 (when (file-directory-p dir) | |
2344 (setq article 'nneething) | |
2345 (gnus-group-enter-directory dir)))))))) | |
2346 | |
2347 (cond | |
2348 ;; Refuse to select canceled articles. | |
2349 ((and (numberp article) | |
2350 gnus-summary-buffer | |
2351 (get-buffer gnus-summary-buffer) | |
2352 (buffer-name (get-buffer gnus-summary-buffer)) | |
2353 (eq (cdr (save-excursion | |
2354 (set-buffer gnus-summary-buffer) | |
2355 (assq article gnus-newsgroup-reads))) | |
2356 gnus-canceled-mark)) | |
2357 nil) | |
2358 ;; We first check `gnus-original-article-buffer'. | |
2359 ((and (get-buffer gnus-original-article-buffer) | |
2360 (numberp article) | |
2361 (save-excursion | |
2362 (set-buffer gnus-original-article-buffer) | |
2363 (and (equal (car gnus-original-article) group) | |
2364 (eq (cdr gnus-original-article) article)))) | |
2365 (insert-buffer-substring gnus-original-article-buffer) | |
2366 'article) | |
2367 ;; Check the backlog. | |
2368 ((and gnus-keep-backlog | |
2369 (gnus-backlog-request-article group article (current-buffer))) | |
2370 'article) | |
2371 ;; Check asynchronous pre-fetch. | |
2372 ((gnus-async-request-fetched-article group article (current-buffer)) | |
2373 (gnus-async-prefetch-next group article gnus-summary-buffer) | |
2374 'article) | |
2375 ;; Check the cache. | |
2376 ((and gnus-use-cache | |
2377 (numberp article) | |
2378 (gnus-cache-request-article article group)) | |
2379 'article) | |
2380 ;; Get the article and put into the article buffer. | |
2381 ((or (stringp article) (numberp article)) | |
2382 (let ((gnus-override-method | |
2383 (and (stringp article) gnus-refer-article-method)) | |
2384 (buffer-read-only nil)) | |
2385 (erase-buffer) | |
2386 (gnus-kill-all-overlays) | |
2387 (when (gnus-request-article article group (current-buffer)) | |
2388 (when (numberp article) | |
2389 (gnus-async-prefetch-next group article gnus-summary-buffer) | |
2390 (when gnus-keep-backlog | |
2391 (gnus-backlog-enter-article | |
2392 group article (current-buffer)))) | |
2393 'article))) | |
2394 ;; It was a pseudo. | |
2395 (t article))) | |
2396 | |
2397 ;; Take the article from the original article buffer | |
2398 ;; and place it in the buffer it's supposed to be in. | |
2399 (when (and (get-buffer gnus-article-buffer) | |
2400 ;;(numberp article) | |
2401 (equal (buffer-name (current-buffer)) | |
2402 (buffer-name (get-buffer gnus-article-buffer)))) | |
2403 (save-excursion | |
2404 (if (get-buffer gnus-original-article-buffer) | |
2405 (set-buffer (get-buffer gnus-original-article-buffer)) | |
2406 (set-buffer (get-buffer-create gnus-original-article-buffer)) | |
2407 (buffer-disable-undo (current-buffer)) | |
2408 (setq major-mode 'gnus-original-article-mode) | |
2409 (setq buffer-read-only t) | |
2410 (gnus-add-current-to-buffer-list)) | |
2411 (let (buffer-read-only) | |
2412 (erase-buffer) | |
2413 (insert-buffer-substring gnus-article-buffer)) | |
2414 (setq gnus-original-article (cons group article)))) | |
2415 | |
2416 ;; Update sparse articles. | |
2417 (when (and do-update-line | |
2418 (or (numberp article) | |
2419 (stringp article))) | |
2420 (let ((buf (current-buffer))) | |
2421 (set-buffer gnus-summary-buffer) | |
2422 (gnus-summary-update-article do-update-line) | |
2423 (gnus-summary-goto-subject do-update-line nil t) | |
2424 (set-window-point (get-buffer-window (current-buffer) t) | |
2425 (point)) | |
2426 (set-buffer buf)))))) | |
2427 | |
2428 ;;; | |
2429 ;;; Article editing | |
2430 ;;; | |
2431 | |
2432 (defcustom gnus-article-edit-mode-hook nil | |
2433 "Hook run in article edit mode buffers." | |
2434 :group 'gnus-article-various | |
2435 :type 'hook) | |
2436 | |
2437 (defvar gnus-article-edit-done-function nil) | |
2438 | |
2439 (defvar gnus-article-edit-mode-map nil) | |
2440 | |
2441 (unless gnus-article-edit-mode-map | |
2442 (setq gnus-article-edit-mode-map (copy-keymap text-mode-map)) | |
2443 | |
2444 (gnus-define-keys gnus-article-edit-mode-map | |
2445 "\C-c\C-c" gnus-article-edit-done | |
2446 "\C-c\C-k" gnus-article-edit-exit) | |
2447 | |
2448 (gnus-define-keys (gnus-article-edit-wash-map | |
2449 "\C-c\C-w" gnus-article-edit-mode-map) | |
2450 "f" gnus-article-edit-full-stops)) | |
2451 | |
2452 (defun gnus-article-edit-mode () | |
2453 "Major mode for editing articles. | |
2454 This is an extended text-mode. | |
2455 | |
2456 \\{gnus-article-edit-mode-map}" | |
2457 (interactive) | |
2458 (kill-all-local-variables) | |
2459 (setq major-mode 'gnus-article-edit-mode) | |
2460 (setq mode-name "Article Edit") | |
2461 (use-local-map gnus-article-edit-mode-map) | |
2462 (make-local-variable 'gnus-article-edit-done-function) | |
2463 (make-local-variable 'gnus-prev-winconf) | |
2464 (setq buffer-read-only nil) | |
2465 (buffer-enable-undo) | |
2466 (widen) | |
2467 (run-hooks 'text-mode 'gnus-article-edit-mode-hook)) | |
2468 | |
2469 (defun gnus-article-edit (&optional force) | |
2470 "Edit the current article. | |
2471 This will have permanent effect only in mail groups. | |
2472 If FORCE is non-nil, allow editing of articles even in read-only | |
2473 groups." | |
2474 (interactive "P") | |
2475 (when (and (not force) | |
2476 (gnus-group-read-only-p)) | |
19969
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
2477 (error "The current newsgroup does not support article editing")) |
17493 | 2478 (gnus-article-edit-article |
2479 `(lambda () | |
2480 (gnus-summary-edit-article-done | |
2481 ,(or (mail-header-references gnus-current-headers) "") | |
2482 ,(gnus-group-read-only-p) ,gnus-summary-buffer)))) | |
2483 | |
2484 (defun gnus-article-edit-article (exit-func) | |
2485 "Start editing the contents of the current article buffer." | |
2486 (let ((winconf (current-window-configuration))) | |
2487 (set-buffer gnus-article-buffer) | |
2488 (gnus-article-edit-mode) | |
19969
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
2489 (gnus-set-text-properties (point-min) (point-max) nil) |
17493 | 2490 (gnus-configure-windows 'edit-article) |
2491 (setq gnus-article-edit-done-function exit-func) | |
2492 (setq gnus-prev-winconf winconf) | |
2493 (gnus-message 6 "C-c C-c to end edits"))) | |
2494 | |
2495 (defun gnus-article-edit-done () | |
2496 "Update the article edits and exit." | |
2497 (interactive) | |
2498 (let ((func gnus-article-edit-done-function) | |
2499 (buf (current-buffer)) | |
2500 (start (window-start))) | |
2501 (gnus-article-edit-exit) | |
2502 (save-excursion | |
2503 (set-buffer buf) | |
2504 (let ((buffer-read-only nil)) | |
2505 (funcall func))) | |
2506 (set-buffer buf) | |
2507 (set-window-start (get-buffer-window buf) start) | |
2508 (set-window-point (get-buffer-window buf) (point)))) | |
2509 | |
2510 (defun gnus-article-edit-exit () | |
2511 "Exit the article editing without updating." | |
2512 (interactive) | |
2513 ;; We remove all text props from the article buffer. | |
2514 (let ((buf (format "%s" (buffer-string))) | |
2515 (curbuf (current-buffer)) | |
2516 (p (point)) | |
2517 (window-start (window-start))) | |
2518 (erase-buffer) | |
2519 (insert buf) | |
2520 (let ((winconf gnus-prev-winconf)) | |
2521 (gnus-article-mode) | |
2522 ;; The cache and backlog have to be flushed somewhat. | |
2523 (when gnus-use-cache | |
2524 (gnus-cache-update-article | |
2525 (car gnus-article-current) (cdr gnus-article-current))) | |
2526 (when gnus-keep-backlog | |
2527 (gnus-backlog-remove-article | |
2528 (car gnus-article-current) (cdr gnus-article-current))) | |
2529 ;; Flush original article as well. | |
2530 (save-excursion | |
2531 (when (get-buffer gnus-original-article-buffer) | |
2532 (set-buffer gnus-original-article-buffer) | |
2533 (setq gnus-original-article nil))) | |
2534 (set-window-configuration winconf) | |
2535 ;; Tippy-toe some to make sure that point remains where it was. | |
2536 (let ((buf (current-buffer))) | |
2537 (set-buffer curbuf) | |
2538 (set-window-start (get-buffer-window (current-buffer)) window-start) | |
2539 (goto-char p) | |
2540 (set-buffer buf))))) | |
2541 | |
2542 (defun gnus-article-edit-full-stops () | |
2543 "Interactively repair spacing at end of sentences." | |
2544 (interactive) | |
2545 (save-excursion | |
2546 (goto-char (point-min)) | |
2547 (search-forward-regexp "^$" nil t) | |
2548 (let ((case-fold-search nil)) | |
2549 (query-replace-regexp "\\([.!?][])}]* \\)\\([[({A-Z]\\)" "\\1 \\2")))) | |
2550 | |
2551 ;;; | |
2552 ;;; Article highlights | |
2553 ;;; | |
2554 | |
2555 ;; Written by Per Abrahamsen <abraham@iesd.auc.dk>. | |
2556 | |
2557 ;;; Internal Variables: | |
2558 | |
2559 (defcustom gnus-button-url-regexp "\\b\\(s?https?\\|ftp\\|file\\|gopher\\|news\\|telnet\\|wais\\|mailto\\):\\(//[-a-zA-Z0-9_.]+:[0-9]*\\)?\\([-a-zA-Z0-9_=!?#$@~`%&*+|\\/:;.,]\\|\\w\\)+\\([-a-zA-Z0-9_=#$@~`%&*+|\\/]\\|\\w\\)" | |
2560 "Regular expression that matches URLs." | |
2561 :group 'gnus-article-buttons | |
2562 :type 'regexp) | |
2563 | |
2564 (defcustom gnus-button-alist | |
2565 `(("<\\(url: ?\\)?news:\\([^>\n\t ]*@[^>\n\t ]*\\)>" 0 t | |
2566 gnus-button-message-id 2) | |
19969
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
2567 ("\\bnews:\\([^>\n\t ]*@[^>\n\t ]*\\)" 0 t gnus-button-message-id 1) |
17493 | 2568 ("\\(\\b<\\(url: ?\\)?news:\\(//\\)?\\([^>\n\t ]*\\)>\\)" 1 t |
2569 gnus-button-fetch-group 4) | |
2570 ("\\bnews:\\(//\\)?\\([^>\n\t ]+\\)" 0 t gnus-button-fetch-group 2) | |
2571 ("\\bin\\( +article\\)? +\\(<\\([^\n @<>]+@[^\n @<>]+\\)>\\)" 2 | |
2572 t gnus-button-message-id 3) | |
19969
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
2573 ("\\(<URL: *\\)mailto: *\\([^> \n\t]+\\)>" 0 t gnus-url-mailto 2) |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
2574 ("\\bmailto:\\([^ \n\t]+\\)" 0 t gnus-url-mailto 1) |
17493 | 2575 ;; This is how URLs _should_ be embedded in text... |
2576 ("<URL: *\\([^>]*\\)>" 0 t gnus-button-embedded-url 1) | |
2577 ;; Raw URLs. | |
2578 (,gnus-button-url-regexp 0 t gnus-button-url 0)) | |
2579 "Alist of regexps matching buttons in article bodies. | |
2580 | |
2581 Each entry has the form (REGEXP BUTTON FORM CALLBACK PAR...), where | |
2582 REGEXP: is the string matching text around the button, | |
2583 BUTTON: is the number of the regexp grouping actually matching the button, | |
2584 FORM: is a lisp expression which must eval to true for the button to | |
2585 be added, | |
2586 CALLBACK: is the function to call when the user push this button, and each | |
2587 PAR: is a number of a regexp grouping whose text will be passed to CALLBACK. | |
2588 | |
2589 CALLBACK can also be a variable, in that case the value of that | |
2590 variable it the real callback function." | |
2591 :group 'gnus-article-buttons | |
2592 :type '(repeat (list regexp | |
2593 (integer :tag "Button") | |
2594 (sexp :tag "Form") | |
2595 (function :tag "Callback") | |
2596 (repeat :tag "Par" | |
2597 :inline t | |
2598 (integer :tag "Regexp group"))))) | |
2599 | |
2600 (defcustom gnus-header-button-alist | |
2601 `(("^\\(References\\|Message-I[Dd]\\):" "<[^>]+>" | |
2602 0 t gnus-button-message-id 0) | |
2603 ("^\\(From\\|Reply-To\\):" ": *\\(.+\\)$" 1 t gnus-button-reply 1) | |
2604 ("^\\(Cc\\|To\\):" "[^ \t\n<>,()\"]+@[^ \t\n<>,()\"]+" | |
2605 0 t gnus-button-mailto 0) | |
2606 ("^X-[Uu][Rr][Ll]:" ,gnus-button-url-regexp 0 t gnus-button-url 0) | |
19969
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
2607 ("^Subject:" ,gnus-button-url-regexp 0 t gnus-button-url 0) |
17493 | 2608 ("^[^:]+:" ,gnus-button-url-regexp 0 t gnus-button-url 0) |
2609 ("^[^:]+:" "\\(<\\(url: \\)?news:\\([^>\n ]*\\)>\\)" 1 t | |
2610 gnus-button-message-id 3)) | |
2611 "Alist of headers and regexps to match buttons in article heads. | |
2612 | |
2613 This alist is very similar to `gnus-button-alist', except that each | |
2614 alist has an additional HEADER element first in each entry: | |
2615 | |
2616 \(HEADER REGEXP BUTTON FORM CALLBACK PAR) | |
2617 | |
2618 HEADER is a regexp to match a header. For a fuller explanation, see | |
2619 `gnus-button-alist'." | |
2620 :group 'gnus-article-buttons | |
2621 :group 'gnus-article-headers | |
2622 :type '(repeat (list (regexp :tag "Header") | |
2623 regexp | |
2624 (integer :tag "Button") | |
2625 (sexp :tag "Form") | |
2626 (function :tag "Callback") | |
2627 (repeat :tag "Par" | |
2628 :inline t | |
2629 (integer :tag "Regexp group"))))) | |
2630 | |
2631 (defvar gnus-button-regexp nil) | |
2632 (defvar gnus-button-marker-list nil) | |
2633 ;; Regexp matching any of the regexps from `gnus-button-alist'. | |
2634 | |
2635 (defvar gnus-button-last nil) | |
2636 ;; The value of `gnus-button-alist' when `gnus-button-regexp' was build. | |
2637 | |
2638 ;;; Commands: | |
2639 | |
2640 (defun gnus-article-push-button (event) | |
2641 "Check text under the mouse pointer for a callback function. | |
2642 If the text under the mouse pointer has a `gnus-callback' property, | |
2643 call it with the value of the `gnus-data' text property." | |
2644 (interactive "e") | |
2645 (set-buffer (window-buffer (posn-window (event-start event)))) | |
2646 (let* ((pos (posn-point (event-start event))) | |
2647 (data (get-text-property pos 'gnus-data)) | |
2648 (fun (get-text-property pos 'gnus-callback))) | |
2649 (when fun | |
2650 (funcall fun data)))) | |
2651 | |
2652 (defun gnus-article-press-button () | |
2653 "Check text at point for a callback function. | |
2654 If the text at point has a `gnus-callback' property, | |
2655 call it with the value of the `gnus-data' text property." | |
2656 (interactive) | |
2657 (let* ((data (get-text-property (point) 'gnus-data)) | |
2658 (fun (get-text-property (point) 'gnus-callback))) | |
2659 (when fun | |
2660 (funcall fun data)))) | |
2661 | |
2662 (defun gnus-article-prev-button (n) | |
2663 "Move point to N buttons backward. | |
2664 If N is negative, move forward instead." | |
2665 (interactive "p") | |
2666 (gnus-article-next-button (- n))) | |
2667 | |
2668 (defun gnus-article-next-button (n) | |
2669 "Move point to N buttons forward. | |
2670 If N is negative, move backward instead." | |
2671 (interactive "p") | |
2672 (let ((function (if (< n 0) 'previous-single-property-change | |
2673 'next-single-property-change)) | |
2674 (inhibit-point-motion-hooks t) | |
2675 (backward (< n 0)) | |
2676 (limit (if (< n 0) (point-min) (point-max)))) | |
2677 (setq n (abs n)) | |
2678 (while (and (not (= limit (point))) | |
2679 (> n 0)) | |
2680 ;; Skip past the current button. | |
2681 (when (get-text-property (point) 'gnus-callback) | |
2682 (goto-char (funcall function (point) 'gnus-callback nil limit))) | |
2683 ;; Go to the next (or previous) button. | |
2684 (gnus-goto-char (funcall function (point) 'gnus-callback nil limit)) | |
2685 ;; Put point at the start of the button. | |
2686 (when (and backward (not (get-text-property (point) 'gnus-callback))) | |
2687 (goto-char (funcall function (point) 'gnus-callback nil limit))) | |
2688 ;; Skip past intangible buttons. | |
2689 (when (get-text-property (point) 'intangible) | |
2690 (incf n)) | |
2691 (decf n)) | |
2692 (unless (zerop n) | |
2693 (gnus-message 5 "No more buttons")) | |
2694 n)) | |
2695 | |
2696 (defun gnus-article-highlight (&optional force) | |
2697 "Highlight current article. | |
2698 This function calls `gnus-article-highlight-headers', | |
2699 `gnus-article-highlight-citation', | |
2700 `gnus-article-highlight-signature', and `gnus-article-add-buttons' to | |
2701 do the highlighting. See the documentation for those functions." | |
2702 (interactive (list 'force)) | |
2703 (gnus-article-highlight-headers) | |
2704 (gnus-article-highlight-citation force) | |
2705 (gnus-article-highlight-signature) | |
2706 (gnus-article-add-buttons force) | |
2707 (gnus-article-add-buttons-to-head)) | |
2708 | |
2709 (defun gnus-article-highlight-some (&optional force) | |
2710 "Highlight current article. | |
2711 This function calls `gnus-article-highlight-headers', | |
2712 `gnus-article-highlight-signature', and `gnus-article-add-buttons' to | |
2713 do the highlighting. See the documentation for those functions." | |
2714 (interactive (list 'force)) | |
2715 (gnus-article-highlight-headers) | |
2716 (gnus-article-highlight-signature) | |
2717 (gnus-article-add-buttons)) | |
2718 | |
2719 (defun gnus-article-highlight-headers () | |
2720 "Highlight article headers as specified by `gnus-header-face-alist'." | |
2721 (interactive) | |
2722 (save-excursion | |
2723 (set-buffer gnus-article-buffer) | |
2724 (save-restriction | |
2725 (let ((alist gnus-header-face-alist) | |
2726 (buffer-read-only nil) | |
2727 (case-fold-search t) | |
2728 (inhibit-point-motion-hooks t) | |
2729 entry regexp header-face field-face from hpoints fpoints) | |
2730 (message-narrow-to-head) | |
2731 (while (setq entry (pop alist)) | |
2732 (goto-char (point-min)) | |
2733 (setq regexp (concat "^\\(" | |
2734 (if (string-equal "" (nth 0 entry)) | |
2735 "[^\t ]" | |
2736 (nth 0 entry)) | |
2737 "\\)") | |
2738 header-face (nth 1 entry) | |
2739 field-face (nth 2 entry)) | |
2740 (while (and (re-search-forward regexp nil t) | |
2741 (not (eobp))) | |
2742 (beginning-of-line) | |
2743 (setq from (point)) | |
2744 (unless (search-forward ":" nil t) | |
2745 (forward-char 1)) | |
2746 (when (and header-face | |
2747 (not (memq (point) hpoints))) | |
2748 (push (point) hpoints) | |
2749 (gnus-put-text-property from (point) 'face header-face)) | |
2750 (when (and field-face | |
2751 (not (memq (setq from (point)) fpoints))) | |
2752 (push from fpoints) | |
2753 (if (re-search-forward "^[^ \t]" nil t) | |
2754 (forward-char -2) | |
2755 (goto-char (point-max))) | |
2756 (gnus-put-text-property from (point) 'face field-face)))))))) | |
2757 | |
2758 (defun gnus-article-highlight-signature () | |
2759 "Highlight the signature in an article. | |
2760 It does this by highlighting everything after | |
2761 `gnus-signature-separator' using `gnus-signature-face'." | |
2762 (interactive) | |
2763 (save-excursion | |
2764 (set-buffer gnus-article-buffer) | |
2765 (let ((buffer-read-only nil) | |
2766 (inhibit-point-motion-hooks t)) | |
2767 (save-restriction | |
2768 (when (and gnus-signature-face | |
2769 (gnus-article-narrow-to-signature)) | |
2770 (gnus-overlay-put (gnus-make-overlay (point-min) (point-max)) | |
2771 'face gnus-signature-face) | |
2772 (widen) | |
2773 (gnus-article-search-signature) | |
2774 (let ((start (match-beginning 0)) | |
2775 (end (set-marker (make-marker) (1+ (match-end 0))))) | |
2776 (gnus-article-add-button start (1- end) 'gnus-signature-toggle | |
2777 end))))))) | |
2778 | |
2779 (defun gnus-button-in-region-p (b e prop) | |
2780 "Say whether PROP exists in the region." | |
2781 (text-property-not-all b e prop nil)) | |
2782 | |
2783 (defun gnus-article-add-buttons (&optional force) | |
2784 "Find external references in the article and make buttons of them. | |
2785 \"External references\" are things like Message-IDs and URLs, as | |
2786 specified by `gnus-button-alist'." | |
2787 (interactive (list 'force)) | |
2788 (save-excursion | |
2789 (set-buffer gnus-article-buffer) | |
2790 (let ((buffer-read-only nil) | |
2791 (inhibit-point-motion-hooks t) | |
2792 (case-fold-search t) | |
2793 (alist gnus-button-alist) | |
2794 beg entry regexp) | |
2795 ;; Remove all old markers. | |
2796 (let (marker entry) | |
2797 (while (setq marker (pop gnus-button-marker-list)) | |
2798 (goto-char marker) | |
2799 (when (setq entry (gnus-button-entry)) | |
2800 (put-text-property (match-beginning (nth 1 entry)) | |
2801 (match-end (nth 1 entry)) | |
2802 'gnus-callback nil)) | |
2803 (set-marker marker nil))) | |
2804 ;; We skip the headers. | |
2805 (goto-char (point-min)) | |
2806 (unless (search-forward "\n\n" nil t) | |
2807 (goto-char (point-max))) | |
2808 (setq beg (point)) | |
2809 (while (setq entry (pop alist)) | |
2810 (setq regexp (car entry)) | |
2811 (goto-char beg) | |
2812 (while (re-search-forward regexp nil t) | |
2813 (let* ((start (and entry (match-beginning (nth 1 entry)))) | |
2814 (end (and entry (match-end (nth 1 entry)))) | |
2815 (from (match-beginning 0))) | |
2816 (when (and (or (eq t (nth 2 entry)) | |
2817 (eval (nth 2 entry))) | |
2818 (not (gnus-button-in-region-p | |
2819 start end 'gnus-callback))) | |
2820 ;; That optional form returned non-nil, so we add the | |
2821 ;; button. | |
2822 (gnus-article-add-button | |
2823 start end 'gnus-button-push | |
2824 (car (push (set-marker (make-marker) from) | |
2825 gnus-button-marker-list)))))))))) | |
2826 | |
2827 ;; Add buttons to the head of an article. | |
2828 (defun gnus-article-add-buttons-to-head () | |
2829 "Add buttons to the head of the article." | |
2830 (interactive) | |
2831 (save-excursion | |
2832 (set-buffer gnus-article-buffer) | |
2833 (let ((buffer-read-only nil) | |
2834 (inhibit-point-motion-hooks t) | |
2835 (case-fold-search t) | |
2836 (alist gnus-header-button-alist) | |
2837 entry beg end) | |
2838 (nnheader-narrow-to-headers) | |
2839 (while alist | |
2840 ;; Each alist entry. | |
2841 (setq entry (car alist) | |
2842 alist (cdr alist)) | |
2843 (goto-char (point-min)) | |
2844 (while (re-search-forward (car entry) nil t) | |
2845 ;; Each header matching the entry. | |
2846 (setq beg (match-beginning 0)) | |
2847 (setq end (or (and (re-search-forward "^[^ \t]" nil t) | |
2848 (match-beginning 0)) | |
2849 (point-max))) | |
2850 (goto-char beg) | |
2851 (while (re-search-forward (nth 1 entry) end t) | |
2852 ;; Each match within a header. | |
2853 (let* ((entry (cdr entry)) | |
2854 (start (match-beginning (nth 1 entry))) | |
2855 (end (match-end (nth 1 entry))) | |
2856 (form (nth 2 entry))) | |
2857 (goto-char (match-end 0)) | |
2858 (when (eval form) | |
2859 (gnus-article-add-button | |
2860 start end (nth 3 entry) | |
2861 (buffer-substring (match-beginning (nth 4 entry)) | |
2862 (match-end (nth 4 entry))))))) | |
2863 (goto-char end)))) | |
2864 (widen))) | |
2865 | |
2866 ;;; External functions: | |
2867 | |
2868 (defun gnus-article-add-button (from to fun &optional data) | |
2869 "Create a button between FROM and TO with callback FUN and data DATA." | |
2870 (when gnus-article-button-face | |
2871 (gnus-overlay-put (gnus-make-overlay from to) | |
2872 'face gnus-article-button-face)) | |
2873 (gnus-add-text-properties | |
2874 from to | |
2875 (nconc (and gnus-article-mouse-face | |
2876 (list gnus-mouse-face-prop gnus-article-mouse-face)) | |
2877 (list 'gnus-callback fun) | |
2878 (and data (list 'gnus-data data))))) | |
2879 | |
2880 ;;; Internal functions: | |
2881 | |
19969
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
2882 (defun gnus-article-set-globals () |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
2883 (save-excursion |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
2884 (set-buffer gnus-summary-buffer) |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
2885 (gnus-set-global-variables))) |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19537
diff
changeset
|
2886 |
17493 | 2887 (defun gnus-signature-toggle (end) |
2888 (save-excursion | |
2889 (set-buffer gnus-article-buffer) | |
2890 (let ((buffer-read-only nil) | |
2891 (inhibit-point-motion-hooks t)) | |
2892 (if (get-text-property end 'invisible) | |
2893 (gnus-article-unhide-text end (point-max)) | |
2894 (gnus-article-hide-text end (point-max) gnus-hidden-properties))))) | |
2895 | |
2896 (defun gnus-button-entry () | |
2897 ;; Return the first entry in `gnus-button-alist' matching this place. | |
2898 (let ((alist gnus-button-alist) | |
2899 (entry nil)) | |
2900 (while alist | |
2901 (setq entry (pop alist)) | |
2902 (if (looking-at (car entry)) | |
2903 (setq alist nil) | |
2904 (setq entry nil))) | |
2905 entry)) | |
2906 | |
2907 (defun gnus-button-push (marker) | |
2908 ;; Push button starting at MARKER. | |
2909 (save-excursion | |
2910 (set-buffer gnus-article-buffer) | |
2911 (goto-char marker) | |
2912 (let* ((entry (gnus-button-entry)) | |
2913 (inhibit-point-motion-hooks t) | |
2914 (fun (nth 3 entry)) | |
2915 (args (mapcar (lambda (group) | |
2916 (let ((string (match-string group))) | |
2917 (gnus-set-text-properties | |
2918 0 (length string) nil string) | |
2919 string)) | |
2920 (nthcdr 4 entry)))) | |
2921 (cond | |
2922 ((fboundp fun) | |
2923 (apply fun args)) | |
2924 ((and (boundp fun) | |
2925 (fboundp (symbol-value fun))) | |
2926 (apply (symbol-value fun) args)) | |
2927 (t | |
2928 (gnus-message 1 "You must define `%S' to use this button" | |
2929 (cons fun args))))))) | |
2930 | |
2931 (defun gnus-button-message-id (message-id) | |
2932 "Fetch MESSAGE-ID." | |
2933 (save-excursion | |
2934 (set-buffer gnus-summary-buffer) | |
2935 (gnus-summary-refer-article message-id))) | |
2936 | |
2937 (defun gnus-button-fetch-group (address) | |
2938 "Fetch GROUP specified by ADDRESS." | |
2939 (if (not (string-match "[:/]" address)) | |
2940 ;; This is just a simple group url. | |
2941 (gnus-group-read-ephemeral-group address gnus-select-method) | |
2942 (if (not (string-match "^\\([^:/]+\\)\\(:\\([^/]+\\)/\\)?\\(.*\\)$" | |
2943 address)) | |
2944 (error "Can't parse %s" address) | |
2945 (gnus-group-read-ephemeral-group | |
2946 (match-string 4 address) | |
2947 `(nntp ,(match-string 1 address) | |
2948 (nntp-address ,(match-string 1 address)) | |
2949 (nntp-port-number ,(if (match-end 3) | |
2950 (match-string 3 address) | |
2951 "nntp"))))))) | |
2952 | |
2953 (defun gnus-split-string (string pattern) | |
2954 "Return a list of substrings of STRING which are separated by PATTERN." | |
2955 (let (parts (start 0)) | |
2956 (while (string-match pattern string start) | |
2957 (setq parts (cons (substring string start (match-beginning 0)) parts) | |
2958 start (match-end 0))) | |
2959 (nreverse (cons (substring string start) parts)))) | |
2960 | |
2961 (defun gnus-url-parse-query-string (query &optional downcase) | |
2962 (let (retval pairs cur key val) | |
2963 (setq pairs (gnus-split-string query "&")) | |
2964 (while pairs | |
2965 (setq cur (car pairs) | |
2966 pairs (cdr pairs)) | |
2967 (if (not (string-match "=" cur)) | |
2968 nil ; Grace | |
2969 (setq key (gnus-url-unhex-string (substring cur 0 (match-beginning 0))) | |
2970 val (gnus-url-unhex-string (substring cur (match-end 0) nil))) | |
2971 (if downcase | |
2972 (setq key (downcase key))) | |
2973 (setq cur (assoc key retval)) | |
2974 (if cur | |
2975 (setcdr cur (cons val (cdr cur))) | |
2976 (setq retval (cons (list key val) retval))))) | |
2977 retval)) | |
2978 | |
2979 (defun gnus-url-unhex (x) | |
2980 (if (> x ?9) | |
2981 (if (>= x ?a) | |
2982 (+ 10 (- x ?a)) | |
2983 (+ 10 (- x ?A))) | |
2984 (- x ?0))) | |
2985 | |
2986 (defun gnus-url-unhex-string (str &optional allow-newlines) | |
2987 "Remove %XXX embedded spaces, etc in a url. | |
2988 If optional second argument ALLOW-NEWLINES is non-nil, then allow the | |
2989 decoding of carriage returns and line feeds in the string, which is normally | |
2990 forbidden in URL encoding." | |
2991 (setq str (or str "")) | |
2992 (let ((tmp "") | |
2993 (case-fold-search t)) | |
2994 (while (string-match "%[0-9a-f][0-9a-f]" str) | |
2995 (let* ((start (match-beginning 0)) | |
2996 (ch1 (gnus-url-unhex (elt str (+ start 1)))) | |
2997 (code (+ (* 16 ch1) | |
2998 (gnus-url-unhex (elt str (+ start 2)))))) | |
2999 (setq tmp (concat | |
3000 tmp (substring str 0 start) | |
3001 (cond | |
3002 (allow-newlines | |
3003 (char-to-string code)) | |
3004 ((or (= code ?\n) (= code ?\r)) | |
3005 " ") | |
3006 (t (char-to-string code)))) | |
3007 str (substring str (match-end 0))))) | |
3008 (setq tmp (concat tmp str)) | |
3009 tmp)) | |
3010 | |
3011 (defun gnus-url-mailto (url) | |
3012 ;; Send mail to someone | |
3013 (when (string-match "mailto:/*\\(.*\\)" url) | |
3014 (setq url (substring url (match-beginning 1) nil))) | |
3015 (let (to args source-url subject func) | |
3016 (if (string-match (regexp-quote "?") url) | |
3017 (setq to (gnus-url-unhex-string (substring url 0 (match-beginning 0))) | |
3018 args (gnus-url-parse-query-string | |
3019 (substring url (match-end 0) nil) t)) | |
3020 (setq to (gnus-url-unhex-string url))) | |
3021 (setq args (cons (list "to" to) args) | |
3022 subject (cdr-safe (assoc "subject" args))) | |
3023 (message-mail) | |
3024 (while args | |
3025 (setq func (intern-soft (concat "message-goto-" (downcase (caar args))))) | |
3026 (if (fboundp func) | |
3027 (funcall func) | |
3028 (message-position-on-field (caar args))) | |
3029 (insert (mapconcat 'identity (cdar args) ", ")) | |
3030 (setq args (cdr args))) | |
3031 (if subject | |
3032 (message-goto-body) | |
3033 (message-goto-subject)))) | |
3034 | |
3035 (defun gnus-button-mailto (address) | |
3036 ;; Mail to ADDRESS. | |
3037 (set-buffer (gnus-copy-article-buffer)) | |
3038 (message-reply address)) | |
3039 | |
3040 (defun gnus-button-reply (address) | |
3041 ;; Reply to ADDRESS. | |
3042 (message-reply address)) | |
3043 | |
3044 (defun gnus-button-url (address) | |
3045 "Browse ADDRESS." | |
3046 (funcall browse-url-browser-function address)) | |
3047 | |
3048 (defun gnus-button-embedded-url (address) | |
3049 "Browse ADDRESS." | |
3050 (funcall browse-url-browser-function (gnus-strip-whitespace address))) | |
3051 | |
3052 ;;; Next/prev buttons in the article buffer. | |
3053 | |
3054 (defvar gnus-next-page-line-format "%{%(Next page...%)%}\n") | |
3055 (defvar gnus-prev-page-line-format "%{%(Previous page...%)%}\n") | |
3056 | |
3057 (defvar gnus-prev-page-map nil) | |
3058 (unless gnus-prev-page-map | |
3059 (setq gnus-prev-page-map (make-sparse-keymap)) | |
3060 (define-key gnus-prev-page-map gnus-mouse-2 'gnus-button-prev-page) | |
3061 (define-key gnus-prev-page-map "\r" 'gnus-button-prev-page)) | |
3062 | |
3063 (defun gnus-insert-prev-page-button () | |
3064 (let ((buffer-read-only nil)) | |
3065 (gnus-eval-format | |
3066 gnus-prev-page-line-format nil | |
3067 `(gnus-prev t local-map ,gnus-prev-page-map | |
3068 gnus-callback gnus-article-button-prev-page)))) | |
3069 | |
3070 (defvar gnus-next-page-map nil) | |
3071 (unless gnus-next-page-map | |
3072 (setq gnus-next-page-map (make-keymap)) | |
3073 (suppress-keymap gnus-prev-page-map) | |
3074 (define-key gnus-next-page-map gnus-mouse-2 'gnus-button-next-page) | |
3075 (define-key gnus-next-page-map "\r" 'gnus-button-next-page)) | |
3076 | |
3077 (defun gnus-button-next-page () | |
3078 "Go to the next page." | |
3079 (interactive) | |
3080 (let ((win (selected-window))) | |
3081 (select-window (get-buffer-window gnus-article-buffer t)) | |
3082 (gnus-article-next-page) | |
3083 (select-window win))) | |
3084 | |
3085 (defun gnus-button-prev-page () | |
3086 "Go to the prev page." | |
3087 (interactive) | |
3088 (let ((win (selected-window))) | |
3089 (select-window (get-buffer-window gnus-article-buffer t)) | |
3090 (gnus-article-prev-page) | |
3091 (select-window win))) | |
3092 | |
3093 (defun gnus-insert-next-page-button () | |
3094 (let ((buffer-read-only nil)) | |
3095 (gnus-eval-format gnus-next-page-line-format nil | |
3096 `(gnus-next t local-map ,gnus-next-page-map | |
3097 gnus-callback | |
3098 gnus-article-button-next-page)))) | |
3099 | |
3100 (defun gnus-article-button-next-page (arg) | |
3101 "Go to the next page." | |
3102 (interactive "P") | |
3103 (let ((win (selected-window))) | |
3104 (select-window (get-buffer-window gnus-article-buffer t)) | |
3105 (gnus-article-next-page) | |
3106 (select-window win))) | |
3107 | |
3108 (defun gnus-article-button-prev-page (arg) | |
3109 "Go to the prev page." | |
3110 (interactive "P") | |
3111 (let ((win (selected-window))) | |
3112 (select-window (get-buffer-window gnus-article-buffer t)) | |
3113 (gnus-article-prev-page) | |
3114 (select-window win))) | |
3115 | |
3116 (gnus-ems-redefine) | |
3117 | |
3118 (provide 'gnus-art) | |
3119 | |
3120 (run-hooks 'gnus-art-load-hook) | |
3121 | |
3122 ;;; gnus-art.el ends here |