cgit.sxemacs.org Git - gnus/blob - lisp/gnus-vis.el

   1 ;;; gnus-vis.el --- display-oriented parts of Gnus
   2 ;; Copyright (C) 1995 Free Software Foundation, Inc.
   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
  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.
  23
  24 ;;; Commentary:
  25
  26 ;;; Code:
  27
  28 (require 'gnus)
  29 (require gnus-easymenu)
  30
  31 ;;; summary highligts
  32
  33 (defvar gnus-summary-selected-face 'underline
  34   "*Face used for highlighting the current article in the summary buffer.")
  35
  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.
  42
  43 Point will be at the beginning of the line when FORM is evaluated.
  44 The following can be used for convenience:
  45
  46 score:   (gnus-summary-article-score)
  47 default: gnus-summary-default-score
  48 below:   gnus-summary-mark-below
  49
  50 To check for marks, e.g. to underline replied articles, use
  51 `gnus-summary-article-mark':
  52
  53    ((= (gnus-summary-article-mark) gnus-replied-mark) . underline)")
  54
  55 ;;; article highlights
  56
  57 (defvar gnus-make-foreground t
  58   "Non nil means foreground color to highlight citations.")
  59
  60 (defvar gnus-article-button-face 'bold
  61   "Face used for text buttons.")
  62
  63 (defvar gnus-article-mouse-face (if (boundp 'gnus-mouse-face)
  64                                     gnus-mouse-face
  65                                   'highlight)
  66   "Face used when the mouse is over the button.")
  67
  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.
  74
  75 The first non-nil NAME or CONTENT with a matching REGEXP in the list
  76 will be used.")
  77
  78 (defvar gnus-signature-face 'italic
  79   "Face used for signature.")
  80
  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
  90      gnus-button-url 0))
  91   "Alist of regexps matching buttons in an article.
  92
  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
  97 be added,
  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.
 100
 101 CALLBACK can also be a variable, in that case the value of that
 102 variable it the real callback function.")
 103
 104 (defvar gnus-button-url (cond ((fboundp 'w3-fetch)
 105                                'w3-fetch)
 106                               ((fboundp 'highlight-headers-follow-url-netscape)
 107                                'highlight-headers-follow-url-netscape)
 108                               (t nil))
 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:
 112
 113 w3-fetch:
 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.")
 117
 118 \f
 119
 120 (eval-and-compile
 121   (autoload 'nnkiboze-generate-groups "nnkiboze")
 122   (autoload 'gnus-cite-parse-maybe "gnus-cite" nil t))
 123
 124 ;;;
 125 ;;; gnus-menu
 126 ;;;
 127
 128 ;; Newsgroup buffer
 129
 130 (defun gnus-group-make-menu-bar ()
 131   (easy-menu-define
 132    gnus-group-reading-menu
 133    gnus-group-mode-map
 134    ""
 135    '("Group"
 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]
 149      ))
 150
 151   (easy-menu-define
 152    gnus-group-group-menu
 153    gnus-group-mode-map
 154    ""
 155    '("Groups"
 156      ("Listing"
 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])
 166      ("Mark"
 167       ["Mark group" gnus-group-mark-group t]
 168       ["Unmark group" gnus-group-unmark-group t]
 169       ["Mark region" gnus-group-mark-region t])
 170      ("Subscribe"
 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])
 174      ("Foreign groups"
 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 doc group" gnus-group-make-doc-group t]
 181       ["Make a kiboze group" gnus-group-make-kiboze-group t]
 182       ["Make a virtual group" gnus-group-make-empty-virtual t]
 183       ["Add a group to a virtual" gnus-group-add-to-virtual t])
 184      ["Read a directory as a group" gnus-group-enter-directory t]
 185      ["Jump to group" gnus-group-jump-to-group t]
 186      ["Best unread group" gnus-group-best-unread-group t]
 187      ))
 188
 189   (easy-menu-define
 190    gnus-group-post-menu
 191    gnus-group-mode-map
 192    ""
 193    '("Post"
 194      ["Send a mail" gnus-group-mail t]
 195      ["Post an article" gnus-group-post-news t]
 196      ))
 197
 198   (easy-menu-define
 199    gnus-group-misc-menu
 200    gnus-group-mode-map
 201    ""
 202    '("Misc"
 203      ["Send a bug report" gnus-bug t]
 204      ["Check for new news" gnus-group-get-new-news t]
 205      ["Delete bogus groups" gnus-group-check-bogus-groups t]
 206      ["Find new newsgroups" gnus-find-new-newsgroups t]
 207      ["Restart Gnus" gnus-group-restart t]
 208      ["Read init file" gnus-group-read-init-file t]
 209      ["Browse foreign server" gnus-group-browse-foreign-server t]
 210      ["Enter server buffer" gnus-group-enter-server-mode t]
 211      ["Edit the global kill file" gnus-group-edit-global-kill t]
 212      ["Expire all expirable articles" gnus-group-expire-all-groups t]
 213      ["Generate any kiboze groups" nnkiboze-generate-groups t]
 214      ["Gnus version" gnus-version t]
 215      ["Save .newsrc files" gnus-group-save-newsrc t]
 216      ["Suspend Gnus" gnus-group-suspend t]
 217      ["Clear dribble buffer" gnus-group-clear-dribble t]
 218      ["Exit from Gnus" gnus-group-exit t]
 219      ["Exit without saving" gnus-group-quit t]
 220      ["Sort group buffer" gnus-group-sort-groups t]
 221      ["Edit global KILL file" gnus-group-edit-global-kill t]
 222      ))
 223
 224   )
 225
 226 ;; Server mode
 227 (defun gnus-server-make-menu-bar ()
 228   (easy-menu-define
 229    gnus-server-menu
 230    gnus-server-mode-map
 231    ""
 232    '("Server"
 233      ["Add" gnus-server-add-server t]
 234      ["Browse" gnus-server-read-server t]
 235      ["List" gnus-server-list-servers t]
 236      ["Kill" gnus-server-kill-server t]
 237      ["Yank" gnus-server-yank-server t]
 238      ["Copy" gnus-server-copy-server t]
 239      ["Edit" gnus-server-edit-server t]
 240      ["Exit" gnus-server-exit t]
 241      )))
 242
 243 ;; Browse mode
 244 (defun gnus-browse-make-menu-bar ()
 245   (easy-menu-define
 246    gnus-browse-menu
 247    gnus-browse-mode-map
 248    ""
 249    '("Browse"
 250      ["Subscribe" gnus-browse-unsubscribe-current-group t]
 251      ["Read" gnus-group-read-group t]
 252      ["Exit" gnus-browse-exit t]
 253      )))
 254
 255 ;; Summary buffer
 256 (defun gnus-summary-make-menu-bar ()
 257
 258   (easy-menu-define
 259    gnus-summary-mark-menu
 260    gnus-summary-mode-map
 261    ""
 262    '("Mark"
 263      ("Read"
 264       ["Mark as read" gnus-summary-mark-as-read-forward t]
 265       ["Mark same subject and select" gnus-summary-kill-same-subject-and-select t]
 266       ["Mark same subject" gnus-summary-kill-same-subject t]
 267       ["Catchup" gnus-summary-catchup t]
 268       ["Catchup all" gnus-summary-catchup-all t]
 269       ["Catchup to here" gnus-summary-catchup-to-here t]
 270       ["Catchup region" gnus-summary-mark-region-as-read t])
 271      ("Various"
 272       ["Tick" gnus-summary-tick-article-forward t]
 273       ["Mark as dormant" gnus-summary-mark-as-dormant t]
 274       ["Remove marks" gnus-summary-clear-mark-forward t]
 275       ["Set expirable mark" gnus-summary-mark-as-expirable t]
 276       ["Set bookmark" gnus-summary-set-bookmark t]
 277       ["Remove bookmark" gnus-summary-remove-bookmark t])
 278      ("Display"
 279       ["Remove lines marked as read" gnus-summary-remove-lines-marked-as-read t]
 280       ["Remove lines marked with..." gnus-summary-remove-lines-marked-with t]
 281       ["Show dormant articles" gnus-summary-show-all-dormant t]
 282       ["Hide dormant articles" gnus-summary-hide-all-dormant t]
 283       ["Show expunged articles" gnus-summary-show-all-expunged t])
 284      ("Process mark"
 285       ["Set mark" gnus-summary-mark-as-processable t]
 286       ["Remove mark" gnus-summary-unmark-as-processable t]
 287       ["Remove all marks" gnus-summary-unmark-all-processable t]
 288       ["Mark series" gnus-uu-mark-series t]
 289       ["Mark region" gnus-uu-mark-region t]
 290       ["Mark by regexp" gnus-uu-mark-by-regexp t]
 291       ["Mark all" gnus-uu-mark-all t]
 292       ["Mark sparse" gnus-uu-mark-sparse t]
 293       ["Mark thread" gnus-uu-mark-thread t]
 294       )
 295      ))
 296
 297   (easy-menu-define
 298    gnus-summary-move-menu
 299    gnus-summary-mode-map
 300    ""
 301    '("Move"
 302      ["Scroll article forwards" gnus-summary-next-page t]
 303      ["Next unread article" gnus-summary-next-unread-article t]
 304      ["Previous unread article" gnus-summary-prev-unread-article t]
 305      ["Next article" gnus-summary-next-article t]
 306      ["Previous article" gnus-summary-prev-article t]
 307      ["Next article same subject" gnus-summary-next-same-subject t]
 308      ["Previous article same subject" gnus-summary-prev-same-subject t]
 309      ["First unread article" gnus-summary-first-unread-article t]
 310      ["Go to subject number..." gnus-summary-goto-subject t]
 311      ["Go to the last article" gnus-summary-goto-last-article t]
 312      ["Pop article off history" gnus-summary-pop-article t]
 313      ))
 314
 315   (easy-menu-define
 316    gnus-summary-article-menu
 317    gnus-summary-mode-map
 318    ""
 319    '("Article"
 320      ("Hide"
 321       ("Date"
 322        ["Local" gnus-article-date-local t]
 323        ["UT" gnus-article-date-local t]
 324        ["Lapsed" gnus-article-date-local t])
 325       ["Headers" gnus-article-hide-headers t]
 326       ["Signature" gnus-article-hide-signature t]
 327       ["Citation" gnus-article-hide-citation t]
 328       ["Overstrike" gnus-article-treat-overstrike t]
 329       ["Word wrap" gnus-article-word-wrap t]
 330       ["CR" gnus-article-remove-cr t]
 331       ["Show X-Face" gnus-article-display-x-face t]
 332       ["Quoted-Printable" gnus-article-de-quoted-unreadable t])
 333      ("Extract"
 334       ["Uudecode" gnus-uu-decode-uu t]
 335       ["Uudecode and save" gnus-uu-decode-uu-and-save t]
 336       ["Unshar" gnus-uu-decode-unshar t]
 337       ["Unshar and save" gnus-uu-decode-unshar-and-save t]
 338       ["Save" gnus-uu-decode-save t]
 339       ["Binhex" gnus-uu-decode-binhex t])
 340      ["Enter digest buffer" gnus-summary-enter-digest-group t]
 341      ["Isearch article" gnus-summary-isearch-article t]
 342      ["Search all articles" gnus-summary-search-article-forward t]
 343      ["Beginning of the article" gnus-summary-beginning-of-article t]
 344      ["End of the article" gnus-summary-end-of-article t]
 345      ["Fetch parent of article" gnus-summary-refer-parent-article t]
 346      ["Fetch article with id..." gnus-summary-refer-article t]
 347      ["Stop page breaking" gnus-summary-stop-page-breaking t]
 348      ["Caesar rotate" gnus-summary-caesar-message t]
 349      ["Redisplay" gnus-summary-show-article t]
 350      ["Toggle header" gnus-summary-toggle-header t]
 351      ["Toggle MIME" gnus-summary-toggle-mime t]
 352      ["Save" gnus-summary-save-article t]
 353      ["Save in mail format" gnus-summary-save-article-mail t]
 354      ["Pipe through a filter" gnus-summary-pipe-output t]
 355      ("Mail articles"
 356       ["Respool article" gnus-summary-respool-article t]
 357       ["Move article" gnus-summary-move-article t]
 358       ["Copy article" gnus-summary-copy-article t]
 359       ["Import file" gnus-summary-import-article t]
 360       ["Edit article" gnus-summary-edit-article t]
 361       ["Delete article" gnus-summary-delete-article t])
 362      ))
 363
 364   (easy-menu-define
 365    gnus-summary-thread-menu
 366    gnus-summary-mode-map
 367    ""
 368    '("Threads"
 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]
 379      ))
 380
 381   (easy-menu-define
 382    gnus-summary-misc-menu
 383    gnus-summary-mode-map
 384    ""
 385    '("Misc"
 386      ("Sort"
 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])
 392      ("Exit"
 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-exit-no-update 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]
 406      ))
 407
 408   (easy-menu-define
 409    gnus-summary-post-menu
 410    gnus-summary-mode-map
 411    ""
 412    '("Post"
 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]
 428      ))
 429
 430   (easy-menu-define
 431    gnus-summary-kill-menu
 432    gnus-summary-mode-map
 433    ""
 434    '("Score"
 435      ["Enter score" gnus-summary-score-entry t]
 436      ["Raise score" gnus-summary-increase-score t]
 437      ["Lower score" gnus-summary-lower-score t]
 438      ["Current score" gnus-summary-current-score t]
 439      ["Set score" gnus-summary-set-score t]
 440      ("Score file"
 441       ["Switch current score file" gnus-score-change-score-file t]
 442       ["Set mark below" gnus-score-set-mark-below t]
 443       ["Set expunge below" gnus-score-set-expunge-below t]
 444       ["Edit current score file" gnus-score-edit-alist t]
 445       ["Edit score file" gnus-score-edit-file t]
 446       ["Trace score" gnus-score-find-trace t])
 447      ))
 448   )
 449
 450 ;; Article buffer
 451 (defun gnus-article-make-menu-bar ()
 452
 453  (easy-menu-define
 454    gnus-article-article-menu
 455    gnus-article-mode-map
 456    ""
 457    '("Article"
 458      ["Scroll forwards" gnus-article-next-page t]
 459      ["Scroll backwards" gnus-article-prev-page t]
 460      ["Show summary" gnus-article-show-summary t]
 461      ["Fetch Message-ID at point" gnus-article-refer-article t]
 462      ["Mail to address at point" gnus-article-mail t]
 463      ["Mail to address at point and include original"
 464       gnus-article-mail-with-original t]
 465      ))
 466
 467  (easy-menu-define
 468    gnus-article-treatment-menu
 469    gnus-article-mode-map
 470    ""
 471    '("Treatment"
 472      ["Hide headers" gnus-article-hide-headers t]
 473      ["Hide signature" gnus-article-hide-signature t]
 474      ["Hide citation" gnus-article-hide-citation t]
 475      ["Treat overstrike" gnus-article-treat-overstrike t]
 476      ["Remove carriage return" gnus-article-remove-cr t]
 477      ["Remove quoted-unreadble" gnus-article-de-quoted-unreadable t]
 478      ))
 479  )
 480
 481 ;;;
 482 ;;; summary highlights
 483 ;;;
 484
 485 (defun gnus-highlight-selected-summary ()
 486   ;; Added by Per Abrahamsen <amanda@iesd.auc.dk>.
 487   ;; Highlight selected article in summary buffer
 488   (if gnus-summary-selected-face
 489       (save-excursion
 490         (let* ((beg (progn (beginning-of-line) (point)))
 491                (end (progn (end-of-line) (point)))
 492                ;; Fix by Mike Dugan <dugan@bucrf16.bu.edu>.
 493                (from (if (get-text-property beg 'mouse-face)
 494                          beg
 495                        (1+ (or (next-single-property-change
 496                                 beg 'mouse-face nil end)
 497                                beg))))
 498                (to (1- (or (next-single-property-change
 499                             from 'mouse-face nil end)
 500                            end))))
 501           ;; If no mouse-face prop on line (e.g. xemacs) we
 502           ;; will have to = from = end, so we highlight the
 503           ;; entire line instead.
 504           (if (= to from)
 505               (progn
 506                 (setq from beg)
 507                 (setq to end)))
 508           (if gnus-newsgroup-selected-overlay
 509               (move-overlay gnus-newsgroup-selected-overlay
 510                             from to (current-buffer))
 511             (setq gnus-newsgroup-selected-overlay (make-overlay from to))
 512             (overlay-put gnus-newsgroup-selected-overlay 'face
 513                          gnus-summary-selected-face))))))
 514
 515
 516 ;; New implementation by Christian Limpach <Christian.Limpach@nice.ch>.
 517 (defun gnus-summary-highlight-line ()
 518   "Highlight current line according to `gnus-summary-highlight'."
 519   (let* ((list gnus-summary-highlight)
 520          (p (point))
 521          (end (progn (end-of-line) (point)))
 522          ;; now find out where the line starts and leave point there.
 523          (beg (progn (beginning-of-line) (point)))
 524          (score (or (cdr (assq (or (get-text-property beg 'gnus-number)
 525                                    gnus-current-article)
 526                                gnus-newsgroup-scored))
 527                     gnus-summary-default-score 0))
 528          (default gnus-summary-default-score)
 529          (mark (get-text-property beg 'gnus-mark))
 530          (inhibit-read-only t))
 531     (while (and list (not (eval (car (car list)))))
 532       (setq list (cdr list)))
 533     (let ((face (and list (cdr (car list)))))
 534       ;; BUG! For some reason the text properties of the first
 535       ;; characters get mangled.
 536       (or (eobp)
 537           (eq face (get-text-property beg 'face))
 538           (put-text-property beg end 'face face)))
 539     (goto-char p)))
 540
 541 ;;;
 542 ;;; gnus-carpal
 543 ;;;
 544
 545 (defvar gnus-carpal-group-buffer-buttons
 546   '(("next" . gnus-group-next-unread-group)
 547     ("prev" . gnus-group-prev-unread-group)
 548     ("read" . gnus-group-read-group)
 549     ("select" . gnus-group-select-group)
 550     ("catch up" . gnus-group-catchup-current)
 551     ("new news" . gnus-group-get-new-news-this-group)
 552     ("toggle sub" . gnus-group-unsubscribe-current-group)
 553     ("subscribe" . gnus-group-unsubscribe-group)
 554     ("kill" . gnus-group-kill-group)
 555     ("yank" . gnus-group-yank-group)
 556     ("describe" . gnus-group-describe-group)
 557     "list"
 558     ("subscribed" . gnus-group-list-groups)
 559     ("all" . gnus-group-list-all-groups)
 560     ("killed" . gnus-group-list-killed)
 561     ("zombies" . gnus-group-list-zombies)
 562     ("matching" . gnus-group-list-matching)
 563     ("post" . gnus-group-post-news)
 564     ("mail" . gnus-group-mail)
 565     ("new news" . gnus-group-get-new-news)
 566     ("browse foreign" . gnus-group-browse-foreign)
 567     ("exit" . gnus-group-exit)))
 568
 569 (defvar gnus-carpal-summary-buffer-buttons
 570   '("mark"
 571     ("read" . gnus-summary-mark-as-read-forward)
 572     ("tick" . gnus-summary-tick-article-forward)
 573     ("clear" . gnus-summary-clear-mark-forward)
 574     ("expirable" . gnus-summary-mark-as-expirable)
 575     "move"
 576     ("scroll" . gnus-summary-next-page)
 577     ("next unread" . gnus-summary-next-unread-article)
 578     ("prev unread" . gnus-summary-prev-unread-article)
 579     ("first" . gnus-summary-first-unread-article)
 580     ("best" . gnus-summary-best-unread-article)
 581     "article"
 582     ("headers" . gnus-summary-toggle-header)
 583     ("uudecode" . gnus-uu-decode-uu)
 584     ("enter digest" . gnus-summary-enter-digest-group)
 585     ("fetch parent" . gnus-summary-refer-parent-article)
 586     "mail"
 587     ("move" . gnus-summary-move-article)
 588     ("copy" . gnus-summary-copy-article)
 589     ("respool" . gnus-summary-respool-article)
 590     "threads"
 591     ("lower" . gnus-summary-lower-thread)
 592     ("kill" . gnus-summary-kill-thread)
 593     "post"
 594     ("post" . gnus-summary-post-news)
 595     ("mail" . gnus-summary-mail)
 596     ("followup" . gnus-summary-followup-with-original)
 597     ("reply" . gnus-summary-reply-with-original)
 598     ("cancel" . gnus-summary-cancel-article)
 599     "misc"
 600     ("exit" . gnus-summary-exit)
 601     ("fed up" . gnus-summary-catchup-and-goto-next-group)))
 602
 603 (defvar gnus-carpal-server-buffer-buttons
 604   '(("add" . gnus-server-add-server)
 605     ("browse" . gnus-server-browse-server)
 606     ("list" . gnus-server-list-servers)
 607     ("kill" . gnus-server-kill-server)
 608     ("yank" . gnus-server-yank-server)
 609     ("copy" . gnus-server-copy-server)
 610     ("exit" . gnus-server-exit)))
 611
 612 (defvar gnus-carpal-browse-buffer-buttons
 613   '(("subscribe" . gnus-browse-unsubscribe-current-group)
 614     ("exit" . gnus-browse-exit)))
 615
 616 (defvar gnus-carpal-group-buffer "*Carpal Group*")
 617 (defvar gnus-carpal-summary-buffer "*Carpal Summary*")
 618 (defvar gnus-carpal-server-buffer "*Carpal Server*")
 619 (defvar gnus-carpal-browse-buffer "*Carpal Browse*")
 620
 621 (defvar gnus-carpal-attached-buffer nil)
 622
 623 (defvar gnus-carpal-mode-hook nil
 624   "*Hook run in carpal mode buffers.")
 625
 626 (defvar gnus-carpal-button-face 'bold
 627   "*Face used on carpal buttons.")
 628
 629 (defvar gnus-carpal-header-face 'bold-italic
 630   "*Face used on carpal buffer headers.")
 631
 632 (defvar gnus-carpal-mode-map nil)
 633 (put 'gnus-carpal-mode 'mode-class 'special)
 634
 635 (if gnus-carpal-mode-map
 636     nil
 637   (setq gnus-carpal-mode-map (make-keymap))
 638   (suppress-keymap gnus-carpal-mode-map)
 639   (define-key gnus-carpal-mode-map " " 'gnus-carpal-select)
 640   (define-key gnus-carpal-mode-map "\r" 'gnus-carpal-select)
 641   (define-key gnus-carpal-mode-map gnus-mouse-2 'gnus-carpal-mouse-select))
 642
 643 (defun gnus-carpal-mode ()
 644   "Major mode clicking buttons.
 645
 646 All normal editing commands are switched off.
 647 \\<gnus-carpal-mode-map>
 648 The following commands are available:
 649
 650 \\{gnus-carpal-mode-map}"
 651   (interactive)
 652   (kill-all-local-variables)
 653   (setq mode-line-modified "-- ")
 654   (setq major-mode 'gnus-carpal-mode)
 655   (setq mode-name "Gnus Carpal")
 656   (setq mode-line-process nil)
 657   (use-local-map gnus-carpal-mode-map)
 658   (buffer-disable-undo (current-buffer))
 659   (setq buffer-read-only t)
 660   (make-local-variable 'gnus-carpal-attached-buffer)
 661   (run-hooks 'gnus-carpal-mode-hook))
 662
 663 (defun gnus-carpal-setup-buffer (type)
 664   (let ((buffer (symbol-value (intern (format "gnus-carpal-%s-buffer" type)))))
 665     (if (get-buffer buffer)
 666         ()
 667       (save-excursion
 668         (set-buffer (get-buffer-create buffer))
 669         (gnus-carpal-mode)
 670         (setq gnus-carpal-attached-buffer
 671               (intern (format "gnus-%s-buffer" type)))
 672         (gnus-add-current-to-buffer-list)
 673         (let ((buttons (symbol-value
 674                         (intern (format "gnus-carpal-%s-buffer-buttons"
 675                                         type))))
 676               (buffer-read-only nil)
 677               button)
 678           (while buttons
 679             (setq button (car buttons)
 680                   buttons (cdr buttons))
 681             (if (stringp button)
 682                 (set-text-properties
 683                  (point)
 684                  (prog2 (insert button) (point) (insert " "))
 685                  (list 'face gnus-carpal-header-face))
 686               (set-text-properties
 687                (point)
 688                (prog2 (insert (car button)) (point) (insert " "))
 689                (list 'gnus-callback (cdr button)
 690                      'face gnus-carpal-button-face
 691                      'mouse-face 'highlight))))
 692           (let ((fill-column (- (window-width) 2)))
 693             (fill-region (point-min) (point-max)))
 694           (set-window-point (get-buffer-window (current-buffer))
 695                             (point-min)))))))
 696
 697 (defun gnus-carpal-select ()
 698   "Select the button under point."
 699   (interactive)
 700   (let ((func (get-text-property (point) 'gnus-callback)))
 701     (if (null func)
 702         ()
 703       (pop-to-buffer (symbol-value gnus-carpal-attached-buffer))
 704       (call-interactively func))))
 705
 706 (defun gnus-carpal-mouse-select (event)
 707   "Select the button under the mouse pointer."
 708   (interactive "e")
 709   (mouse-set-point event)
 710   (gnus-carpal-select))
 711
 712 ;;;
 713 ;;; article highlights
 714 ;;;
 715
 716 ;; Written by Per Abrahamsen <abraham@iesd.auc.dk>.
 717
 718 ;;; Internal Variables:
 719
 720 (defvar gnus-button-regexp nil)
 721 ;; Regexp matching any of the regexps from `gnus-button-alist'.
 722
 723 (defvar gnus-button-last nil)
 724 ;; The value of `gnus-button-alist' when `gnus-button-regexp' was build.
 725
 726 ;;; Commands:
 727
 728 (defun gnus-article-push-button (event)
 729   "Check text under the mouse pointer for a callback function.
 730 If the text under the mouse pointer has a `gnus-callback' property,
 731 call it with the value of the `gnus-data' text property."
 732   (interactive "e")
 733   (set-buffer (window-buffer (posn-window (event-start event))))
 734   (let* ((pos (posn-point (event-start event)))
 735          (data (get-text-property pos 'gnus-data))
 736          (fun (get-text-property pos 'gnus-callback)))
 737       (if fun (funcall fun data))))
 738
 739 (defun gnus-article-press-button ()
 740   "Check text at point for a callback function.
 741 If the text at point has a `gnus-callback' property,
 742 call it with the value of the `gnus-data' text property."
 743   (interactive)
 744   (let* ((data (get-text-property (point) 'gnus-data))
 745          (fun (get-text-property (point) 'gnus-callback)))
 746       (if fun (funcall fun data))))
 747
 748 ;; Suggested by Arne Elofsson <arne@hodgkin.mbi.ucla.edu>
 749 (defun gnus-article-next-button ()
 750   "Move point to next button."
 751   (interactive)
 752   (if (get-text-property (point) 'gnus-callback)
 753       (goto-char (next-single-property-change (point) 'gnus-callback
 754                                        nil (point-max))))
 755   (let ((pos (next-single-property-change (point) 'gnus-callback)))
 756     (if pos
 757         (goto-char pos)
 758       (setq pos (next-single-property-change (point-min) 'gnus-callback))
 759       (if pos
 760           (goto-char pos)
 761         (error "No buttons found")))))
 762
 763 (defun gnus-article-highlight ()
 764   "Highlight current article.
 765 This function calls `gnus-article-highlight-headers',
 766 `gnus-article-highlight-citation',
 767 `gnus-article-highlight-signature', and `gnus-article-add-buttons' to
 768 do the highlighting.  See the documentation for those functions."
 769   (interactive)
 770   (gnus-article-highlight-headers)
 771   (gnus-article-highlight-citation)
 772   (gnus-article-highlight-signature)
 773   (gnus-article-add-buttons))
 774
 775 (defun gnus-article-hide ()
 776   "Hide current article.
 777 This function calls `gnus-article-hide-headers',
 778 `gnus-article-hide-citation-maybe', and `gnus-article-hide-signature'
 779 to do the hiding.  See the documentation for those functions."
 780   (interactive)
 781   (gnus-article-hide-headers)
 782   (gnus-article-hide-citation-maybe)
 783   (gnus-article-hide-signature))
 784
 785 (defun gnus-article-highlight-headers ()
 786   "Highlight article headers as specified by `gnus-header-face-alist'."
 787   (interactive)
 788   (save-excursion
 789     (set-buffer gnus-article-buffer)
 790     (goto-char (point-min))
 791     (search-forward "\n\n")
 792     (beginning-of-line 0)
 793     (while (not (bobp))
 794       (let ((alist gnus-header-face-alist)
 795             (buffer-read-only nil)
 796             (case-fold-search t)
 797             (end (point))
 798             (inhibit-point-motion-hooks t)
 799             begin entry regexp header-face field-face header-found field-found)
 800         (re-search-backward "^[^ \t]" nil t)
 801         (setq begin (point))
 802         (while alist
 803           (setq entry (car alist)
 804                 regexp (nth 0 entry)
 805                 header-face (nth 1 entry)
 806                 field-face (nth 2 entry)
 807                 alist (cdr alist))
 808           (if (looking-at regexp)
 809               (let ((from (point)))
 810                 (skip-chars-forward "^:\n")
 811                 (and (not header-found)
 812                      header-face
 813                      (progn
 814                        (put-text-property  from (point) 'face header-face)
 815                        (setq header-found t)))
 816                 (and (not field-found)
 817                      field-face
 818                      (progn
 819                        (skip-chars-forward ": \t")
 820                        (let ((from (point)))
 821                          (goto-char end)
 822                          (skip-chars-backward " \t")
 823                          (put-text-property from (point) 'face field-face)
 824                          (setq field-found t))))))
 825           (goto-char begin))))))
 826
 827 (defun gnus-article-highlight-signature ()
 828   "Highlight the signature in an article.
 829 It does this by highlighting everything after
 830 `gnus-signature-separator' using `gnus-signature-face'."
 831   (interactive)
 832   (save-excursion
 833     (set-buffer gnus-article-buffer)
 834     (let ((buffer-read-only nil)
 835           (inhibit-point-motion-hooks t))
 836       (goto-char (point-max))
 837       (and (re-search-backward gnus-signature-separator nil t)
 838            gnus-signature-face
 839            (let ((start (match-beginning 0))
 840                  (end (match-end 0)))
 841              (gnus-article-add-button start end 'gnus-signature-toggle end)
 842              (overlay-put (make-overlay end (point-max))
 843                           'face gnus-signature-face))))))
 844
 845 (defun gnus-article-hide-signature ()
 846   "Hide the signature in an article.
 847 It does this by making everything after `gnus-signature-separator' invisible."
 848   (interactive)
 849   (save-excursion
 850     (set-buffer gnus-article-buffer)
 851     (let ((buffer-read-only nil))
 852       (goto-char (point-max))
 853       (and (re-search-backward gnus-signature-separator nil t)
 854            gnus-signature-face
 855            (add-text-properties (match-end 0) (point-max)
 856                                 gnus-hidden-properties)))))
 857
 858 (defun gnus-article-add-buttons ()
 859   "Find external references in article and make them to buttons.
 860
 861 External references are things like message-ids and URLs, as specified by
 862 `gnus-button-alist'."
 863   (interactive)
 864   (if (eq gnus-button-last gnus-button-alist)
 865       ()
 866     (setq gnus-button-regexp (mapconcat 'car gnus-button-alist  "\\|")
 867           gnus-button-last gnus-button-alist))
 868   (save-excursion
 869     (set-buffer gnus-article-buffer)
 870     (gnus-cite-parse-maybe)
 871     (let ((buffer-read-only nil)
 872           (inhibit-point-motion-hooks t)
 873           (case-fold-search t))
 874       (goto-char (point-min))
 875       (search-forward "\n\n")
 876       (while (re-search-forward gnus-button-regexp nil t)
 877         (goto-char (match-beginning 0))
 878         (let* ((from (point))
 879                (entry (gnus-button-entry))
 880                (start (and entry (match-beginning (nth 1 entry))))
 881                (end (and entry (match-end (nth 1 entry))))
 882                (form (nth 2 entry))
 883                marker)
 884           (if (not entry)
 885               ()
 886             (goto-char (match-end 0))
 887             (if (eval form)
 888                 (gnus-article-add-button start end 'gnus-button-push
 889                                          (set-marker (make-marker)
 890                                                      from)))))))))
 891
 892 ;;; External functions:
 893
 894 (defun gnus-article-add-button (from to fun &optional data)
 895   "Create a button between FROM and TO with callback FUN and data DATA."
 896   (add-text-properties from to
 897                        (append (if gnus-article-button-face
 898                                    (list 'face gnus-article-button-face))
 899                                (if gnus-article-mouse-face
 900                                    (list 'mouse-face gnus-article-mouse-face))
 901                                (list 'gnus-callback fun)
 902                                (if data (list 'gnus-data data)))))
 903
 904 ;;; Internal functions:
 905
 906 (defun gnus-signature-toggle (end)
 907   (save-excursion
 908     (set-buffer gnus-article-buffer)
 909     (let ((buffer-read-only nil))
 910       (if (get-text-property end 'invisible)
 911           (remove-text-properties end (point-max) gnus-hidden-properties)
 912         (add-text-properties end (point-max) gnus-hidden-properties)))))
 913
 914 (defun gnus-make-face (color)
 915   ;; Create entry for face with background COLOR.
 916   (let ((name (intern (concat "gnus " color))))
 917     (make-face name)
 918     (if gnus-make-foreground
 919         (set-face-foreground name color)
 920       (set-face-background name color))
 921     name))
 922
 923 (defun gnus-button-entry ()
 924   ;; Return the first entry in `gnus-button-alist' matching this place.
 925   (let ((alist gnus-button-alist)
 926         (entry nil))
 927     (while alist
 928       (setq entry (car alist)
 929             alist (cdr alist))
 930       (if (looking-at (car entry))
 931           (setq alist nil)
 932         (setq entry nil)))
 933     entry))
 934
 935 (defun gnus-button-push (marker)
 936   ;; Push button starting at MARKER.
 937   (save-excursion
 938     (set-buffer gnus-article-buffer)
 939     (goto-char marker)
 940     (let* ((entry (gnus-button-entry))
 941            (inhibit-point-motion-hooks t)
 942            (fun (nth 3 entry))
 943            (args (mapcar (lambda (group)
 944                            (let ((string (buffer-substring
 945                                           (match-beginning group)
 946                                           (match-end group))))
 947                            (set-text-properties 0 (length string) nil string)
 948                            string))
 949                          (nthcdr 4 entry))))
 950       (cond ((fboundp fun)
 951              (apply fun args))
 952             ((and (boundp fun)
 953                   (fboundp (symbol-value fun)))
 954              (apply (symbol-value fun) args))
 955             (t
 956              (message "You must define `%S' to use this button"
 957                       (cons fun args)))))))
 958
 959 (defun gnus-button-message-id (message-id)
 960   ;; Push on MESSAGE-ID.
 961   (save-excursion
 962     (set-buffer gnus-summary-buffer)
 963     (gnus-summary-refer-article message-id)))
 964
 965 ;;; Compatibility Functions:
 966
 967 (or (fboundp 'rassoc)
 968     ;; Introduced in Emacs 19.29.
 969     (defun rassoc (elt list)
 970       "Return non-nil if ELT is `equal' to the cdr of an element of LIST.
 971 The value is actually the element of LIST whose cdr is ELT."
 972       (let (result)
 973         (while list
 974           (setq result (car list))
 975           (if (equal (cdr result) elt)
 976               (setq list nil)
 977             (setq result nil
 978                   list (cdr list))))
 979         result)))
 980
 981 (provide 'gnus-vis)
 982
 983 ;;; gnus-vis.el ends here