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