Mercurial > emacs
annotate lisp/gnus-vis.el @ 18797:e9aa787f0154
(quail-translate-key): Fix previous change.
author | Kenichi Handa <handa@m17n.org> |
---|---|
date | Tue, 15 Jul 1997 08:24:47 +0000 |
parents | 092790f767a4 |
children |
rev | line source |
---|---|
13401 | 1 ;;; gnus-vis.el --- display-oriented parts of Gnus |
15511 | 2 ;; Copyright (C) 1995,96 Free Software Foundation, Inc. |
13401 | 3 |
4 ;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> | |
5 ;; Per Abrahamsen <abraham@iesd.auc.dk> | |
6 ;; Keywords: news | |
7 | |
8 ;; This file is part of GNU Emacs. | |
9 | |
10 ;; GNU Emacs is free software; you can redistribute it and/or modify | |
11 ;; it under the terms of the GNU General Public License as published by | |
12 ;; the Free Software Foundation; either version 2, or (at your option) | |
13 ;; any later version. | |
14 | |
15 ;; GNU Emacs is distributed in the hope that it will be useful, | |
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
18 ;; GNU General Public License for more details. | |
19 | |
20 ;; You should have received a copy of the GNU General Public License | |
14169 | 21 ;; along with GNU Emacs; see the file COPYING. If not, write to the |
22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
23 ;; Boston, MA 02111-1307, USA. | |
13401 | 24 |
25 ;;; Commentary: | |
26 | |
27 ;;; Code: | |
28 | |
29 (require 'gnus) | |
30 (require 'gnus-ems) | |
31 (require 'easymenu) | |
32 (require 'custom) | |
15511 | 33 (require 'browse-url) |
34 (require 'gnus-score) | |
35 (eval-when-compile (require 'cl)) | |
13401 | 36 |
37 (defvar gnus-group-menu-hook nil | |
38 "*Hook run after the creation of the group mode menu.") | |
39 | |
40 (defvar gnus-summary-menu-hook nil | |
41 "*Hook run after the creation of the summary mode menu.") | |
42 | |
43 (defvar gnus-article-menu-hook nil | |
44 "*Hook run after the creation of the article mode menu.") | |
45 | |
46 ;;; Summary highlights. | |
47 | |
48 ;(defvar gnus-summary-highlight-properties | |
49 ; '((unread "ForestGreen" "green") | |
50 ; (ticked "Firebrick" "pink") | |
51 ; (read "black" "white") | |
52 ; (low italic italic) | |
53 ; (high bold bold) | |
54 ; (canceled "yellow/black" "black/yellow"))) | |
55 | |
56 ;(defvar gnus-summary-highlight-translation | |
57 ; '(((unread (= mark gnus-unread-mark)) | |
58 ; (ticked (or (= mark gnus-ticked-mark) (= mark gnus-dormant-mark))) | |
59 ; (read (not (or (= mark gnus-unread-mark) (= mark gnus-dormant-mark) | |
60 ; (= mark gnus-ticked-mark) (= mark gnus-canceled-mark)))) | |
61 ; (canceled (= mark gnus-canceled-mark))) | |
62 ; ((low (< score gnus-summary-default-score)) | |
63 ; (high (> score gnus-summary-default-score))))) | |
64 | |
65 ;(defun gnus-visual-map-face-translation () | |
66 ; (let ((props gnus-summary-highlight-properties) | |
67 ; (trans gnus-summary-highlight-translation) | |
68 ; map) | |
69 ; (while props))) | |
70 | |
71 ;see gnus-cus.el | |
72 ;(defvar gnus-summary-selected-face 'underline | |
73 ; "*Face used for highlighting the current article in the summary buffer.") | |
74 | |
75 ;see gnus-cus.el | |
76 ;(defvar gnus-summary-highlight | |
77 ; (cond ((not (eq gnus-display-type 'color)) | |
78 ; '(((> score default) . bold) | |
79 ; ((< score default) . italic))) | |
80 ; ((eq gnus-background-mode 'dark) | |
81 ; (list (cons '(= mark gnus-canceled-mark) | |
82 ; (custom-face-lookup "yellow" "black" nil nil nil nil)) | |
83 ; (cons '(and (> score default) | |
84 ; (or (= mark gnus-dormant-mark) | |
85 ; (= mark gnus-ticked-mark))) | |
86 ; (custom-face-lookup "pink" nil nil t nil nil)) | |
87 ; (cons '(and (< score default) | |
88 ; (or (= mark gnus-dormant-mark) | |
89 ; (= mark gnus-ticked-mark))) | |
90 ; (custom-face-lookup "pink" nil nil nil t nil)) | |
91 ; (cons '(or (= mark gnus-dormant-mark) | |
92 ; (= mark gnus-ticked-mark)) | |
93 ; (custom-face-lookup "pink" nil nil nil nil nil)) | |
94 | |
95 ; (cons '(and (> score default) (= mark gnus-ancient-mark)) | |
96 ; (custom-face-lookup "SkyBlue" nil nil t nil nil)) | |
97 ; (cons '(and (< score default) (= mark gnus-ancient-mark)) | |
98 ; (custom-face-lookup "SkyBlue" nil nil nil t nil)) | |
99 ; (cons '(= mark gnus-ancient-mark) | |
100 ; (custom-face-lookup "SkyBlue" nil nil nil nil nil)) | |
101 | |
102 ; (cons '(and (> score default) (= mark gnus-unread-mark)) | |
103 ; (custom-face-lookup "white" nil nil t nil nil)) | |
104 ; (cons '(and (< score default) (= mark gnus-unread-mark)) | |
105 ; (custom-face-lookup "white" nil nil nil t nil)) | |
106 ; (cons '(= mark gnus-unread-mark) | |
107 ; (custom-face-lookup "white" nil nil nil nil nil)) | |
108 | |
109 ; (cons '(> score default) 'bold) | |
110 ; (cons '(< score default) 'italic))) | |
111 ; (t | |
112 ; (list (cons '(= mark gnus-canceled-mark) | |
113 ; (custom-face-lookup "yellow" "black" nil nil nil nil)) | |
114 ; (cons '(and (> score default) | |
115 ; (or (= mark gnus-dormant-mark) | |
116 ; (= mark gnus-ticked-mark))) | |
117 ; (custom-face-lookup "firebrick" nil nil t nil nil)) | |
118 ; (cons '(and (< score default) | |
119 ; (or (= mark gnus-dormant-mark) | |
120 ; (= mark gnus-ticked-mark))) | |
121 ; (custom-face-lookup "firebrick" nil nil nil t nil)) | |
122 ; (cons '(or (= mark gnus-dormant-mark) | |
123 ; (= mark gnus-ticked-mark)) | |
124 ; (custom-face-lookup "firebrick" nil nil nil nil nil)) | |
125 | |
126 ; (cons '(and (> score default) (= mark gnus-ancient-mark)) | |
127 ; (custom-face-lookup "RoyalBlue" nil nil t nil nil)) | |
128 ; (cons '(and (< score default) (= mark gnus-ancient-mark)) | |
129 ; (custom-face-lookup "RoyalBlue" nil nil nil t nil)) | |
130 ; (cons '(= mark gnus-ancient-mark) | |
131 ; (custom-face-lookup "RoyalBlue" nil nil nil nil nil)) | |
132 | |
133 ; (cons '(and (> score default) (/= mark gnus-unread-mark)) | |
134 ; (custom-face-lookup "DarkGreen" nil nil t nil nil)) | |
135 ; (cons '(and (< score default) (/= mark gnus-unread-mark)) | |
136 ; (custom-face-lookup "DarkGreen" nil nil nil t nil)) | |
137 ; (cons '(/= mark gnus-unread-mark) | |
138 ; (custom-face-lookup "DarkGreen" nil nil nil nil nil)) | |
139 | |
140 ; (cons '(> score default) 'bold) | |
141 ; (cons '(< score default) 'italic)))) | |
142 ; "*Alist of `(FORM . FACE)'. | |
143 ;Summary lines are highlighted with the FACE for the first FORM which | |
144 ;evaluate to a non-nil value. | |
145 | |
146 ;Point will be at the beginning of the line when FORM is evaluated. | |
147 ;The following can be used for convenience: | |
148 | |
149 ;score: (gnus-summary-article-score) | |
150 ;default: gnus-summary-default-score | |
151 ;below: gnus-summary-mark-below | |
152 ;mark: (gnus-summary-article-mark) | |
153 | |
154 ;The latter can be used like this: | |
155 ; ((= mark gnus-replied-mark) . underline)") | |
156 | |
157 ;;; article highlights | |
158 | |
159 ;see gnus-cus.el | |
160 ;(defvar gnus-header-face-alist | |
161 ; (cond ((not (eq gnus-display-type 'color)) | |
162 ; '(("" bold italic))) | |
163 ; ((eq gnus-background-mode 'dark) | |
164 ; (list (list "From" nil | |
165 ; (custom-face-lookup "SkyBlue" nil nil t t nil)) | |
166 ; (list "Subject" nil | |
167 ; (custom-face-lookup "pink" nil nil t t nil)) | |
168 ; (list "Newsgroups:.*," nil | |
169 ; (custom-face-lookup "yellow" nil nil t t nil)) | |
170 ; (list "" | |
171 ; (custom-face-lookup "cyan" nil nil t nil nil) | |
172 ; (custom-face-lookup "green" nil nil nil t nil)))) | |
173 ; (t | |
174 ; (list (list "From" nil | |
175 ; (custom-face-lookup "RoyalBlue" nil nil t t nil)) | |
176 ; (list "Subject" nil | |
177 ; (custom-face-lookup "firebrick" nil nil t t nil)) | |
178 ; (list "Newsgroups:.*," nil | |
179 ; (custom-face-lookup "red" nil nil t t nil)) | |
180 ; (list "" | |
181 ; (custom-face-lookup "DarkGreen" nil nil t nil nil) | |
182 ; (custom-face-lookup "DarkGreen" nil nil nil t nil))))) | |
183 ; "Alist of headers and faces used for highlighting them. | |
184 ;The entries in the list has the form `(REGEXP NAME CONTENT)', where | |
185 ;REGEXP is a regular expression matching the beginning of the header, | |
186 ;NAME is the face used for highlighting the header name and CONTENT is | |
187 ;the face used for highlighting the header content. | |
188 | |
189 ;The first non-nil NAME or CONTENT with a matching REGEXP in the list | |
190 ;will be used.") | |
191 | |
192 | |
193 ;see gnus-cus.el | |
194 ;(defvar gnus-make-foreground t | |
195 ; "Non nil means foreground color to highlight citations.") | |
196 | |
197 ;see gnus-cus.el | |
198 ;(defvar gnus-article-button-face 'bold | |
199 ; "Face used for text buttons.") | |
200 | |
201 ;see gnus-cus.el | |
202 ;(defvar gnus-article-mouse-face (if (boundp 'gnus-mouse-face) | |
203 ; gnus-mouse-face | |
204 ; 'highlight) | |
205 ; "Face used when the mouse is over the button.") | |
206 | |
207 ;see gnus-cus.el | |
208 ;(defvar gnus-signature-face 'italic | |
209 ; "Face used for signature.") | |
210 | |
15511 | 211 (defvar gnus-button-url-regexp "\\b\\(s?https?\\|ftp\\|file\\|gopher\\|news\\|telnet\\|wais\\|mailto\\):\\(//[-a-zA-Z0-9_.]+:[0-9]*\\)?[-\\wa-zA-Z0-9_=!?#$@~`%&*+|\\/.,]*[-\\wa-zA-Z0-9_=#$@~`%&*+|\\/]" |
212 "*Regular expression that matches URLs.") | |
213 | |
13401 | 214 (defvar gnus-button-alist |
15511 | 215 `(("\\bin\\( +article\\)? +\\(<\\([^\n @<>]+@[^\n @<>]+\\)>\\)" 2 |
216 t gnus-button-message-id 3) | |
217 ("\\(<?\\(url: ?\\)?news:\\([^>\n\t ]*\\)>?\\)" 1 t | |
13401 | 218 gnus-button-message-id 3) |
15511 | 219 ("\\(<URL: *\\)?mailto: *\\([^> \n\t]+\\)>?" 0 t gnus-button-reply 2) |
13401 | 220 ;; Next regexp stolen from highlight-headers.el. |
221 ;; Modified by Vladimir Alexiev. | |
16650
092790f767a4
(gnus-button-alist): Allow whitespace in `<URL:...'
Richard M. Stallman <rms@gnu.org>
parents:
15511
diff
changeset
|
222 (,gnus-button-url-regexp 0 t gnus-button-url 0) |
092790f767a4
(gnus-button-alist): Allow whitespace in `<URL:...'
Richard M. Stallman <rms@gnu.org>
parents:
15511
diff
changeset
|
223 ;; This is how URLs _should_ be embedded in text... It should go |
092790f767a4
(gnus-button-alist): Allow whitespace in `<URL:...'
Richard M. Stallman <rms@gnu.org>
parents:
15511
diff
changeset
|
224 ;; last to avoid matching only a subset of the URL, depending on |
092790f767a4
(gnus-button-alist): Allow whitespace in `<URL:...'
Richard M. Stallman <rms@gnu.org>
parents:
15511
diff
changeset
|
225 ;; how it was broken across lines. |
092790f767a4
(gnus-button-alist): Allow whitespace in `<URL:...'
Richard M. Stallman <rms@gnu.org>
parents:
15511
diff
changeset
|
226 ("<URL:\\([^>]+\\)>" 0 t gnus-button-url 1)) |
15511 | 227 "Alist of regexps matching buttons in article bodies. |
13401 | 228 |
229 Each entry has the form (REGEXP BUTTON FORM CALLBACK PAR...), where | |
230 REGEXP: is the string matching text around the button, | |
231 BUTTON: is the number of the regexp grouping actually matching the button, | |
232 FORM: is a lisp expression which must eval to true for the button to | |
233 be added, | |
234 CALLBACK: is the function to call when the user push this button, and each | |
235 PAR: is a number of a regexp grouping whose text will be passed to CALLBACK. | |
236 | |
237 CALLBACK can also be a variable, in that case the value of that | |
238 variable it the real callback function.") | |
239 | |
15511 | 240 (defvar gnus-header-button-alist |
241 `(("^\\(References\\|Message-I[Dd]\\):" "<[^>]+>" | |
242 0 t gnus-button-message-id 0) | |
243 ("^\\(From\\|Reply-To\\): " ": *\\(.+\\)$" 1 t gnus-button-reply 0) | |
244 ("^\\(Cc\\|To\\):" "[^ \t\n<>,()\"]+@[^ \t\n<>,()\"]+" | |
245 0 t gnus-button-mailto 0) | |
246 ("^X-[Uu][Rr][Ll]:" ,gnus-button-url-regexp 0 t gnus-button-url 0) | |
247 ("^[^:]+:" ,gnus-button-url-regexp 0 t gnus-button-url 0) | |
248 ("^[^:]+:" "\\(<\\(url: \\)?news:\\([^>\n ]*\\)>\\)" 1 t | |
249 gnus-button-message-id 3)) | |
250 "Alist of headers and regexps to match buttons in article heads. | |
251 | |
252 This alist is very similar to `gnus-button-alist', except that each | |
253 alist has an additional HEADER element first in each entry: | |
254 | |
255 \(HEADER REGEXP BUTTON FORM CALLBACK PAR) | |
256 | |
257 HEADER is a regexp to match a header. For a fuller explanation, see | |
258 `gnus-button-alist'.") | |
259 | |
13401 | 260 ;see gnus-cus.el |
261 ;(eval-when-compile | |
262 ; (defvar browse-url-browser-function)) | |
263 | |
15511 | 264 ;;; Group mode highlighting. |
265 | |
13401 | 266 ;see gnus-cus.el |
15511 | 267 ;(defvar gnus-group-highlight nil |
268 ; "Group lines are highlighted with the FACE for the first FORM which | |
269 ;evaluate to a non-nil value. | |
270 ; | |
271 ;Point will be at the beginning of the line when FORM is evaluated. | |
272 ;Variables bound when these forms are evaluated include: | |
273 ; | |
274 ;group: The group name. | |
275 ;unread: The number of unread articles. | |
276 ;method: The select method. | |
277 ;mailp: Whether the select method is a mail method. | |
278 ;level: The level of the group. | |
279 ;score: The score of the group. | |
280 ;ticked: The number of ticked articles in the group. | |
281 ;") | |
13401 | 282 |
15511 | 283 |
284 ;;; Internal variables. | |
285 | |
286 (defvar gnus-button-marker-list nil) | |
13401 | 287 |
288 | |
289 | |
290 (eval-and-compile | |
291 (autoload 'nnkiboze-generate-groups "nnkiboze") | |
292 (autoload 'gnus-cite-parse-maybe "gnus-cite" nil t)) | |
293 | |
294 ;;; | |
295 ;;; gnus-menu | |
296 ;;; | |
297 | |
298 (defun gnus-visual-turn-off-edit-menu (type) | |
299 (define-key (symbol-value (intern (format "gnus-%s-mode-map" type))) | |
300 [menu-bar edit] 'undefined)) | |
301 | |
302 ;; Newsgroup buffer | |
303 | |
304 (defun gnus-group-make-menu-bar () | |
305 (gnus-visual-turn-off-edit-menu 'group) | |
306 (or | |
307 (boundp 'gnus-group-reading-menu) | |
308 (progn | |
309 (easy-menu-define | |
15511 | 310 gnus-group-reading-menu gnus-group-mode-map "" |
13401 | 311 '("Group" |
15511 | 312 ["Read" gnus-group-read-group (gnus-group-group-name)] |
313 ["Select" gnus-group-select-group (gnus-group-group-name)] | |
314 ["See old articles" (gnus-group-select-group 'all) | |
315 :keys "C-u SPC" :active (gnus-group-group-name)] | |
316 ["Catch up" gnus-group-catchup-current (gnus-group-group-name)] | |
317 ["Catch up all articles" gnus-group-catchup-current-all | |
318 (gnus-group-group-name)] | |
319 ["Check for new articles" gnus-group-get-new-news-this-group | |
320 (gnus-group-group-name)] | |
321 ["Toggle subscription" gnus-group-unsubscribe-current-group | |
322 (gnus-group-group-name)] | |
323 ["Kill" gnus-group-kill-group (gnus-group-group-name)] | |
324 ["Yank" gnus-group-yank-group gnus-list-of-killed-groups] | |
325 ["Describe" gnus-group-describe-group (gnus-group-group-name)] | |
326 ["Fetch FAQ" gnus-group-fetch-faq (gnus-group-group-name)] | |
327 ["Edit kill file" gnus-group-edit-local-kill | |
328 (gnus-group-group-name)] | |
329 ;; Actually one should check, if any of the marked groups gives t for | |
330 ;; (gnus-check-backend-function 'request-expire-articles ...) | |
331 ["Expire articles" gnus-group-expire-articles | |
332 (or (and (gnus-group-group-name) | |
333 (gnus-check-backend-function | |
334 'request-expire-articles | |
335 (gnus-group-group-name))) gnus-group-marked)] | |
336 ["Set group level" gnus-group-set-current-level | |
337 (gnus-group-group-name)] | |
338 ["Select quick" gnus-group-quick-select-group (gnus-group-group-name)] | |
13401 | 339 )) |
340 | |
341 (easy-menu-define | |
15511 | 342 gnus-group-group-menu gnus-group-mode-map "" |
13401 | 343 '("Groups" |
344 ("Listing" | |
15511 | 345 ["List unread subscribed groups" gnus-group-list-groups t] |
346 ["List (un)subscribed groups" gnus-group-list-all-groups t] | |
347 ["List killed groups" gnus-group-list-killed gnus-killed-list] | |
348 ["List zombie groups" gnus-group-list-zombies gnus-zombie-list] | |
349 ["List level..." gnus-group-list-level t] | |
13401 | 350 ["Describe all groups" gnus-group-describe-all-groups t] |
15511 | 351 ["Group apropos..." gnus-group-apropos t] |
352 ["Group and description apropos..." gnus-group-description-apropos t] | |
353 ["List groups matching..." gnus-group-list-matching t] | |
354 ["List all groups matching..." gnus-group-list-all-matching t] | |
355 ["List active file" gnus-group-list-active t]) | |
356 ("Sort" | |
357 ["Default sort" gnus-group-sort-groups | |
358 (or (not (boundp 'gnus-topic-mode)) (not gnus-topic-mode))] | |
359 ["Sort by method" gnus-group-sort-groups-by-method | |
360 (or (not (boundp 'gnus-topic-mode)) (not gnus-topic-mode))] | |
361 ["Sort by rank" gnus-group-sort-groups-by-rank | |
362 (or (not (boundp 'gnus-topic-mode)) (not gnus-topic-mode))] | |
363 ["Sort by score" gnus-group-sort-groups-by-score | |
364 (or (not (boundp 'gnus-topic-mode)) (not gnus-topic-mode))] | |
365 ["Sort by level" gnus-group-sort-groups-by-level | |
366 (or (not (boundp 'gnus-topic-mode)) (not gnus-topic-mode))] | |
367 ["Sort by unread" gnus-group-sort-groups-by-unread | |
368 (or (not (boundp 'gnus-topic-mode)) (not gnus-topic-mode))] | |
369 ["Sort by name" gnus-group-sort-groups-by-alphabet | |
370 (or (not (boundp 'gnus-topic-mode)) (not gnus-topic-mode))]) | |
13401 | 371 ("Mark" |
15511 | 372 ["Mark group" gnus-group-mark-group |
373 (and (gnus-group-group-name) | |
374 (not (memq (gnus-group-group-name) gnus-group-marked)))] | |
375 ["Unmark group" gnus-group-unmark-group | |
376 (and (gnus-group-group-name) | |
377 (memq (gnus-group-group-name) gnus-group-marked))] | |
378 ["Unmark all" gnus-group-unmark-all-groups gnus-group-marked] | |
379 ["Mark regexp..." gnus-group-mark-regexp t] | |
380 ["Mark region" gnus-group-mark-region t] | |
381 ["Mark buffer" gnus-group-mark-buffer t] | |
382 ["Execute command" gnus-group-universal-argument | |
383 (or gnus-group-marked (gnus-group-group-name))]) | |
13401 | 384 ("Subscribe" |
385 ["Subscribe to random group" gnus-group-unsubscribe-group t] | |
386 ["Kill all newsgroups in region" gnus-group-kill-region t] | |
15511 | 387 ["Kill all zombie groups" gnus-group-kill-all-zombies |
388 gnus-zombie-list] | |
389 ["Kill all groups on level..." gnus-group-kill-level t]) | |
13401 | 390 ("Foreign groups" |
391 ["Make a foreign group" gnus-group-make-group t] | |
392 ["Add a directory group" gnus-group-make-directory-group t] | |
393 ["Add the help group" gnus-group-make-help-group t] | |
394 ["Add the archive group" gnus-group-make-archive-group t] | |
395 ["Make a doc group" gnus-group-make-doc-group t] | |
396 ["Make a kiboze group" gnus-group-make-kiboze-group t] | |
397 ["Make a virtual group" gnus-group-make-empty-virtual t] | |
15511 | 398 ["Add a group to a virtual" gnus-group-add-to-virtual t] |
399 ["Rename group" gnus-group-rename-group | |
400 (gnus-check-backend-function | |
401 'request-rename-group (gnus-group-group-name))] | |
402 ["Delete group" gnus-group-delete-group | |
403 (gnus-check-backend-function | |
404 'request-delete-group (gnus-group-group-name))]) | |
13401 | 405 ("Editing groups" |
15511 | 406 ["Parameters" gnus-group-edit-group-parameters |
407 (gnus-group-group-name)] | |
408 ["Select method" gnus-group-edit-group-method | |
409 (gnus-group-group-name)] | |
410 ["Info" gnus-group-edit-group (gnus-group-group-name)]) | |
411 ("Score file" | |
412 ["Flush cache" gnus-score-flush-cache | |
413 (or gnus-score-cache gnus-short-name-score-file-cache)]) | |
414 ("Move" | |
415 ["Next" gnus-group-next-group t] | |
416 ["Previous" gnus-group-prev-group t] | |
417 ["Next unread" gnus-group-next-unread-group t] | |
418 ["Previous unread" gnus-group-prev-unread-group t] | |
419 ["Next unread same level" gnus-group-next-unread-group-same-level t] | |
420 ["Previous unread same level" | |
421 gnus-group-previous-unread-group-same-level t] | |
422 ["Jump to group" gnus-group-jump-to-group t] | |
423 ["First unread group" gnus-group-first-unread-group t] | |
424 ["Best unread group" gnus-group-best-unread-group t]) | |
425 ["Transpose" gnus-group-transpose-groups | |
426 (gnus-group-group-name)] | |
427 ["Read a directory as a group..." gnus-group-enter-directory t] | |
13401 | 428 )) |
429 | |
430 (easy-menu-define | |
15511 | 431 gnus-group-misc-menu gnus-group-mode-map "" |
13401 | 432 '("Misc" |
433 ["Send a bug report" gnus-bug t] | |
434 ["Send a mail" gnus-group-mail t] | |
15511 | 435 ["Post an article..." gnus-group-post-news t] |
436 ["Customize score file" gnus-score-customize t] | |
13401 | 437 ["Check for new news" gnus-group-get-new-news t] |
15511 | 438 ["Activate all groups" gnus-activate-all-groups t] |
13401 | 439 ["Delete bogus groups" gnus-group-check-bogus-groups t] |
440 ["Find new newsgroups" gnus-find-new-newsgroups t] | |
441 ["Restart Gnus" gnus-group-restart t] | |
442 ["Read init file" gnus-group-read-init-file t] | |
443 ["Browse foreign server" gnus-group-browse-foreign-server t] | |
444 ["Enter server buffer" gnus-group-enter-server-mode t] | |
15511 | 445 ["Expire all expirable articles" gnus-group-expire-all-groups t] |
13401 | 446 ["Generate any kiboze groups" nnkiboze-generate-groups t] |
447 ["Gnus version" gnus-version t] | |
448 ["Save .newsrc files" gnus-group-save-newsrc t] | |
449 ["Suspend Gnus" gnus-group-suspend t] | |
450 ["Clear dribble buffer" gnus-group-clear-dribble t] | |
451 ["Exit from Gnus" gnus-group-exit t] | |
452 ["Exit without saving" gnus-group-quit t] | |
453 ["Edit global kill file" gnus-group-edit-global-kill t] | |
15511 | 454 ["Read manual" gnus-info-find-node t] |
455 ["Toggle topics" gnus-topic-mode t] | |
456 ("SOUP" | |
457 ["Pack replies" nnsoup-pack-replies (fboundp 'nnsoup-request-group)] | |
458 ["Send replies" gnus-soup-send-replies | |
459 (fboundp 'gnus-soup-pack-packet)] | |
460 ["Pack packet" gnus-soup-pack-packet (fboundp 'gnus-soup-pack-packet)] | |
461 ["Save areas" gnus-soup-save-areas (fboundp 'gnus-soup-pack-packet)] | |
462 ["Brew SOUP" gnus-soup-brew-soup (fboundp 'gnus-soup-pack-packet)]) | |
13401 | 463 )) |
464 (run-hooks 'gnus-group-menu-hook) | |
465 ))) | |
466 | |
467 ;; Summary buffer | |
468 (defun gnus-summary-make-menu-bar () | |
469 (gnus-visual-turn-off-edit-menu 'summary) | |
470 | |
15511 | 471 (unless (boundp 'gnus-summary-misc-menu) |
13401 | 472 |
15511 | 473 (easy-menu-define |
474 gnus-summary-misc-menu gnus-summary-mode-map "" | |
475 '("Misc" | |
476 ("Mark" | |
477 ("Read" | |
478 ["Mark as read" gnus-summary-mark-as-read-forward t] | |
479 ["Mark same subject and select" | |
480 gnus-summary-kill-same-subject-and-select t] | |
481 ["Mark same subject" gnus-summary-kill-same-subject t] | |
482 ["Catchup" gnus-summary-catchup t] | |
483 ["Catchup all" gnus-summary-catchup-all t] | |
484 ["Catchup to here" gnus-summary-catchup-to-here t] | |
485 ["Catchup region" gnus-summary-mark-region-as-read t] | |
486 ["Mark excluded" gnus-summary-limit-mark-excluded-as-read t]) | |
487 ("Various" | |
488 ["Tick" gnus-summary-tick-article-forward t] | |
489 ["Mark as dormant" gnus-summary-mark-as-dormant t] | |
490 ["Remove marks" gnus-summary-clear-mark-forward t] | |
491 ["Set expirable mark" gnus-summary-mark-as-expirable t] | |
492 ["Set bookmark" gnus-summary-set-bookmark t] | |
493 ["Remove bookmark" gnus-summary-remove-bookmark t]) | |
494 ("Limit" | |
495 ["Marks..." gnus-summary-limit-to-marks t] | |
496 ["Subject..." gnus-summary-limit-to-subject t] | |
497 ["Author..." gnus-summary-limit-to-author t] | |
498 ["Score" gnus-summary-limit-to-score t] | |
499 ["Unread" gnus-summary-limit-to-unread t] | |
500 ["Non-dormant" gnus-summary-limit-exclude-dormant t] | |
501 ["Articles" gnus-summary-limit-to-articles t] | |
502 ["Pop limit" gnus-summary-pop-limit t] | |
503 ["Show dormant" gnus-summary-limit-include-dormant t] | |
504 ["Hide childless dormant" | |
505 gnus-summary-limit-exclude-childless-dormant t] | |
506 ;;["Hide thread" gnus-summary-limit-exclude-thread t] | |
507 ["Show expunged" gnus-summary-show-all-expunged t]) | |
508 ("Process mark" | |
509 ["Set mark" gnus-summary-mark-as-processable t] | |
510 ["Remove mark" gnus-summary-unmark-as-processable t] | |
511 ["Remove all marks" gnus-summary-unmark-all-processable t] | |
512 ["Mark above" gnus-uu-mark-over t] | |
513 ["Mark series" gnus-uu-mark-series t] | |
514 ["Mark region" gnus-uu-mark-region t] | |
515 ["Mark by regexp..." gnus-uu-mark-by-regexp t] | |
516 ["Mark all" gnus-uu-mark-all t] | |
517 ["Mark buffer" gnus-uu-mark-buffer t] | |
518 ["Mark sparse" gnus-uu-mark-sparse t] | |
519 ["Mark thread" gnus-uu-mark-thread t] | |
520 ["Unmark thread" gnus-uu-unmark-thread t])) | |
521 ("Scroll article" | |
522 ["Page forward" gnus-summary-next-page t] | |
523 ["Page backward" gnus-summary-prev-page t] | |
524 ["Line forward" gnus-summary-scroll-up t]) | |
525 ("Move" | |
526 ["Next unread article" gnus-summary-next-unread-article t] | |
527 ["Previous unread article" gnus-summary-prev-unread-article t] | |
528 ["Next article" gnus-summary-next-article t] | |
529 ["Previous article" gnus-summary-prev-article t] | |
530 ["Next unread subject" gnus-summary-next-unread-subject t] | |
531 ["Previous unread subject" gnus-summary-prev-unread-subject t] | |
532 ["Next article same subject" gnus-summary-next-same-subject t] | |
533 ["Previous article same subject" gnus-summary-prev-same-subject t] | |
534 ["First unread article" gnus-summary-first-unread-article t] | |
535 ["Best unread article" gnus-summary-best-unread-article t] | |
536 ["Go to subject number..." gnus-summary-goto-subject t] | |
537 ["Go to article number..." gnus-summary-goto-article t] | |
538 ["Go to the last article" gnus-summary-goto-last-article t] | |
539 ["Pop article off history" gnus-summary-pop-article t]) | |
540 ("Sort" | |
541 ["Sort by number" gnus-summary-sort-by-number t] | |
542 ["Sort by author" gnus-summary-sort-by-author t] | |
543 ["Sort by subject" gnus-summary-sort-by-subject t] | |
544 ["Sort by date" gnus-summary-sort-by-date t] | |
545 ["Sort by score" gnus-summary-sort-by-score t]) | |
546 ("Exit" | |
547 ["Catchup and exit" gnus-summary-catchup-and-exit t] | |
548 ["Catchup all and exit" gnus-summary-catchup-and-exit t] | |
549 ["Catchup and goto next" gnus-summary-catchup-and-goto-next-group t] | |
550 ["Exit group" gnus-summary-exit t] | |
551 ["Exit group without updating" gnus-summary-exit-no-update t] | |
552 ["Exit and goto next group" gnus-summary-next-group t] | |
553 ["Exit and goto prev group" gnus-summary-prev-group t] | |
554 ["Reselect group" gnus-summary-reselect-current-group t] | |
555 ["Rescan group" gnus-summary-rescan-group t]) | |
556 ("Help" | |
13401 | 557 ["Fetch group FAQ" gnus-summary-fetch-faq t] |
558 ["Describe group" gnus-summary-describe-group t] | |
15511 | 559 ["Read manual" gnus-info-find-node t]) |
560 ("Cache" | |
561 ["Enter article" gnus-cache-enter-article t] | |
562 ["Remove article" gnus-cache-remove-article t]) | |
563 ("Modes" | |
564 ["Pick and read" gnus-pick-mode t] | |
565 ["Binary" gnus-binary-mode t]) | |
566 ["Filter articles..." gnus-summary-execute-command t] | |
567 ["Run command on subjects..." gnus-summary-universal-argument t] | |
568 ["Toggle line truncation" gnus-summary-toggle-truncation t] | |
569 ["Expand window" gnus-summary-expand-window t] | |
570 ["Expire expirable articles" gnus-summary-expire-articles | |
571 (gnus-check-backend-function | |
572 'request-expire-articles gnus-newsgroup-name)] | |
573 ["Edit local kill file" gnus-summary-edit-local-kill t] | |
574 ["Edit main kill file" gnus-summary-edit-global-kill t] | |
575 )) | |
13401 | 576 |
15511 | 577 (easy-menu-define |
578 gnus-summary-kill-menu gnus-summary-mode-map "" | |
579 (cons | |
580 "Score" | |
581 (nconc | |
582 (list | |
583 ["Enter score..." gnus-summary-score-entry t]) | |
584 (gnus-visual-score-map 'increase) | |
585 (gnus-visual-score-map 'lower) | |
586 '(("Mark" | |
587 ["Kill below" gnus-summary-kill-below t] | |
588 ["Mark above" gnus-summary-mark-above t] | |
589 ["Tick above" gnus-summary-tick-above t] | |
590 ["Clear above" gnus-summary-clear-above t]) | |
591 ["Current score" gnus-summary-current-score t] | |
592 ["Set score" gnus-summary-set-score t] | |
593 ["Customize score file" gnus-score-customize t] | |
594 ["Switch current score file..." gnus-score-change-score-file t] | |
595 ["Set mark below..." gnus-score-set-mark-below t] | |
596 ["Set expunge below..." gnus-score-set-expunge-below t] | |
597 ["Edit current score file" gnus-score-edit-current-scores t] | |
598 ["Edit score file" gnus-score-edit-file t] | |
599 ["Trace score" gnus-score-find-trace t] | |
600 ["Rescore buffer" gnus-summary-rescore t] | |
601 ["Increase score..." gnus-summary-increase-score t] | |
602 ["Lower score..." gnus-summary-lower-score t])))) | |
13401 | 603 |
15511 | 604 '(("Default header" |
605 ["Ask" (gnus-score-set-default 'gnus-score-default-header nil) | |
606 :style radio | |
607 :selected (null gnus-score-default-header)] | |
608 ["From" (gnus-score-set-default 'gnus-score-default-header 'a) | |
609 :style radio | |
610 :selected (eq gnus-score-default-header 'a)] | |
611 ["Subject" (gnus-score-set-default 'gnus-score-default-header 's) | |
612 :style radio | |
613 :selected (eq gnus-score-default-header 's)] | |
614 ["Article body" | |
615 (gnus-score-set-default 'gnus-score-default-header 'b) | |
616 :style radio | |
617 :selected (eq gnus-score-default-header 'b )] | |
618 ["All headers" | |
619 (gnus-score-set-default 'gnus-score-default-header 'h) | |
620 :style radio | |
621 :selected (eq gnus-score-default-header 'h )] | |
622 ["Message-Id" (gnus-score-set-default 'gnus-score-default-header 'i) | |
623 :style radio | |
624 :selected (eq gnus-score-default-header 'i )] | |
625 ["Thread" (gnus-score-set-default 'gnus-score-default-header 't) | |
626 :style radio | |
627 :selected (eq gnus-score-default-header 't )] | |
628 ["Crossposting" | |
629 (gnus-score-set-default 'gnus-score-default-header 'x) | |
630 :style radio | |
631 :selected (eq gnus-score-default-header 'x )] | |
632 ["Lines" (gnus-score-set-default 'gnus-score-default-header 'l) | |
633 :style radio | |
634 :selected (eq gnus-score-default-header 'l )] | |
635 ["Date" (gnus-score-set-default 'gnus-score-default-header 'd) | |
636 :style radio | |
637 :selected (eq gnus-score-default-header 'd )] | |
638 ["Followups to author" | |
639 (gnus-score-set-default 'gnus-score-default-header 'f) | |
640 :style radio | |
641 :selected (eq gnus-score-default-header 'f )]) | |
642 ("Default type" | |
643 ["Ask" (gnus-score-set-default 'gnus-score-default-type nil) | |
644 :style radio | |
645 :selected (null gnus-score-default-type)] | |
646 ;; The `:active' key is commented out in the following, | |
647 ;; because the GNU Emacs hack to support radio buttons use | |
648 ;; active to indicate which button is selected. | |
649 ["Substring" (gnus-score-set-default 'gnus-score-default-type 's) | |
650 :style radio | |
651 ;; :active (not (memq gnus-score-default-header '(l d))) | |
652 :selected (eq gnus-score-default-type 's)] | |
653 ["Regexp" (gnus-score-set-default 'gnus-score-default-type 'r) | |
654 :style radio | |
655 ;; :active (not (memq gnus-score-default-header '(l d))) | |
656 :selected (eq gnus-score-default-type 'r)] | |
657 ["Exact" (gnus-score-set-default 'gnus-score-default-type 'e) | |
658 :style radio | |
659 ;; :active (not (memq gnus-score-default-header '(l d))) | |
660 :selected (eq gnus-score-default-type 'e)] | |
661 ["Fuzzy" (gnus-score-set-default 'gnus-score-default-type 'f) | |
662 :style radio | |
663 ;; :active (not (memq gnus-score-default-header '(l d))) | |
664 :selected (eq gnus-score-default-type 'f)] | |
665 ["Before date" (gnus-score-set-default 'gnus-score-default-type 'b) | |
666 :style radio | |
667 ;; :active (eq (gnus-score-default-header 'd)) | |
668 :selected (eq gnus-score-default-type 'b)] | |
669 ["At date" (gnus-score-set-default 'gnus-score-default-type 'n) | |
670 :style radio | |
671 ;; :active (eq (gnus-score-default-header 'd)) | |
672 :selected (eq gnus-score-default-type 'n)] | |
673 ["After date" (gnus-score-set-default 'gnus-score-default-type 'a) | |
674 :style radio | |
675 ;; :active (eq (gnus-score-default-header 'd)) | |
676 :selected (eq gnus-score-default-type 'a)] | |
677 ["Less than number" | |
678 (gnus-score-set-default 'gnus-score-default-type '<) | |
679 :style radio | |
680 ;; :active (eq (gnus-score-default-header 'l)) | |
681 :selected (eq gnus-score-default-type '<)] | |
682 ["Equal to number" | |
683 (gnus-score-set-default 'gnus-score-default-type '=) | |
684 :style radio | |
685 ;; :active (eq (gnus-score-default-header 'l)) | |
686 :selected (eq gnus-score-default-type '=)] | |
687 ["Greater than number" | |
688 (gnus-score-set-default 'gnus-score-default-type '>) | |
689 :style radio | |
690 ;; :active (eq (gnus-score-default-header 'l)) | |
691 :selected (eq gnus-score-default-type '>)]) | |
692 ["Default fold" gnus-score-default-fold-toggle | |
693 :style toggle | |
694 :selected gnus-score-default-fold] | |
695 ("Default duration" | |
696 ["Ask" (gnus-score-set-default 'gnus-score-default-duration nil) | |
697 :style radio | |
698 :selected (null gnus-score-default-duration)] | |
699 ["Permanent" | |
700 (gnus-score-set-default 'gnus-score-default-duration 'p) | |
701 :style radio | |
702 :selected (eq gnus-score-default-duration 'p)] | |
703 ["Temporary" | |
704 (gnus-score-set-default 'gnus-score-default-duration 't) | |
705 :style radio | |
706 :selected (eq gnus-score-default-duration 't)] | |
707 ["Immediate" | |
708 (gnus-score-set-default 'gnus-score-default-duration 'i) | |
709 :style radio | |
710 :selected (eq gnus-score-default-duration 'i)])) | |
13401 | 711 |
15511 | 712 (easy-menu-define |
713 gnus-summary-article-menu gnus-summary-mode-map "" | |
714 '("Article" | |
715 ("Hide" | |
716 ["All" gnus-article-hide t] | |
717 ["Headers" gnus-article-hide-headers t] | |
718 ["Signature" gnus-article-hide-signature t] | |
719 ["Citation" gnus-article-hide-citation t] | |
720 ["PGP" gnus-article-hide-pgp t] | |
721 ["Boring headers" gnus-article-hide-boring-headers t]) | |
722 ("Highlight" | |
723 ["All" gnus-article-highlight t] | |
724 ["Headers" gnus-article-highlight-headers t] | |
725 ["Signature" gnus-article-highlight-signature t] | |
726 ["Citation" gnus-article-highlight-citation t]) | |
727 ("Date" | |
728 ["Local" gnus-article-date-local t] | |
729 ["UT" gnus-article-date-ut t] | |
730 ["Original" gnus-article-date-original t] | |
731 ["Lapsed" gnus-article-date-lapsed t]) | |
732 ("Filter" | |
733 ["Overstrike" gnus-article-treat-overstrike t] | |
734 ["Word wrap" gnus-article-fill-cited-article t] | |
735 ["CR" gnus-article-remove-cr t] | |
736 ["Trailing blank lines" gnus-article-remove-trailing-blank-lines t] | |
737 ["Show X-Face" gnus-article-display-x-face t] | |
738 ["Quoted-Printable" gnus-article-de-quoted-unreadable t] | |
739 ["Rot 13" gnus-summary-caesar-message t] | |
740 ["Add buttons" gnus-article-add-buttons t] | |
741 ["Add buttons to head" gnus-article-add-buttons-to-head t] | |
742 ["Stop page breaking" gnus-summary-stop-page-breaking t] | |
743 ["Toggle MIME" gnus-summary-toggle-mime t] | |
744 ["Verbose header" gnus-summary-verbose-headers t] | |
745 ["Toggle header" gnus-summary-toggle-header t]) | |
746 ("Output" | |
747 ["Save in default format" gnus-summary-save-article t] | |
748 ["Save in file" gnus-summary-save-article-file t] | |
749 ["Save in Unix mail format" gnus-summary-save-article-mail t] | |
750 ["Save in MH folder" gnus-summary-save-article-folder t] | |
751 ["Save in VM folder" gnus-summary-save-article-vm t] | |
752 ["Save in RMAIL mbox" gnus-summary-save-article-rmail t] | |
753 ["Save body in file" gnus-summary-save-article-body-file t] | |
754 ["Pipe through a filter" gnus-summary-pipe-output t] | |
755 ["Add to SOUP packet" gnus-soup-add-article t]) | |
756 ("Backend" | |
757 ["Respool article..." gnus-summary-respool-article t] | |
758 ["Move article..." gnus-summary-move-article | |
759 (gnus-check-backend-function | |
760 'request-move-article gnus-newsgroup-name)] | |
761 ["Copy article..." gnus-summary-copy-article t] | |
762 ["Crosspost article..." gnus-summary-crosspost-article | |
763 (gnus-check-backend-function | |
764 'request-replace-article gnus-newsgroup-name)] | |
765 ["Import file..." gnus-summary-import-article t] | |
766 ["Edit article" gnus-summary-edit-article | |
767 (not (gnus-group-read-only-p))] | |
768 ["Delete article" gnus-summary-delete-article | |
769 (gnus-check-backend-function | |
770 'request-expire-articles gnus-newsgroup-name)] | |
771 ["Query respool" gnus-summary-respool-query t] | |
772 ["Delete expirable articles" gnus-summary-expire-articles-now | |
773 (gnus-check-backend-function | |
774 'request-expire-articles gnus-newsgroup-name)]) | |
775 ("Extract" | |
776 ["Uudecode" gnus-uu-decode-uu t] | |
777 ["Uudecode and save" gnus-uu-decode-uu-and-save t] | |
778 ["Unshar" gnus-uu-decode-unshar t] | |
779 ["Unshar and save" gnus-uu-decode-unshar-and-save t] | |
780 ["Save" gnus-uu-decode-save t] | |
781 ["Binhex" gnus-uu-decode-binhex t] | |
782 ["Postscript" gnus-uu-decode-postscript t]) | |
783 ["Enter digest buffer" gnus-summary-enter-digest-group t] | |
784 ["Isearch article..." gnus-summary-isearch-article t] | |
785 ["Search articles forward..." gnus-summary-search-article-forward t] | |
786 ["Search articles backward..." gnus-summary-search-article-backward t] | |
787 ["Beginning of the article" gnus-summary-beginning-of-article t] | |
788 ["End of the article" gnus-summary-end-of-article t] | |
789 ["Fetch parent of article" gnus-summary-refer-parent-article t] | |
790 ["Fetch referenced articles" gnus-summary-refer-references t] | |
791 ["Fetch article with id..." gnus-summary-refer-article t] | |
792 ["Redisplay" gnus-summary-show-article t])) | |
13401 | 793 |
15511 | 794 (easy-menu-define |
795 gnus-summary-thread-menu gnus-summary-mode-map "" | |
796 '("Threads" | |
797 ["Toggle threading" gnus-summary-toggle-threads t] | |
798 ["Hide threads" gnus-summary-hide-all-threads t] | |
799 ["Show threads" gnus-summary-show-all-threads t] | |
800 ["Hide thread" gnus-summary-hide-thread t] | |
801 ["Show thread" gnus-summary-show-thread t] | |
802 ["Go to next thread" gnus-summary-next-thread t] | |
803 ["Go to previous thread" gnus-summary-prev-thread t] | |
804 ["Go down thread" gnus-summary-down-thread t] | |
805 ["Go up thread" gnus-summary-up-thread t] | |
806 ["Top of thread" gnus-summary-top-thread t] | |
807 ["Mark thread as read" gnus-summary-kill-thread t] | |
808 ["Lower thread score" gnus-summary-lower-thread t] | |
809 ["Raise thread score" gnus-summary-raise-thread t] | |
810 ["Rethread current" gnus-summary-rethread-current t] | |
811 )) | |
13401 | 812 |
15511 | 813 (easy-menu-define |
814 gnus-summary-post-menu gnus-summary-mode-map "" | |
815 '("Post" | |
816 ["Post an article" gnus-summary-post-news t] | |
817 ["Followup" gnus-summary-followup t] | |
818 ["Followup and yank" gnus-summary-followup-with-original t] | |
819 ["Supersede article" gnus-summary-supersede-article t] | |
820 ["Cancel article" gnus-summary-cancel-article t] | |
821 ["Reply" gnus-summary-reply t] | |
822 ["Reply and yank" gnus-summary-reply-with-original t] | |
823 ["Mail forward" gnus-summary-mail-forward t] | |
824 ["Post forward" gnus-summary-post-forward t] | |
825 ["Digest and mail" gnus-uu-digest-mail-forward t] | |
826 ["Digest and post" gnus-uu-digest-post-forward t] | |
827 ["Resend message" gnus-summary-resend-message t] | |
828 ["Send bounced mail" gnus-summary-resend-bounced-mail t] | |
829 ["Send a mail" gnus-summary-mail-other-window t] | |
830 ["Uuencode and post" gnus-uu-post-news t] | |
831 ;;("Draft" | |
832 ;;["Send" gnus-summary-send-draft t] | |
833 ;;["Send bounced" gnus-resend-bounced-mail t]) | |
834 )) | |
835 (run-hooks 'gnus-summary-menu-hook) | |
836 )) | |
13401 | 837 |
838 (defun gnus-score-set-default (var value) | |
15511 | 839 "A version of set that updates the GNU Emacs menu-bar." |
13401 | 840 (set var value) |
841 ;; It is the message that forces the active status to be updated. | |
842 (message "")) | |
843 | |
844 (defun gnus-visual-score-map (type) | |
845 (if t | |
846 nil | |
847 (let ((headers '(("author" "from" string) | |
848 ("subject" "subject" string) | |
849 ("article body" "body" string) | |
850 ("article head" "head" string) | |
851 ("xref" "xref" string) | |
852 ("lines" "lines" number) | |
853 ("followups to author" "followup" string))) | |
854 (types '((number ("less than" <) | |
855 ("greater than" >) | |
856 ("equal" =)) | |
857 (string ("substring" s) | |
858 ("exact string" e) | |
859 ("fuzzy string" f) | |
860 ("regexp" r)))) | |
861 (perms '(("temporary" (current-time-string)) | |
862 ("permanent" nil) | |
863 ("immediate" now))) | |
864 header) | |
865 (list | |
866 (apply | |
867 'nconc | |
868 (list | |
869 (if (eq type 'lower) | |
870 "Lower score" | |
871 "Increase score")) | |
872 (let (outh) | |
873 (while headers | |
874 (setq header (car headers)) | |
875 (setq outh | |
876 (cons | |
877 (apply | |
878 'nconc | |
879 (list (car header)) | |
880 (let ((ts (cdr (assoc (nth 2 header) types))) | |
881 outt) | |
882 (while ts | |
883 (setq outt | |
884 (cons | |
885 (apply | |
886 'nconc | |
15511 | 887 (list (caar ts)) |
13401 | 888 (let ((ps perms) |
889 outp) | |
890 (while ps | |
891 (setq outp | |
892 (cons | |
893 (vector | |
15511 | 894 (caar ps) |
13401 | 895 (list |
896 'gnus-summary-score-entry | |
897 (nth 1 header) | |
898 (if (or (string= (nth 1 header) | |
899 "head") | |
900 (string= (nth 1 header) | |
901 "body")) | |
902 "" | |
903 (list 'gnus-summary-header | |
904 (nth 1 header))) | |
905 (list 'quote (nth 1 (car ts))) | |
906 (list 'gnus-score-default nil) | |
907 (nth 1 (car ps)) | |
908 t) | |
909 t) | |
910 outp)) | |
911 (setq ps (cdr ps))) | |
912 (list (nreverse outp)))) | |
913 outt)) | |
914 (setq ts (cdr ts))) | |
915 (list (nreverse outt)))) | |
916 outh)) | |
917 (setq headers (cdr headers))) | |
918 (list (nreverse outh)))))))) | |
919 | |
920 ;; Article buffer | |
921 (defun gnus-article-make-menu-bar () | |
922 (gnus-visual-turn-off-edit-menu 'summary) | |
923 (or | |
924 (boundp 'gnus-article-article-menu) | |
925 (progn | |
926 (easy-menu-define | |
15511 | 927 gnus-article-article-menu gnus-article-mode-map "" |
13401 | 928 '("Article" |
15511 | 929 ["Scroll forwards" gnus-article-goto-next-page t] |
930 ["Scroll backwards" gnus-article-goto-prev-page t] | |
13401 | 931 ["Show summary" gnus-article-show-summary t] |
932 ["Fetch Message-ID at point" gnus-article-refer-article t] | |
933 ["Mail to address at point" gnus-article-mail t] | |
934 )) | |
935 | |
936 (easy-menu-define | |
15511 | 937 gnus-article-treatment-menu gnus-article-mode-map "" |
13401 | 938 '("Treatment" |
939 ["Hide headers" gnus-article-hide-headers t] | |
940 ["Hide signature" gnus-article-hide-signature t] | |
941 ["Hide citation" gnus-article-hide-citation t] | |
942 ["Treat overstrike" gnus-article-treat-overstrike t] | |
943 ["Remove carriage return" gnus-article-remove-cr t] | |
944 ["Remove quoted-unreadable" gnus-article-de-quoted-unreadable t] | |
945 )) | |
15511 | 946 (run-hooks 'gnus-article-menu-hook)))) |
13401 | 947 |
948 ;;; | |
949 ;;; summary highlights | |
950 ;;; | |
951 | |
952 (defun gnus-highlight-selected-summary () | |
953 ;; Added by Per Abrahamsen <amanda@iesd.auc.dk>. | |
954 ;; Highlight selected article in summary buffer | |
955 (if gnus-summary-selected-face | |
956 (save-excursion | |
957 (let* ((beg (progn (beginning-of-line) (point))) | |
958 (end (progn (end-of-line) (point))) | |
959 ;; Fix by Mike Dugan <dugan@bucrf16.bu.edu>. | |
15511 | 960 (from (if (get-text-property beg gnus-mouse-face-prop) |
13401 | 961 beg |
962 (1+ (or (next-single-property-change | |
15511 | 963 beg gnus-mouse-face-prop nil end) |
13401 | 964 beg)))) |
965 (to (1- (or (next-single-property-change | |
15511 | 966 from gnus-mouse-face-prop nil end) |
13401 | 967 end)))) |
968 ;; If no mouse-face prop on line (e.g. xemacs) we | |
969 ;; will have to = from = end, so we highlight the | |
970 ;; entire line instead. | |
971 (if (= (+ to 2) from) | |
972 (progn | |
973 (setq from beg) | |
974 (setq to end))) | |
975 (if gnus-newsgroup-selected-overlay | |
976 (gnus-move-overlay gnus-newsgroup-selected-overlay | |
977 from to (current-buffer)) | |
978 (setq gnus-newsgroup-selected-overlay (gnus-make-overlay from to)) | |
979 (gnus-overlay-put gnus-newsgroup-selected-overlay 'face | |
980 gnus-summary-selected-face)))))) | |
981 | |
982 ;; New implementation by Christian Limpach <Christian.Limpach@nice.ch>. | |
983 (defun gnus-summary-highlight-line () | |
984 "Highlight current line according to `gnus-summary-highlight'." | |
985 (let* ((list gnus-summary-highlight) | |
986 (p (point)) | |
987 (end (progn (end-of-line) (point))) | |
988 ;; now find out where the line starts and leave point there. | |
989 (beg (progn (beginning-of-line) (point))) | |
15511 | 990 (article (gnus-summary-article-number)) |
991 (score (or (cdr (assq (or article gnus-current-article) | |
13401 | 992 gnus-newsgroup-scored)) |
993 gnus-summary-default-score 0)) | |
15511 | 994 (mark (or (gnus-summary-article-mark) gnus-unread-mark)) |
13401 | 995 (inhibit-read-only t)) |
15511 | 996 ;; Eval the cars of the lists until we find a match. |
997 (let ((default gnus-summary-default-score)) | |
998 (while (and list | |
999 (not (eval (caar list)))) | |
1000 (setq list (cdr list)))) | |
1001 (let ((face (cdar list))) | |
1002 (unless (eq face (get-text-property beg 'face)) | |
1003 (gnus-put-text-property | |
1004 beg end 'face | |
1005 (setq face (if (boundp face) (symbol-value face) face))) | |
1006 (when gnus-summary-highlight-line-function | |
1007 (funcall gnus-summary-highlight-line-function article face)))) | |
1008 (goto-char p))) | |
1009 | |
1010 (defun gnus-group-highlight-line () | |
1011 "Highlight the current line according to `gnus-group-highlight'." | |
1012 (let* ((list gnus-group-highlight) | |
1013 (p (point)) | |
1014 (end (progn (end-of-line) (point))) | |
1015 ;; now find out where the line starts and leave point there. | |
1016 (beg (progn (beginning-of-line) (point))) | |
1017 (group (gnus-group-group-name)) | |
1018 (entry (gnus-group-entry group)) | |
1019 (unread (if (numberp (car entry)) (car entry) 0)) | |
1020 (info (nth 2 entry)) | |
1021 (method (gnus-server-get-method group (gnus-info-method info))) | |
1022 (marked (gnus-info-marks info)) | |
1023 (mailp (memq 'mail (assoc (symbol-name | |
1024 (car (or method gnus-select-method))) | |
1025 gnus-valid-select-methods))) | |
1026 (level (or (gnus-info-level info) 9)) | |
1027 (score (or (gnus-info-score info) 0)) | |
1028 (ticked (gnus-range-length (cdr (assq 'tick marked)))) | |
1029 (inhibit-read-only t)) | |
1030 ;; Eval the cars of the lists until we find a match. | |
1031 (while (and list | |
1032 (not (eval (caar list)))) | |
13401 | 1033 (setq list (cdr list))) |
15511 | 1034 (let ((face (cdar list))) |
1035 (unless (eq face (get-text-property beg 'face)) | |
1036 (gnus-put-text-property | |
1037 beg end 'face | |
1038 (setq face (if (boundp face) (symbol-value face) face))) | |
1039 (gnus-extent-start-open beg))) | |
13401 | 1040 (goto-char p))) |
1041 | |
1042 ;;; | |
1043 ;;; gnus-carpal | |
1044 ;;; | |
1045 | |
1046 (defvar gnus-carpal-group-buffer-buttons | |
1047 '(("next" . gnus-group-next-unread-group) | |
1048 ("prev" . gnus-group-prev-unread-group) | |
1049 ("read" . gnus-group-read-group) | |
1050 ("select" . gnus-group-select-group) | |
1051 ("catch-up" . gnus-group-catchup-current) | |
1052 ("new-news" . gnus-group-get-new-news-this-group) | |
1053 ("toggle-sub" . gnus-group-unsubscribe-current-group) | |
1054 ("subscribe" . gnus-group-unsubscribe-group) | |
1055 ("kill" . gnus-group-kill-group) | |
1056 ("yank" . gnus-group-yank-group) | |
1057 ("describe" . gnus-group-describe-group) | |
1058 "list" | |
1059 ("subscribed" . gnus-group-list-groups) | |
1060 ("all" . gnus-group-list-all-groups) | |
1061 ("killed" . gnus-group-list-killed) | |
1062 ("zombies" . gnus-group-list-zombies) | |
1063 ("matching" . gnus-group-list-matching) | |
1064 ("post" . gnus-group-post-news) | |
1065 ("mail" . gnus-group-mail) | |
1066 ("rescan" . gnus-group-get-new-news) | |
1067 ("browse-foreign" . gnus-group-browse-foreign) | |
1068 ("exit" . gnus-group-exit))) | |
1069 | |
1070 (defvar gnus-carpal-summary-buffer-buttons | |
1071 '("mark" | |
1072 ("read" . gnus-summary-mark-as-read-forward) | |
1073 ("tick" . gnus-summary-tick-article-forward) | |
1074 ("clear" . gnus-summary-clear-mark-forward) | |
1075 ("expirable" . gnus-summary-mark-as-expirable) | |
1076 "move" | |
1077 ("scroll" . gnus-summary-next-page) | |
1078 ("next-unread" . gnus-summary-next-unread-article) | |
1079 ("prev-unread" . gnus-summary-prev-unread-article) | |
1080 ("first" . gnus-summary-first-unread-article) | |
1081 ("best" . gnus-summary-best-unread-article) | |
1082 "article" | |
1083 ("headers" . gnus-summary-toggle-header) | |
1084 ("uudecode" . gnus-uu-decode-uu) | |
1085 ("enter-digest" . gnus-summary-enter-digest-group) | |
1086 ("fetch-parent" . gnus-summary-refer-parent-article) | |
1087 "mail" | |
1088 ("move" . gnus-summary-move-article) | |
1089 ("copy" . gnus-summary-copy-article) | |
1090 ("respool" . gnus-summary-respool-article) | |
1091 "threads" | |
1092 ("lower" . gnus-summary-lower-thread) | |
1093 ("kill" . gnus-summary-kill-thread) | |
1094 "post" | |
1095 ("post" . gnus-summary-post-news) | |
1096 ("mail" . gnus-summary-mail) | |
1097 ("followup" . gnus-summary-followup-with-original) | |
1098 ("reply" . gnus-summary-reply-with-original) | |
1099 ("cancel" . gnus-summary-cancel-article) | |
1100 "misc" | |
1101 ("exit" . gnus-summary-exit) | |
1102 ("fed-up" . gnus-summary-catchup-and-goto-next-group))) | |
1103 | |
1104 (defvar gnus-carpal-server-buffer-buttons | |
1105 '(("add" . gnus-server-add-server) | |
1106 ("browse" . gnus-server-browse-server) | |
1107 ("list" . gnus-server-list-servers) | |
1108 ("kill" . gnus-server-kill-server) | |
1109 ("yank" . gnus-server-yank-server) | |
1110 ("copy" . gnus-server-copy-server) | |
1111 ("exit" . gnus-server-exit))) | |
1112 | |
1113 (defvar gnus-carpal-browse-buffer-buttons | |
1114 '(("subscribe" . gnus-browse-unsubscribe-current-group) | |
1115 ("exit" . gnus-browse-exit))) | |
1116 | |
1117 (defvar gnus-carpal-group-buffer "*Carpal Group*") | |
1118 (defvar gnus-carpal-summary-buffer "*Carpal Summary*") | |
1119 (defvar gnus-carpal-server-buffer "*Carpal Server*") | |
1120 (defvar gnus-carpal-browse-buffer "*Carpal Browse*") | |
1121 | |
1122 (defvar gnus-carpal-attached-buffer nil) | |
1123 | |
1124 (defvar gnus-carpal-mode-hook nil | |
1125 "*Hook run in carpal mode buffers.") | |
1126 | |
1127 (defvar gnus-carpal-button-face 'bold | |
1128 "*Face used on carpal buttons.") | |
1129 | |
1130 (defvar gnus-carpal-header-face 'bold-italic | |
1131 "*Face used on carpal buffer headers.") | |
1132 | |
1133 (defvar gnus-carpal-mode-map nil) | |
1134 (put 'gnus-carpal-mode 'mode-class 'special) | |
1135 | |
1136 (if gnus-carpal-mode-map | |
1137 nil | |
1138 (setq gnus-carpal-mode-map (make-keymap)) | |
1139 (suppress-keymap gnus-carpal-mode-map) | |
1140 (define-key gnus-carpal-mode-map " " 'gnus-carpal-select) | |
1141 (define-key gnus-carpal-mode-map "\r" 'gnus-carpal-select) | |
1142 (define-key gnus-carpal-mode-map gnus-mouse-2 'gnus-carpal-mouse-select)) | |
1143 | |
1144 (defun gnus-carpal-mode () | |
1145 "Major mode for clicking buttons. | |
1146 | |
1147 All normal editing commands are switched off. | |
1148 \\<gnus-carpal-mode-map> | |
1149 The following commands are available: | |
1150 | |
1151 \\{gnus-carpal-mode-map}" | |
1152 (interactive) | |
1153 (kill-all-local-variables) | |
1154 (setq mode-line-modified "-- ") | |
1155 (setq major-mode 'gnus-carpal-mode) | |
1156 (setq mode-name "Gnus Carpal") | |
1157 (setq mode-line-process nil) | |
1158 (use-local-map gnus-carpal-mode-map) | |
1159 (buffer-disable-undo (current-buffer)) | |
1160 (setq buffer-read-only t) | |
1161 (make-local-variable 'gnus-carpal-attached-buffer) | |
1162 (run-hooks 'gnus-carpal-mode-hook)) | |
1163 | |
1164 (defun gnus-carpal-setup-buffer (type) | |
1165 (let ((buffer (symbol-value (intern (format "gnus-carpal-%s-buffer" type))))) | |
1166 (if (get-buffer buffer) | |
1167 () | |
1168 (save-excursion | |
1169 (set-buffer (get-buffer-create buffer)) | |
1170 (gnus-carpal-mode) | |
1171 (setq gnus-carpal-attached-buffer | |
1172 (intern (format "gnus-%s-buffer" type))) | |
1173 (gnus-add-current-to-buffer-list) | |
1174 (let ((buttons (symbol-value | |
1175 (intern (format "gnus-carpal-%s-buffer-buttons" | |
1176 type)))) | |
1177 (buffer-read-only nil) | |
1178 button) | |
1179 (while buttons | |
1180 (setq button (car buttons) | |
1181 buttons (cdr buttons)) | |
1182 (if (stringp button) | |
15511 | 1183 (gnus-set-text-properties |
13401 | 1184 (point) |
1185 (prog2 (insert button) (point) (insert " ")) | |
1186 (list 'face gnus-carpal-header-face)) | |
15511 | 1187 (gnus-set-text-properties |
13401 | 1188 (point) |
1189 (prog2 (insert (car button)) (point) (insert " ")) | |
1190 (list 'gnus-callback (cdr button) | |
1191 'face gnus-carpal-button-face | |
15511 | 1192 gnus-mouse-face-prop 'highlight)))) |
13401 | 1193 (let ((fill-column (- (window-width) 2))) |
1194 (fill-region (point-min) (point-max))) | |
1195 (set-window-point (get-buffer-window (current-buffer)) | |
1196 (point-min))))))) | |
1197 | |
1198 (defun gnus-carpal-select () | |
1199 "Select the button under point." | |
1200 (interactive) | |
1201 (let ((func (get-text-property (point) 'gnus-callback))) | |
1202 (if (null func) | |
1203 () | |
1204 (pop-to-buffer (symbol-value gnus-carpal-attached-buffer)) | |
1205 (call-interactively func)))) | |
1206 | |
1207 (defun gnus-carpal-mouse-select (event) | |
1208 "Select the button under the mouse pointer." | |
1209 (interactive "e") | |
1210 (mouse-set-point event) | |
1211 (gnus-carpal-select)) | |
1212 | |
1213 ;;; | |
1214 ;;; article highlights | |
1215 ;;; | |
1216 | |
1217 ;; Written by Per Abrahamsen <abraham@iesd.auc.dk>. | |
1218 | |
1219 ;;; Internal Variables: | |
1220 | |
1221 (defvar gnus-button-regexp nil) | |
1222 ;; Regexp matching any of the regexps from `gnus-button-alist'. | |
1223 | |
1224 (defvar gnus-button-last nil) | |
1225 ;; The value of `gnus-button-alist' when `gnus-button-regexp' was build. | |
1226 | |
1227 ;;; Commands: | |
1228 | |
1229 (defun gnus-article-push-button (event) | |
1230 "Check text under the mouse pointer for a callback function. | |
1231 If the text under the mouse pointer has a `gnus-callback' property, | |
1232 call it with the value of the `gnus-data' text property." | |
1233 (interactive "e") | |
1234 (set-buffer (window-buffer (posn-window (event-start event)))) | |
1235 (let* ((pos (posn-point (event-start event))) | |
1236 (data (get-text-property pos 'gnus-data)) | |
1237 (fun (get-text-property pos 'gnus-callback))) | |
1238 (if fun (funcall fun data)))) | |
1239 | |
1240 (defun gnus-article-press-button () | |
1241 "Check text at point for a callback function. | |
1242 If the text at point has a `gnus-callback' property, | |
1243 call it with the value of the `gnus-data' text property." | |
1244 (interactive) | |
1245 (let* ((data (get-text-property (point) 'gnus-data)) | |
1246 (fun (get-text-property (point) 'gnus-callback))) | |
1247 (if fun (funcall fun data)))) | |
1248 | |
15511 | 1249 (defun gnus-article-prev-button (n) |
1250 "Move point to N buttons backward. | |
1251 If N is negative, move forward instead." | |
1252 (interactive "p") | |
1253 (gnus-article-next-button (- n))) | |
1254 | |
1255 (defun gnus-article-next-button (n) | |
1256 "Move point to N buttons forward. | |
1257 If N is negative, move backward instead." | |
1258 (interactive "p") | |
1259 (let ((function (if (< n 0) 'previous-single-property-change | |
1260 'next-single-property-change)) | |
1261 (inhibit-point-motion-hooks t) | |
1262 (backward (< n 0)) | |
1263 (limit (if (< n 0) (point-min) (point-max)))) | |
1264 (setq n (abs n)) | |
1265 (while (and (not (= limit (point))) | |
1266 (> n 0)) | |
1267 ;; Skip past the current button. | |
1268 (when (get-text-property (point) 'gnus-callback) | |
1269 (goto-char (funcall function (point) 'gnus-callback nil limit))) | |
1270 ;; Go to the next (or previous) button. | |
1271 (gnus-goto-char (funcall function (point) 'gnus-callback nil limit)) | |
1272 ;; Put point at the start of the button. | |
1273 (when (and backward (not (get-text-property (point) 'gnus-callback))) | |
1274 (goto-char (funcall function (point) 'gnus-callback nil limit))) | |
1275 ;; Skip past intangible buttons. | |
1276 (when (get-text-property (point) 'intangible) | |
1277 (incf n)) | |
1278 (decf n)) | |
1279 (unless (zerop n) | |
1280 (gnus-message 5 "No more buttons")) | |
1281 n)) | |
13401 | 1282 |
1283 (defun gnus-article-highlight (&optional force) | |
1284 "Highlight current article. | |
1285 This function calls `gnus-article-highlight-headers', | |
1286 `gnus-article-highlight-citation', | |
1287 `gnus-article-highlight-signature', and `gnus-article-add-buttons' to | |
1288 do the highlighting. See the documentation for those functions." | |
1289 (interactive (list 'force)) | |
1290 (gnus-article-highlight-headers) | |
1291 (gnus-article-highlight-citation force) | |
1292 (gnus-article-highlight-signature) | |
15511 | 1293 (gnus-article-add-buttons force) |
1294 (gnus-article-add-buttons-to-head)) | |
13401 | 1295 |
1296 (defun gnus-article-highlight-some (&optional force) | |
1297 "Highlight current article. | |
1298 This function calls `gnus-article-highlight-headers', | |
1299 `gnus-article-highlight-signature', and `gnus-article-add-buttons' to | |
1300 do the highlighting. See the documentation for those functions." | |
1301 (interactive (list 'force)) | |
1302 (gnus-article-highlight-headers) | |
1303 (gnus-article-highlight-signature) | |
1304 (gnus-article-add-buttons)) | |
1305 | |
1306 (defun gnus-article-highlight-headers () | |
1307 "Highlight article headers as specified by `gnus-header-face-alist'." | |
1308 (interactive) | |
1309 (save-excursion | |
1310 (set-buffer gnus-article-buffer) | |
15511 | 1311 (save-restriction |
1312 (let ((alist gnus-header-face-alist) | |
1313 (buffer-read-only nil) | |
1314 (case-fold-search t) | |
1315 (inhibit-point-motion-hooks t) | |
1316 entry regexp header-face field-face from hpoints fpoints) | |
1317 (goto-char (point-min)) | |
1318 (when (search-forward "\n\n" nil t) | |
1319 (narrow-to-region (1- (point)) (point-min)) | |
1320 (while (setq entry (pop alist)) | |
1321 (goto-char (point-min)) | |
1322 (setq regexp (concat "^\\(" | |
1323 (if (string-equal "" (nth 0 entry)) | |
1324 "[^\t ]" | |
1325 (nth 0 entry)) | |
1326 "\\)") | |
13401 | 1327 header-face (nth 1 entry) |
15511 | 1328 field-face (nth 2 entry)) |
1329 (while (and (re-search-forward regexp nil t) | |
1330 (not (eobp))) | |
1331 (beginning-of-line) | |
1332 (setq from (point)) | |
1333 (or (search-forward ":" nil t) | |
1334 (forward-char 1)) | |
1335 (when (and header-face | |
1336 (not (memq (point) hpoints))) | |
1337 (push (point) hpoints) | |
1338 (gnus-put-text-property from (point) 'face header-face)) | |
1339 (when (and field-face | |
1340 (not (memq (setq from (point)) fpoints))) | |
1341 (push from fpoints) | |
1342 (if (re-search-forward "^[^ \t]" nil t) | |
1343 (forward-char -2) | |
1344 (goto-char (point-max))) | |
1345 (gnus-put-text-property from (point) 'face field-face))))))))) | |
13401 | 1346 |
1347 (defun gnus-article-highlight-signature () | |
1348 "Highlight the signature in an article. | |
1349 It does this by highlighting everything after | |
1350 `gnus-signature-separator' using `gnus-signature-face'." | |
1351 (interactive) | |
1352 (save-excursion | |
1353 (set-buffer gnus-article-buffer) | |
1354 (let ((buffer-read-only nil) | |
1355 (inhibit-point-motion-hooks t)) | |
15511 | 1356 (save-restriction |
1357 (when (and gnus-signature-face | |
1358 (gnus-narrow-to-signature)) | |
1359 (gnus-overlay-put (gnus-make-overlay (point-min) (point-max)) | |
1360 'face gnus-signature-face) | |
1361 (widen) | |
1362 (re-search-backward gnus-signature-separator nil t) | |
1363 (let ((start (match-beginning 0)) | |
1364 (end (set-marker (make-marker) (1+ (match-end 0))))) | |
1365 (gnus-article-add-button start (1- end) 'gnus-signature-toggle | |
1366 end))))))) | |
13401 | 1367 |
15511 | 1368 (defun gnus-article-add-buttons (&optional force) |
1369 "Find external references in the article and make buttons of them. | |
1370 \"External references\" are things like Message-IDs and URLs, as | |
1371 specified by `gnus-button-alist'." | |
1372 (interactive (list 'force)) | |
1373 (save-excursion | |
1374 (set-buffer gnus-article-buffer) | |
1375 ;; Remove all old markers. | |
1376 (while gnus-button-marker-list | |
1377 (set-marker (pop gnus-button-marker-list) nil)) | |
1378 (let ((buffer-read-only nil) | |
1379 (inhibit-point-motion-hooks t) | |
1380 (case-fold-search t) | |
1381 (alist gnus-button-alist) | |
1382 beg entry regexp) | |
1383 (goto-char (point-min)) | |
1384 ;; We skip the headers. | |
1385 (unless (search-forward "\n\n" nil t) | |
1386 (goto-char (point-max))) | |
1387 (setq beg (point)) | |
1388 (while (setq entry (pop alist)) | |
1389 (setq regexp (car entry)) | |
1390 (goto-char beg) | |
1391 (while (re-search-forward regexp nil t) | |
1392 (let* ((start (and entry (match-beginning (nth 1 entry)))) | |
1393 (end (and entry (match-end (nth 1 entry)))) | |
1394 (from (match-beginning 0))) | |
1395 (when (or (eq t (nth 1 entry)) | |
1396 (eval (nth 1 entry))) | |
1397 ;; That optional form returned non-nil, so we add the | |
1398 ;; button. | |
1399 (gnus-article-add-button | |
1400 start end 'gnus-button-push | |
1401 (car (push (set-marker (make-marker) from) | |
1402 gnus-button-marker-list)))))))))) | |
1403 | |
1404 ;; Add buttons to the head of an article. | |
1405 (defun gnus-article-add-buttons-to-head () | |
1406 "Add buttons to the head of the article." | |
13401 | 1407 (interactive) |
1408 (save-excursion | |
1409 (set-buffer gnus-article-buffer) | |
1410 (let ((buffer-read-only nil) | |
1411 (inhibit-point-motion-hooks t) | |
15511 | 1412 (case-fold-search t) |
1413 (alist gnus-header-button-alist) | |
1414 entry beg end) | |
1415 (nnheader-narrow-to-headers) | |
1416 (while alist | |
1417 ;; Each alist entry. | |
1418 (setq entry (car alist) | |
1419 alist (cdr alist)) | |
1420 (goto-char (point-min)) | |
1421 (while (re-search-forward (car entry) nil t) | |
1422 ;; Each header matching the entry. | |
1423 (setq beg (match-beginning 0)) | |
1424 (setq end (or (and (re-search-forward "^[^ \t]" nil t) | |
1425 (match-beginning 0)) | |
1426 (point-max))) | |
1427 (goto-char beg) | |
1428 (while (re-search-forward (nth 1 entry) end t) | |
1429 ;; Each match within a header. | |
1430 (let* ((from (match-beginning 0)) | |
1431 (entry (cdr entry)) | |
1432 (start (match-beginning (nth 1 entry))) | |
1433 (end (match-end (nth 1 entry))) | |
1434 (form (nth 2 entry))) | |
1435 (goto-char (match-end 0)) | |
1436 (and (eval form) | |
1437 (gnus-article-add-button | |
1438 start end (nth 3 entry) | |
1439 (buffer-substring (match-beginning (nth 4 entry)) | |
1440 (match-end (nth 4 entry))))))) | |
1441 (goto-char end)))) | |
1442 (widen))) | |
13401 | 1443 |
1444 ;;; External functions: | |
1445 | |
1446 (defun gnus-article-add-button (from to fun &optional data) | |
1447 "Create a button between FROM and TO with callback FUN and data DATA." | |
1448 (and gnus-article-button-face | |
1449 (gnus-overlay-put (gnus-make-overlay from to) | |
1450 'face gnus-article-button-face)) | |
15511 | 1451 (gnus-add-text-properties |
1452 from to | |
1453 (nconc (and gnus-article-mouse-face | |
1454 (list gnus-mouse-face-prop gnus-article-mouse-face)) | |
1455 (list 'gnus-callback fun) | |
1456 (and data (list 'gnus-data data))))) | |
13401 | 1457 |
1458 ;;; Internal functions: | |
1459 | |
1460 (defun gnus-signature-toggle (end) | |
1461 (save-excursion | |
1462 (set-buffer gnus-article-buffer) | |
15511 | 1463 (let ((buffer-read-only nil) |
1464 (inhibit-point-motion-hooks t)) | |
13401 | 1465 (if (get-text-property end 'invisible) |
15511 | 1466 (gnus-unhide-text end (point-max)) |
1467 (gnus-hide-text end (point-max) gnus-hidden-properties))))) | |
13401 | 1468 |
1469 (defun gnus-button-entry () | |
1470 ;; Return the first entry in `gnus-button-alist' matching this place. | |
1471 (let ((alist gnus-button-alist) | |
1472 (entry nil)) | |
1473 (while alist | |
15511 | 1474 (setq entry (pop alist)) |
13401 | 1475 (if (looking-at (car entry)) |
1476 (setq alist nil) | |
1477 (setq entry nil))) | |
1478 entry)) | |
1479 | |
1480 (defun gnus-button-push (marker) | |
1481 ;; Push button starting at MARKER. | |
1482 (save-excursion | |
1483 (set-buffer gnus-article-buffer) | |
1484 (goto-char marker) | |
1485 (let* ((entry (gnus-button-entry)) | |
1486 (inhibit-point-motion-hooks t) | |
1487 (fun (nth 3 entry)) | |
1488 (args (mapcar (lambda (group) | |
1489 (let ((string (buffer-substring | |
1490 (match-beginning group) | |
1491 (match-end group)))) | |
15511 | 1492 (gnus-set-text-properties |
1493 0 (length string) nil string) | |
13401 | 1494 string)) |
1495 (nthcdr 4 entry)))) | |
15511 | 1496 (cond |
1497 ((fboundp fun) | |
1498 (apply fun args)) | |
1499 ((and (boundp fun) | |
1500 (fboundp (symbol-value fun))) | |
1501 (apply (symbol-value fun) args)) | |
1502 (t | |
1503 (gnus-message 1 "You must define `%S' to use this button" | |
13401 | 1504 (cons fun args))))))) |
1505 | |
1506 (defun gnus-button-message-id (message-id) | |
15511 | 1507 "Fetch MESSAGE-ID." |
13401 | 1508 (save-excursion |
1509 (set-buffer gnus-summary-buffer) | |
1510 (gnus-summary-refer-article message-id))) | |
1511 | |
15511 | 1512 (defun gnus-button-mailto (address) |
1513 ;; Mail to ADDRESS. | |
1514 (set-buffer (gnus-copy-article-buffer)) | |
1515 (message-reply address)) | |
1516 | |
1517 (defun gnus-button-reply (address) | |
1518 ;; Reply to ADDRESS. | |
1519 (message-reply address)) | |
1520 | |
1521 (defun gnus-button-url (address) | |
1522 "Browse ADDRESS." | |
16650
092790f767a4
(gnus-button-alist): Allow whitespace in `<URL:...'
Richard M. Stallman <rms@gnu.org>
parents:
15511
diff
changeset
|
1523 (funcall browse-url-browser-function |
092790f767a4
(gnus-button-alist): Allow whitespace in `<URL:...'
Richard M. Stallman <rms@gnu.org>
parents:
15511
diff
changeset
|
1524 ;; Zap whitespace in case <URL:...> contained it. |
092790f767a4
(gnus-button-alist): Allow whitespace in `<URL:...'
Richard M. Stallman <rms@gnu.org>
parents:
15511
diff
changeset
|
1525 ;; (Whitespace illegal in raw URL.) |
092790f767a4
(gnus-button-alist): Allow whitespace in `<URL:...'
Richard M. Stallman <rms@gnu.org>
parents:
15511
diff
changeset
|
1526 (let ((stripped-address address)) |
092790f767a4
(gnus-button-alist): Allow whitespace in `<URL:...'
Richard M. Stallman <rms@gnu.org>
parents:
15511
diff
changeset
|
1527 (while (string-match "\\s +\\|\n+" stripped-address) |
092790f767a4
(gnus-button-alist): Allow whitespace in `<URL:...'
Richard M. Stallman <rms@gnu.org>
parents:
15511
diff
changeset
|
1528 (setq stripped-address (replace-match "" t t stripped-address))) |
092790f767a4
(gnus-button-alist): Allow whitespace in `<URL:...'
Richard M. Stallman <rms@gnu.org>
parents:
15511
diff
changeset
|
1529 stripped-address))) |
15511 | 1530 |
1531 ;;; Next/prev buttons in the article buffer. | |
1532 | |
1533 (defvar gnus-next-page-line-format "%{%(Next page...%)%}\n") | |
1534 (defvar gnus-prev-page-line-format "%{%(Previous page...%)%}\n") | |
1535 | |
1536 (defvar gnus-prev-page-map nil) | |
1537 (unless gnus-prev-page-map | |
1538 (setq gnus-prev-page-map (make-sparse-keymap)) | |
1539 (define-key gnus-prev-page-map gnus-mouse-2 'gnus-button-prev-page) | |
1540 (define-key gnus-prev-page-map "\r" 'gnus-button-prev-page)) | |
1541 | |
1542 (defun gnus-insert-prev-page-button () | |
1543 (let ((buffer-read-only nil)) | |
1544 (gnus-eval-format | |
1545 gnus-prev-page-line-format nil | |
1546 `(gnus-prev t local-map ,gnus-prev-page-map | |
1547 gnus-callback gnus-article-button-prev-page)))) | |
1548 | |
1549 (defvar gnus-next-page-map nil) | |
1550 (unless gnus-next-page-map | |
1551 (setq gnus-next-page-map (make-keymap)) | |
1552 (suppress-keymap gnus-prev-page-map) | |
1553 (define-key gnus-next-page-map gnus-mouse-2 'gnus-button-next-page) | |
1554 (define-key gnus-next-page-map "\r" 'gnus-button-next-page)) | |
1555 | |
1556 (defun gnus-button-next-page () | |
1557 "Go to the next page." | |
1558 (interactive) | |
1559 (let ((win (selected-window))) | |
1560 (select-window (get-buffer-window gnus-article-buffer t)) | |
1561 (gnus-article-next-page) | |
1562 (select-window win))) | |
1563 | |
1564 (defun gnus-button-prev-page () | |
1565 "Go to the prev page." | |
1566 (interactive) | |
1567 (let ((win (selected-window))) | |
1568 (select-window (get-buffer-window gnus-article-buffer t)) | |
1569 (gnus-article-prev-page) | |
1570 (select-window win))) | |
1571 | |
1572 (defun gnus-insert-next-page-button () | |
1573 (let ((buffer-read-only nil)) | |
1574 (gnus-eval-format gnus-next-page-line-format nil | |
1575 `(gnus-next t local-map ,gnus-next-page-map | |
1576 gnus-callback | |
1577 gnus-article-button-next-page)))) | |
1578 | |
1579 (defun gnus-article-button-next-page (arg) | |
1580 "Go to the next page." | |
1581 (interactive "P") | |
1582 (let ((win (selected-window))) | |
1583 (select-window (get-buffer-window gnus-article-buffer t)) | |
1584 (gnus-article-next-page) | |
1585 (select-window win))) | |
1586 | |
1587 (defun gnus-article-button-prev-page (arg) | |
1588 "Go to the prev page." | |
1589 (interactive "P") | |
1590 (let ((win (selected-window))) | |
1591 (select-window (get-buffer-window gnus-article-buffer t)) | |
1592 (gnus-article-prev-page) | |
1593 (select-window win))) | |
1594 | |
13401 | 1595 ;;; Compatibility Functions: |
1596 | |
1597 (or (fboundp 'rassoc) | |
1598 ;; Introduced in Emacs 19.29. | |
1599 (defun rassoc (elt list) | |
1600 "Return non-nil if ELT is `equal' to the cdr of an element of LIST. | |
1601 The value is actually the element of LIST whose cdr is ELT." | |
1602 (let (result) | |
1603 (while list | |
1604 (setq result (car list)) | |
1605 (if (equal (cdr result) elt) | |
1606 (setq list nil) | |
1607 (setq result nil | |
1608 list (cdr list)))) | |
1609 result))) | |
1610 | |
1611 ; (require 'gnus-cus) | |
1612 (gnus-ems-redefine) | |
1613 (provide 'gnus-vis) | |
1614 | |
1615 ;;; gnus-vis.el ends here |