1 ;;; gnus-vis.el --- display-oriented parts of Gnus
2 ;; Copyright (C) 1995 Free Software Foundation, Inc.
4 ;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
5 ;; Per Abrahamsen <abraham@iesd.auc.dk>
8 ;; This file is part of GNU Emacs.
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)
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.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs; see the file COPYING. If not, write to
22 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
29 (require gnus-easymenu)
33 (defvar gnus-summary-selected-face 'underline
34 "*Face used for highlighting the current article in the summary buffer.")
36 (defvar gnus-summary-highlight
37 '(((> score default) . bold)
38 ((< score default) . italic))
39 "*Alist of `(FORM . FACE)'.
40 Summary lines are highlighted with the FACE for the first FORM which
41 evaluate to a non-nil value.
43 Point will be at the beginning of the line when FORM is evaluated.
44 The following can be used for convenience:
46 score: (gnus-summary-article-score)
47 default: gnus-summary-default-score
48 below: gnus-summary-mark-below
50 To check for marks, e.g. to underline replied articles, use
51 `gnus-summary-article-mark':
53 ((= (gnus-summary-article-mark) gnus-replied-mark) . underline)")
55 ;;; article highlights
57 (defvar gnus-make-foreground t
58 "Non nil means foreground color to highlight citations.")
60 (defvar gnus-article-button-face 'bold
61 "Face used for text buttons.")
63 (defvar gnus-article-mouse-face (if (boundp 'gnus-mouse-face)
66 "Face used when the mouse is over the button.")
68 (defvar gnus-header-face-alist '(("" bold italic))
69 "Alist of headers and faces used for highlighting them.
70 The entries in the list has the form `(REGEXP NAME CONTENT)', where
71 REGEXP is a regeular expression matching the beginning of the header,
72 NAME is the face used for highlighting the header name and CONTENT is
73 the face used for highlighting the header content.
75 The first non-nil NAME or CONTENT with a matching REGEXP in the list
78 (defvar gnus-signature-face 'italic
79 "Face used for signature.")
81 (defvar gnus-button-alist
82 '(("in\\( +article\\)? +\\(<\\([^\n @<>]+@[^\n @<>]+\\)>\\)" 2
83 (assq (count-lines (point-min) (match-end 0))
84 gnus-cite-attribution-alist)
85 gnus-button-message-id 3)
86 ;; This is how URLs _should_ be embedded in text...
87 ("<URL:\\([^\n\r>]*\\)>" 0 t gnus-button-url 1)
88 ;; Next regexp stolen from highlight-headers.el
89 ("\\b\\(s?https?\\|ftp\\|file\\|gopher\\|news\\|telnet\\):\\(//[-a-zA-Z0-9_.]+:[0-9]*\\)?[-a-zA-Z0-9_=?#$@~`%&*+|\\/.,]+" 0 t
91 "Alist of regexps matching buttons in an article.
93 Each entry has the form (REGEXP BUTTON FORM CALLBACK PAR...), where
94 REGEXP: is the string matching text around the button,
95 BUTTON: is the number of the regexp grouping actually matching the button,
96 FORM: is a lisp expression which must eval to true for the button to
98 CALLBACK: is the function to call when the user push this button, and each
99 PAR: is a number of a regexp grouping whose text will be passed to CALLBACK.
101 CALLBACK can also be a variable, in that case the value of that
102 variable it the real callback function.")
104 (defvar gnus-button-url (cond ((fboundp 'w3-fetch)
106 ((fboundp 'highlight-headers-follow-url-netscape)
107 'highlight-headers-follow-url-netscape)
109 "Function to fetch URL.
110 The function will be called with one argument, the URL to fetch.
111 Useful values of this function are:
114 defined in the w3 emacs package by William M. Perry.
115 highlight-headers-follow-url-netscape:
116 from `highlight-headers.el' for loading NetScape 1.1.")
121 (autoload 'nnkiboze-generate-groups "nnkiboze")
122 (autoload 'gnus-cite-parse-maybe "gnus-cite" nil t))
130 (defun gnus-group-make-menu-bar ()
132 gnus-group-reading-menu
136 ["Read" gnus-group-read-group t]
137 ["Select" gnus-group-select-group t]
138 ["Catch up" gnus-group-catchup-current t]
139 ["Catch up all articles" gnus-group-catchup-current-all t]
140 ["Check for new articles" gnus-group-get-new-news-this-group t]
141 ["Toggle subscription" gnus-group-unsubscribe-current-group t]
142 ["Kill" gnus-group-kill-group t]
143 ["Yank" gnus-group-yank-group t]
144 ["Describe" gnus-group-describe-group t]
145 ["Fetch FAQ" gnus-group-fetch-faq t]
146 ["Edit kill file" gnus-group-edit-local-kill t]
147 ["Expire articles" gnus-group-expire-articles t]
148 ["Set group level" gnus-group-set-current-level t]
152 gnus-group-group-menu
157 ["List subscribed groups" gnus-group-list-groups t]
158 ["List all groups" gnus-group-list-all-groups t]
159 ["List groups matching..." gnus-group-list-matching t]
160 ["List killed groups" gnus-group-list-killed t]
161 ["List zombie groups" gnus-group-list-zombies t]
162 ["Describe all groups" gnus-group-describe-all-groups t]
163 ["Group apropos" gnus-group-apropos t]
164 ["Group and description apropos" gnus-group-description-apropos t]
165 ["List groups matching..." gnus-group-list-matching t])
167 ["Mark group" gnus-group-mark-group t]
168 ["Unmark group" gnus-group-unmark-group t]
169 ["Mark region" gnus-group-mark-region t])
171 ["Subscribe to random group" gnus-group-unsubscribe-group t]
172 ["Kill all newsgroups in region" gnus-group-kill-region t]
173 ["Kill all zombie groups" gnus-group-kill-all-zombies t])
175 ["Make a foreign group" gnus-group-make-group t]
176 ["Edit a group entry" gnus-group-edit-group t]
177 ["Add a directory group" gnus-group-make-directory-group t]
178 ["Add the help group" gnus-group-make-help-group t]
179 ["Add the archive group" gnus-group-make-archive-group t]
180 ["Make a kiboze group" gnus-group-make-kiboze-group t])
181 ["Jump to group" gnus-group-jump-to-group t]
182 ["Best unread group" gnus-group-best-unread-group t]
190 ["Send a mail" gnus-group-mail t]
191 ["Post an article" gnus-group-post-news t]
199 ["Send a bug report" gnus-bug t]
200 ["Check for new news" gnus-group-get-new-news t]
201 ["Delete bogus groups" gnus-group-check-bogus-groups t]
202 ["Find new newsgroups" gnus-find-new-newsgroups t]
203 ["Restart Gnus" gnus-group-restart t]
204 ["Read init file" gnus-group-read-init-file t]
205 ["Browse foreign server" gnus-group-browse-foreign-server t]
206 ["Enter server buffer" gnus-group-enter-server-mode t]
207 ["Edit the global kill file" gnus-group-edit-global-kill t]
208 ["Expire all expirable articles" gnus-group-expire-all-groups t]
209 ["Generate any kiboze groups" nnkiboze-generate-groups t]
210 ["Gnus version" gnus-version t]
211 ["Save .newsrc files" gnus-group-save-newsrc t]
212 ["Suspend Gnus" gnus-group-suspend t]
213 ["Clear dribble buffer" gnus-group-clear-dribble t]
214 ["Exit from Gnus" gnus-group-exit t]
215 ["Exit without saving" gnus-group-quit t]
216 ["Sort group buffer" gnus-group-sort-groups t]
217 ["Edit global KILL file" gnus-group-edit-global-kill t]
223 (defun gnus-server-make-menu-bar ()
229 ["Add" gnus-server-add-server t]
230 ["Browse" gnus-server-read-server t]
231 ["List" gnus-server-list-servers t]
232 ["Kill" gnus-server-kill-server t]
233 ["Yank" gnus-server-yank-server t]
234 ["Copy" gnus-server-copy-server t]
235 ["Edit" gnus-server-edit-server t]
236 ["Exit" gnus-server-exit t]
240 (defun gnus-browse-make-menu-bar ()
246 ["Subscribe" gnus-browse-unsubscribe-current-group t]
247 ["Exit" gnus-browse-exit t]
251 (defun gnus-summary-make-menu-bar ()
254 gnus-summary-mark-menu
255 gnus-summary-mode-map
259 ["Mark as read" gnus-summary-mark-as-read-forward t]
260 ["Mark same subject and select" gnus-summary-kill-same-subject-and-select t]
261 ["Mark same subject" gnus-summary-kill-same-subject t]
262 ["Catchup" gnus-summary-catchup t]
263 ["Catchup all" gnus-summary-catchup-all t]
264 ["Catchup to here" gnus-summary-catchup-to-here t]
265 ["Catchup region" gnus-summary-mark-region-as-read t])
267 ["Tick" gnus-summary-tick-article-forward t]
268 ["Mark as dormant" gnus-summary-mark-as-dormant t]
269 ["Remove marks" gnus-summary-clear-mark-forward t]
270 ["Set expirable mark" gnus-summary-mark-as-expirable t]
271 ["Set bookmark" gnus-summary-set-bookmark t]
272 ["Remove bookmark" gnus-summary-remove-bookmark t])
274 ["Enter score" gnus-summary-score-entry t]
275 ["Raise score" gnus-summary-raise-score t]
276 ["Lower score" gnus-summary-lower-score t]
277 ["Current score" gnus-summary-current-score t]
278 ["Set score" gnus-summary-set-score t])
280 ["Remove lines marked as read" gnus-summary-remove-lines-marked-as-read t]
281 ["Remove lines marked with..." gnus-summary-remove-lines-marked-with t]
282 ["Show dormant articles" gnus-summary-show-all-dormant t]
283 ["Hide dormant articles" gnus-summary-hide-all-dormant t]
284 ["Show expunged articles" gnus-summary-show-all-expunged t])
286 ["Set mark" gnus-summary-mark-as-processable t]
287 ["Remove mark" gnus-summary-unmark-as-processable t]
288 ["Remove all marks" gnus-summary-unmark-all-processable t]
289 ["Mark series" gnus-uu-mark-series t]
290 ["Mark region" gnus-uu-mark-region t]
291 ["Mark by regexp" gnus-uu-mark-by-regexp t]
292 ["Mark all" gnus-uu-mark-all t]
293 ["Mark sparse" gnus-uu-mark-sparse t]
294 ["Mark thread" gnus-uu-mark-thread t]
299 gnus-summary-move-menu
300 gnus-summary-mode-map
303 ["Scroll article forwards" gnus-summary-next-page t]
304 ["Next unread article" gnus-summary-next-unread-article t]
305 ["Previous unread article" gnus-summary-prev-unread-article t]
306 ["Next article" gnus-summary-next-article t]
307 ["Previous article" gnus-summary-prev-article t]
308 ["Next article same subject" gnus-summary-next-same-subject t]
309 ["Previous article same subject" gnus-summary-prev-same-subject t]
310 ["First unread article" gnus-summary-first-unread-article t]
311 ["Go to subject number..." gnus-summary-goto-subject t]
312 ["Go to the last article" gnus-summary-goto-last-article t]
313 ["Pop article off history" gnus-summary-pop-article t]
317 gnus-summary-article-menu
318 gnus-summary-mode-map
323 ["Local" gnus-article-date-local t]
324 ["UT" gnus-article-date-local t]
325 ["Lapsed" gnus-article-date-local t])
326 ["Headers" gnus-article-hide-headers t]
327 ["Signature" gnus-article-hide-signature t]
328 ["Citation" gnus-article-hide-citation t]
329 ["Overstrike" gnus-article-treat-overstrike t]
330 ["Word wrap" gnus-article-word-wrap t]
331 ["CR" gnus-article-remove-cr t]
332 ["Show X-Face" gnus-article-display-x-face t]
333 ["Quoted-Printable" gnus-article-de-quoted-unreadable t])
335 ["Uudecode" gnus-uu-decode-uu t]
336 ["Uudecode and save" gnus-uu-decode-uu-and-save t]
337 ["Unshar" gnus-uu-decode-unshar t]
338 ["Unshar and save" gnus-uu-decode-unshar-and-save t]
339 ["Save" gnus-uu-decode-save t]
340 ["Binhex" gnus-uu-decode-binhex t])
341 ["Enter digest buffer" gnus-summary-enter-digest-group t]
342 ["Isearch article" gnus-summary-isearch-article t]
343 ["Search all articles" gnus-summary-search-article-forward t]
344 ["Beginning of the article" gnus-summary-beginning-of-article t]
345 ["End of the article" gnus-summary-end-of-article t]
346 ["Fetch parent of article" gnus-summary-refer-parent-article t]
347 ["Fetch article with id..." gnus-summary-refer-article t]
348 ["Stop page breaking" gnus-summary-stop-page-breaking t]
349 ["Caesar rotate" gnus-summary-caesar-message t]
350 ["Redisplay" gnus-summary-show-article t]
351 ["Toggle header" gnus-summary-toggle-header t]
352 ["Toggle MIME" gnus-summary-toggle-mime t]
353 ["Save" gnus-summary-save-article t]
354 ["Save in mail format" gnus-summary-save-article-mail t]
355 ["Pipe through a filter" gnus-summary-pipe-output t]
357 ["Respool article" gnus-summary-respool-article t]
358 ["Move article" gnus-summary-move-article t]
359 ["Copy article" gnus-summary-copy-article t]
360 ["Edit article" gnus-summary-edit-article t]
361 ["Delete article" gnus-summary-delete-article t])
365 gnus-summary-thread-menu
366 gnus-summary-mode-map
369 ["Toggle threading" gnus-summary-toggle-threads t]
370 ["Display hidden thread" gnus-summary-show-thread t]
371 ["Hide thread" gnus-summary-hide-thread t]
372 ["Go to next thread" gnus-summary-next-thread t]
373 ["Go to previous thread" gnus-summary-prev-thread t]
374 ["Go down thread" gnus-summary-down-thread t]
375 ["Go up thread" gnus-summary-up-thread t]
376 ["Mark thread as read" gnus-summary-kill-thread t]
377 ["Lower thread score" gnus-summary-lower-thread t]
378 ["Raise thread score" gnus-summary-raise-thread t]
382 gnus-summary-misc-menu
383 gnus-summary-mode-map
387 ["Sort by number" gnus-summary-sort-by-number t]
388 ["Sort by author" gnus-summary-sort-by-author t]
389 ["Sort by subject" gnus-summary-sort-by-subject t]
390 ["Sort by date" gnus-summary-sort-by-date t]
391 ["Sort by score" gnus-summary-sort-by-score t])
393 ["Catchup and exit" gnus-summary-catchup-and-exit t]
394 ["Catchup and goto next" gnus-summary-catchup-and-goto-next-group t]
395 ["Exit group" gnus-summary-exit t]
396 ["Exit group without updating" gnus-summary-quit t]
397 ["Reselect group" gnus-summary-reselect-current-group t]
398 ["Rescan group" gnus-summary-rescan-group t])
399 ["Fetch group FAQ" gnus-summary-fetch-faq t]
400 ["Filter articles" gnus-summary-execute-command t]
401 ["Toggle line truncation" gnus-summary-toggle-truncation t]
402 ["Expire expirable articles" gnus-summary-expire-articles t]
403 ["Describe group" gnus-summary-describe-group t]
404 ["Edit local kill file" gnus-summary-edit-local-kill t]
405 ["Edit global kill file" gnus-summary-edit-global-kill t]
409 gnus-summary-post-menu
410 gnus-summary-mode-map
413 ["Post an article" gnus-summary-post-news t]
414 ["Followup" gnus-summary-followup t]
415 ["Followup and yank" gnus-summary-followup-with-original t]
416 ["Supersede article" gnus-summary-supersede-article t]
417 ["Cancel article" gnus-summary-cancel-article t]
418 ["Reply" gnus-summary-reply t]
419 ["Reply and yank" gnus-summary-reply-with-original t]
420 ["Mail forward" gnus-summary-mail-forward t]
421 ["Post forward" gnus-summary-post-forward t]
422 ["Digest and mail" gnus-uu-digest-mail-forward t]
423 ["Digest and post" gnus-uu-digest-post-forward t]
424 ["Send a mail" gnus-summary-mail-other-window t]
425 ["Reply & followup" gnus-summary-followup-and-reply t]
426 ["Reply & followup and yank" gnus-summary-followup-and-reply-with-original t]
427 ["Uuencode and post" gnus-uu-post-news t]
431 gnus-summary-kill-menu
432 gnus-summary-mode-map
436 ["Switch current score file" gnus-score-change-score-file t]
437 ["Set mark below" gnus-score-set-mark-below t]
438 ["Set expunge below" gnus-score-set-expunge-below t]
439 ["Edit current score file" gnus-score-edit-alist t]
440 ["Edit score file" gnus-score-edit-file t]
441 ["Trace score" gnus-score-find-trace t])
446 (defun gnus-article-make-menu-bar ()
449 gnus-article-article-menu
450 gnus-article-mode-map
453 ["Scroll forwards" gnus-article-next-page t]
454 ["Scroll backwards" gnus-article-prev-page t]
455 ["Show summary" gnus-article-show-summary t]
456 ["Fetch Message-ID at point" gnus-article-refer-article t]
457 ["Mail to address at point" gnus-article-mail t]
458 ["Mail to address at point and include original"
459 gnus-article-mail-with-original t]
463 gnus-article-treatment-menu
464 gnus-article-mode-map
467 ["Hide headers" gnus-article-hide-headers t]
468 ["Hide signature" gnus-article-hide-signature t]
469 ["Hide citation" gnus-article-hide-citation t]
470 ["Treat overstrike" gnus-article-treat-overstrike t]
471 ["Remove carriage return" gnus-article-remove-cr t]
472 ["Remove quoted-unreadble" gnus-article-de-quoted-unreadable t]
477 ;;; summary highlights
480 (defun gnus-highlight-selected-summary ()
481 ;; Added by Per Abrahamsen <amanda@iesd.auc.dk>.
482 ;; Highlight selected article in summary buffer
483 (if gnus-summary-selected-face
485 (let* ((beg (progn (beginning-of-line) (point)))
486 (end (progn (end-of-line) (point)))
487 ;; Fix by Mike Dugan <dugan@bucrf16.bu.edu>.
488 (from (if (get-text-property beg 'mouse-face)
490 (1+ (or (next-single-property-change
491 beg 'mouse-face nil end)
493 (to (1- (or (next-single-property-change
494 from 'mouse-face nil end)
496 ;; If no mouse-face prop on line (e.g. xemacs) we
497 ;; will have to = from = end, so we highlight the
498 ;; entire line instead.
503 (if gnus-newsgroup-selected-overlay
504 (move-overlay gnus-newsgroup-selected-overlay
505 from to (current-buffer))
506 (setq gnus-newsgroup-selected-overlay (make-overlay from to))
507 (overlay-put gnus-newsgroup-selected-overlay 'face
508 gnus-summary-selected-face))))))
511 ;; New implementation by Christian Limpach <Christian.Limpach@nice.ch>.
512 (defun gnus-summary-highlight-line ()
513 "Highlight current line according to `gnus-summary-highlight'."
514 (let* ((list gnus-summary-highlight)
516 (end (progn (end-of-line) (point)))
517 ;; now find out where the line starts and leave point there.
518 (beg (progn (beginning-of-line) (point)))
519 (score (or (cdr (assq (or (car (get-text-property beg 'gnus))
520 gnus-current-article)
521 gnus-newsgroup-scored))
522 gnus-summary-default-score 0))
523 (default gnus-summary-default-score)
524 (mark (car (cdr (get-text-property beg 'gnus))))
525 (inhibit-read-only t))
526 (while (and list (not (eval (car (car list)))))
527 (setq list (cdr list)))
528 (let ((face (and list (cdr (car list)))))
529 ;; BUG! For some reason the text properties of the first
530 ;; characters get mangled.
532 (eq face (get-text-property beg 'face))
533 (put-text-property beg end 'face face)))
540 (defvar gnus-carpal-group-buffer-buttons
541 '(("next" . gnus-group-next-unread-group)
542 ("prev" . gnus-group-prev-unread-group)
543 ("read" . gnus-group-read-group)
544 ("select" . gnus-group-select-group)
545 ("catch up" . gnus-group-catchup-current)
546 ("new news" . gnus-group-get-new-news-this-group)
547 ("toggle sub" . gnus-group-unsubscribe-current-group)
548 ("subscribe" . gnus-group-unsubscribe-group)
549 ("kill" . gnus-group-kill-group)
550 ("yank" . gnus-group-yank-group)
551 ("describe" . gnus-group-describe-group)
553 ("subscribed" . gnus-group-list-groups)
554 ("all" . gnus-group-list-all-groups)
555 ("killed" . gnus-group-list-killed)
556 ("zombies" . gnus-group-list-zombies)
557 ("matching" . gnus-group-list-matching)
558 ("post" . gnus-group-post-news)
559 ("mail" . gnus-group-mail)
560 ("new news" . gnus-group-get-new-news)
561 ("browse foreign" . gnus-group-browse-foreign)
562 ("exit" . gnus-group-exit)))
564 (defvar gnus-carpal-summary-buffer-buttons
566 ("read" . gnus-summary-mark-as-read-forward)
567 ("tick" . gnus-summary-tick-article-forward)
568 ("clear" . gnus-summary-clear-mark-forward)
569 ("expirable" . gnus-summary-mark-as-expirable)
571 ("scroll" . gnus-summary-next-page)
572 ("next unread" . gnus-summary-next-unread-article)
573 ("prev unread" . gnus-summary-prev-unread-article)
574 ("first" . gnus-summary-first-unread-article)
575 ("best" . gnus-summary-best-unread-article)
577 ("headers" . gnus-summary-toggle-header)
578 ("uudecode" . gnus-uu-decode-uu)
579 ("enter digest" . gnus-summary-enter-digest-group)
580 ("fetch parent" . gnus-summary-refer-parent-article)
582 ("move" . gnus-summary-move-article)
583 ("copy" . gnus-summary-copy-article)
584 ("respool" . gnus-summary-respool-article)
586 ("lower" . gnus-summary-lower-thread)
587 ("kill" . gnus-summary-kill-thread)
589 ("post" . gnus-summary-post-news)
590 ("mail" . gnus-summary-mail)
591 ("followup" . gnus-summary-followup-with-original)
592 ("reply" . gnus-summary-reply-with-original)
593 ("cancel" . gnus-summary-cancel-article)
595 ("exit" . gnus-summary-exit)
596 ("fed up" . gnus-summary-catchup-and-goto-next)))
598 (defvar gnus-carpal-server-buffer-buttons
599 '(("add" . gnus-server-add-server)
600 ("browse" . gnus-server-browse-server)
601 ("list" . gnus-server-list-servers)
602 ("kill" . gnus-server-kill-server)
603 ("yank" . gnus-server-yank-server)
604 ("copy" . gnus-server-copy-server)
605 ("exit" . gnus-server-exit)))
607 (defvar gnus-carpal-browse-buffer-buttons
608 '(("subscribe" . gnus-browse-unsubscribe-current-group)
609 ("exit" . gnus-browse-exit)))
611 (defvar gnus-carpal-group-buffer "*Carpal Group*")
612 (defvar gnus-carpal-summary-buffer "*Carpal Summary*")
613 (defvar gnus-carpal-server-buffer "*Carpal Server*")
614 (defvar gnus-carpal-browse-buffer "*Carpal Browse*")
616 (defvar gnus-carpal-attached-buffer nil)
618 (defvar gnus-carpal-mode-hook nil
619 "*Hook run in carpal mode buffers.")
621 (defvar gnus-carpal-button-face 'bold
622 "*Face used on carpal buttons.")
624 (defvar gnus-carpal-header-face 'bold-italic
625 "*Face used on carpal buffer headers.")
627 (defvar gnus-carpal-mode-map nil)
628 (put 'gnus-carpal-mode 'mode-class 'special)
630 (if gnus-carpal-mode-map
632 (setq gnus-carpal-mode-map (make-keymap))
633 (suppress-keymap gnus-carpal-mode-map)
634 (define-key gnus-carpal-mode-map " " 'gnus-carpal-select)
635 (define-key gnus-carpal-mode-map "\r" 'gnus-carpal-select)
636 (define-key gnus-carpal-mode-map [mouse-2] 'gnus-carpal-mouse-select))
638 (defun gnus-carpal-mode ()
639 "Major mode clicking buttons.
641 All normal editing commands are switched off.
642 \\<gnus-carpal-mode-map>
643 The following commands are available:
645 \\{gnus-carpal-mode-map}"
647 (kill-all-local-variables)
648 (setq mode-line-modified "-- ")
649 (setq major-mode 'gnus-carpal-mode)
650 (setq mode-name "Gnus Carpal")
651 (setq mode-line-process nil)
652 (use-local-map gnus-carpal-mode-map)
653 (buffer-disable-undo (current-buffer))
654 (setq buffer-read-only t)
655 (make-local-variable 'gnus-carpal-attached-buffer)
656 (run-hooks 'gnus-carpal-mode-hook))
658 (defun gnus-carpal-setup-buffer (type)
659 (let ((buffer (symbol-value (intern (format "gnus-carpal-%s-buffer" type)))))
660 (if (get-buffer buffer)
663 (set-buffer (get-buffer-create buffer))
665 (setq gnus-carpal-attached-buffer
666 (intern (format "gnus-%s-buffer" type)))
667 (gnus-add-current-to-buffer-list)
668 (let ((buttons (symbol-value
669 (intern (format "gnus-carpal-%s-buffer-buttons"
671 (buffer-read-only nil)
674 (setq button (car buttons)
675 buttons (cdr buttons))
679 (prog2 (insert button) (point) (insert " "))
680 (list 'face gnus-carpal-header-face))
683 (prog2 (insert (car button)) (point) (insert " "))
684 (list 'gnus-callback (cdr button)
685 'face gnus-carpal-button-face
686 'mouse-face 'highlight))))
687 (let ((fill-column (- (window-width) 2)))
688 (fill-region (point-min) (point-max)))
689 (set-window-point (get-buffer-window (current-buffer))
692 (defun gnus-carpal-select ()
693 "Select the button under point."
695 (let ((func (get-text-property (point) 'gnus-callback)))
698 (pop-to-buffer (symbol-value gnus-carpal-attached-buffer))
699 (call-interactively func))))
701 (defun gnus-carpal-mouse-select (event)
702 "Select the button under the mouse pointer."
704 (mouse-set-point event)
705 (gnus-carpal-select))
708 ;;; article highlights
711 ;; Written by Per Abrahamsen <abraham@iesd.auc.dk>.
713 ;;; Internal Variables:
715 (defvar gnus-button-regexp nil)
716 ;; Regexp matching any of the regexps from `gnus-button-alist'.
718 (defvar gnus-button-last nil)
719 ;; The value of `gnus-button-alist' when `gnus-button-regexp' was build.
723 (defun gnus-article-push-button (event)
724 "Check text under the mouse pointer for a callback function.
725 If the text under the mouse pointer has a `gnus-callback' property,
726 call it with the value of the `gnus-data' text property."
728 (set-buffer (window-buffer (posn-window (event-start event))))
729 (let* ((pos (posn-point (event-start event)))
730 (data (get-text-property pos 'gnus-data))
731 (fun (get-text-property pos 'gnus-callback)))
732 (if fun (funcall fun data))))
734 (defun gnus-article-press-button ()
735 "Check text at point for a callback function.
736 If the text at point has a `gnus-callback' property,
737 call it with the value of the `gnus-data' text property."
739 (let* ((data (get-text-property (point) 'gnus-data))
740 (fun (get-text-property (point) 'gnus-callback)))
741 (if fun (funcall fun data))))
743 ;; Suggested by Arne Elofsson <arne@hodgkin.mbi.ucla.edu>
744 (defun gnus-article-next-button ()
745 "Move point to next button."
747 (if (get-text-property (point) 'gnus-callback)
748 (goto-char (next-single-property-change (point) 'gnus-callback
750 (let ((pos (next-single-property-change (point) 'gnus-callback)))
753 (setq pos (next-single-property-change (point-min) 'gnus-callback))
756 (error "No buttons found")))))
758 (defun gnus-article-highlight ()
759 "Highlight current article.
760 This function calls `gnus-article-highlight-headers',
761 `gnus-article-highlight-citation',
762 `gnus-article-highlight-signature', and `gnus-article-add-buttons' to
763 do the highlighting. See the documentation for those functions."
765 (gnus-article-highlight-headers)
766 (gnus-article-highlight-citation)
767 (gnus-article-highlight-signature)
768 (gnus-article-add-buttons))
770 (defun gnus-article-hide ()
771 "Hide current article.
772 This function calls `gnus-article-hide-headers',
773 `gnus-article-hide-citation-maybe', and `gnus-article-hide-signature'
774 to do the hiding. See the documentation for those functions."
776 (gnus-article-hide-headers)
777 (gnus-article-hide-citation-maybe)
778 (gnus-article-hide-signature))
780 (defun gnus-article-highlight-headers ()
781 "Highlight article headers as specified by `gnus-header-face-alist'."
784 (set-buffer gnus-article-buffer)
785 (goto-char (point-min))
786 (search-forward "\n\n")
787 (beginning-of-line 0)
789 (let ((alist gnus-header-face-alist)
790 (buffer-read-only nil)
793 (inhibit-point-motion-hooks t)
794 begin entry regexp header-face field-face header-found field-found)
795 (re-search-backward "^[^ \t]" nil t)
798 (setq entry (car alist)
800 header-face (nth 1 entry)
801 field-face (nth 2 entry)
803 (if (looking-at regexp)
804 (let ((from (point)))
805 (skip-chars-forward "^:\n")
806 (and (not header-found)
809 (put-text-property from (point) 'face header-face)
810 (setq header-found t)))
811 (and (not field-found)
814 (skip-chars-forward ": \t")
815 (let ((from (point)))
817 (skip-chars-backward " \t")
818 (put-text-property from (point) 'face field-face)
819 (setq field-found t))))))
820 (goto-char begin))))))
822 (defun gnus-article-highlight-signature ()
823 "Highlight the signature in an article.
824 It does this by highlighting everything after
825 `gnus-signature-separator' using `gnus-signature-face'."
828 (set-buffer gnus-article-buffer)
829 (let ((buffer-read-only nil)
830 (inhibit-point-motion-hooks t))
831 (goto-char (point-max))
832 (and (re-search-backward gnus-signature-separator nil t)
834 (let ((start (match-beginning 0))
836 (gnus-article-add-button start end 'gnus-signature-toggle end)
837 (overlay-put (make-overlay end (point-max))
838 'face gnus-signature-face))))))
840 (defun gnus-article-hide-signature ()
841 "Hide the signature in an article.
842 It does this by making everything after `gnus-signature-separator' invisible."
845 (set-buffer gnus-article-buffer)
846 (let ((buffer-read-only nil))
847 (goto-char (point-max))
848 (and (re-search-backward gnus-signature-separator nil t)
850 (add-text-properties (match-end 0) (point-max)
851 gnus-hidden-properties)))))
853 (defun gnus-article-add-buttons ()
854 "Find external references in article and make them to buttons.
856 External references are things like message-ids and URLs, as specified by
857 `gnus-button-alist'."
859 (if (eq gnus-button-last gnus-button-alist)
861 (setq gnus-button-regexp (mapconcat 'car gnus-button-alist "\\|")
862 gnus-button-last gnus-button-alist))
864 (set-buffer gnus-article-buffer)
865 (gnus-cite-parse-maybe)
866 (let ((buffer-read-only nil)
867 (inhibit-point-motion-hooks t)
868 (case-fold-search t))
869 (goto-char (point-min))
870 (search-forward "\n\n")
871 (while (re-search-forward gnus-button-regexp nil t)
872 (goto-char (match-beginning 0))
873 (let* ((from (point))
874 (entry (gnus-button-entry))
875 (start (and entry (match-beginning (nth 1 entry))))
876 (end (and entry (match-end (nth 1 entry))))
881 (goto-char (match-end 0))
883 (gnus-article-add-button start end 'gnus-button-push
884 (set-marker (make-marker)
887 ;;; External functions:
889 (defun gnus-article-add-button (from to fun &optional data)
890 "Create a button between FROM and TO with callback FUN and data DATA."
891 (add-text-properties from to
892 (append (if gnus-article-button-face
893 (list 'face gnus-article-button-face))
894 (if gnus-article-mouse-face
895 (list 'mouse-face gnus-article-mouse-face))
896 (list 'gnus-callback fun)
897 (if data (list 'gnus-data data)))))
899 ;;; Internal functions:
901 (defun gnus-signature-toggle (end)
903 (set-buffer gnus-article-buffer)
904 (let ((buffer-read-only nil))
905 (if (get-text-property end 'invisible)
906 (remove-text-properties end (point-max) gnus-hidden-properties)
907 (add-text-properties end (point-max) gnus-hidden-properties)))))
909 (defun gnus-make-face (color)
910 ;; Create entry for face with background COLOR.
911 (let ((name (intern (concat "gnus " color))))
913 (if gnus-make-foreground
914 (set-face-foreground name color)
915 (set-face-background name color))
918 (defun gnus-button-entry ()
919 ;; Return the first entry in `gnus-button-alist' matching this place.
920 (let ((alist gnus-button-alist)
923 (setq entry (car alist)
925 (if (looking-at (car entry))
930 (defun gnus-button-push (marker)
931 ;; Push button starting at MARKER.
933 (set-buffer gnus-article-buffer)
935 (let* ((entry (gnus-button-entry))
936 (inhibit-point-motion-hooks t)
938 (args (mapcar (lambda (group)
939 (let ((string (buffer-substring
940 (match-beginning group)
942 (set-text-properties 0 (length string) nil string)
948 (fboundp (symbol-value fun)))
949 (apply (symbol-value fun) args))
951 (message "You must define `%S' to use this button"
952 (cons fun args)))))))
954 (defun gnus-button-message-id (message-id)
955 ;; Push on MESSAGE-ID.
957 (set-buffer gnus-summary-buffer)
958 (gnus-summary-refer-article message-id)))
960 ;;; Compatibility Functions:
962 (or (fboundp 'rassoc)
963 ;; Introduced in Emacs 19.29.
964 (defun rassoc (elt list)
965 "Return non-nil if ELT is `equal' to the cdr of an element of LIST.
966 The value is actually the element of LIST whose cdr is ELT."
969 (setq result (car list))
970 (if (equal (cdr result) elt)
978 ;;; gnus-vis.el ends here