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 (require 'custom)
  31 (require 'gnus-ems)
  32
  33 ;;; Summary highlights.
  34
  35 (defvar gnus-summary-selected-face 'underline
  36   "*Face used for highlighting the current article in the summary buffer.")
  37
  38 (defvar gnus-summary-highlight
  39   (cond ((not (eq gnus-display-type 'color))
  40          '(((> score default) . bold)
  41            ((< score default) . italic)))
  42         ((eq gnus-background-mode 'dark)
  43          (list (cons '(= mark gnus-canceled-mark)
  44                      (custom-face-lookup "yellow" "black" nil nil nil nil))
  45                (cons '(and (> score default)
  46                            (or (= mark gnus-dormant-mark)
  47                                (= mark gnus-ticked-mark)))
  48                      (custom-face-lookup "pink" nil nil t nil nil))
  49                (cons '(and (< score default)
  50                            (or (= mark gnus-dormant-mark)
  51                                (= mark gnus-ticked-mark)))
  52                      (custom-face-lookup "pink" nil nil nil t nil))
  53                (cons '(or (= mark gnus-dormant-mark)
  54                           (= mark gnus-ticked-mark))
  55                      (custom-face-lookup "pink" nil nil nil nil nil))
  56
  57                (cons '(and (> score default) (= mark gnus-ancient-mark))
  58                      (custom-face-lookup "SkyBlue" nil nil t nil nil))
  59                (cons '(and (< score default) (= mark gnus-ancient-mark))
  60                      (custom-face-lookup "SkyBlue" nil nil nil t nil))
  61                (cons '(= mark gnus-ancient-mark)
  62                      (custom-face-lookup "SkyBlue" nil nil nil nil nil))
  63
  64                (cons '(and (> score default) (= mark gnus-unread-mark))
  65                      (custom-face-lookup "green" nil nil t nil nil))
  66                (cons '(and (< score default) (= mark gnus-unread-mark))
  67                      (custom-face-lookup "green" nil nil nil t nil))
  68                (cons '(= mark gnus-unread-mark)
  69                      (custom-face-lookup "green" nil nil nil nil nil))
  70
  71                (cons '(> score default) 'bold)
  72                (cons '(< score default) 'italic)))
  73         (t
  74          (list (cons '(= mark gnus-canceled-mark)
  75                      (custom-face-lookup "yellow" "black" nil nil nil nil))
  76                (cons '(and (> score default)
  77                            (or (= mark gnus-dormant-mark)
  78                                (= mark gnus-ticked-mark)))
  79                      (custom-face-lookup "firebrick" nil nil t nil nil))
  80                (cons '(and (< score default)
  81                            (or (= mark gnus-dormant-mark)
  82                                (= mark gnus-ticked-mark)))
  83                      (custom-face-lookup "firebrick" nil nil nil t nil))
  84                (cons '(or (= mark gnus-dormant-mark)
  85                           (= mark gnus-ticked-mark))
  86                      (custom-face-lookup "firebrick" nil nil nil nil nil))
  87
  88                (cons '(and (> score default) (= mark gnus-ancient-mark))
  89                      (custom-face-lookup "RoyalBlue" nil nil t nil nil))
  90                (cons '(and (< score default) (= mark gnus-ancient-mark))
  91                      (custom-face-lookup "RoyalBlue" nil nil nil t nil))
  92                (cons '(= mark gnus-ancient-mark)
  93                      (custom-face-lookup "RoyalBlue" nil nil nil nil nil))
  94
  95                (cons '(and (> score default) (= mark gnus-unread-mark))
  96                      (custom-face-lookup "DarkGreen" nil nil t nil nil))
  97                (cons '(and (< score default) (= mark gnus-unread-mark))
  98                      (custom-face-lookup "DarkGreen" nil nil nil t nil))
  99                (cons '(= mark gnus-unread-mark)
 100                      (custom-face-lookup "DarkGreen" nil nil nil nil nil))
 101
 102                (cons '(> score default) 'bold)
 103                (cons '(< score default) 'italic))))
 104   "*Alist of `(FORM . FACE)'.
 105 Summary lines are highlighted with the FACE for the first FORM which
 106 evaluate to a non-nil value.
 107
 108 Point will be at the beginning of the line when FORM is evaluated.
 109 The following can be used for convenience:
 110
 111 score:   (gnus-summary-article-score)
 112 default: gnus-summary-default-score
 113 below:   gnus-summary-mark-below
 114 mark:    (gnus-summary-article-mark)
 115
 116 The latter can be used like this:
 117    ((= mark gnus-replied-mark) . underline)")
 118
 119 ;;; article highlights
 120
 121 (defvar gnus-header-face-alist
 122   (cond ((not (eq gnus-display-type 'color))
 123          '(("" bold italic)))
 124         ((eq gnus-background-mode 'dark)
 125          (list (list "From" nil
 126                      (custom-face-lookup "SkyeBlue" nil nil t t nil))
 127                (list "Subject" nil
 128                      (custom-face-lookup "pink" nil nil t t nil))
 129                (list "Newsgroups:.*," nil
 130                      (custom-face-lookup "yellow" nil nil t t nil))
 131                (list ""
 132                      (custom-face-lookup "cyan" nil nil t nil nil)
 133                      (custom-face-lookup "green" nil nil nil t nil))))
 134         (t
 135          (list (list "From" nil
 136                      (custom-face-lookup "RoyalBlue" nil nil t t nil))
 137                (list "Subject" nil
 138                      (custom-face-lookup "firebrick" nil nil t t nil))
 139                (list "Newsgroups:.*," nil
 140                      (custom-face-lookup "dark orange" nil nil t t nil))
 141                (list ""
 142                      (custom-face-lookup "purple" nil nil t nil nil)
 143                      (custom-face-lookup "DarkGreen" nil nil nil t nil)))))
 144   "Alist of headers and faces used for highlighting them.
 145 The entries in the list has the form `(REGEXP NAME CONTENT)', where
 146 REGEXP is a regular expression matching the beginning of the header,
 147 NAME is the face used for highlighting the header name and CONTENT is
 148 the face used for highlighting the header content.
 149
 150 The first non-nil NAME or CONTENT with a matching REGEXP in the list
 151 will be used.")
 152
 153
 154 (defvar gnus-make-foreground t
 155   "Non nil means foreground color to highlight citations.")
 156
 157 (defvar gnus-article-button-face 'bold
 158   "Face used for text buttons.")
 159
 160 (defvar gnus-article-mouse-face (if (boundp 'gnus-mouse-face)
 161                                     gnus-mouse-face
 162                                   'highlight)
 163   "Face used when the mouse is over the button.")
 164
 165 (defvar gnus-signature-face 'italic
 166   "Face used for signature.")
 167
 168 (defvar gnus-button-alist
 169   '(("in\\( +article\\)? +\\(<\\([^\n @<>]+@[^\n @<>]+\\)>\\)" 2
 170      (assq (count-lines (point-min) (match-end 0))
 171            gnus-cite-attribution-alist)
 172      gnus-button-message-id 3)
 173     ;; This is how URLs _should_ be embedded in text...
 174     ("<URL:\\([^\n\r>]*\\)>" 0 t gnus-button-url 1)
 175     ;; Next regexp stolen from highlight-headers.el
 176     ("\\b\\(s?https?\\|ftp\\|file\\|gopher\\|news\\|telnet\\):\\(//[-a-zA-Z0-9_.]+:[0-9]*\\)?[-a-zA-Z0-9_=?#$@~`%&*+|\\/.,]+" 0 t
 177      gnus-button-url 0))
 178   "Alist of regexps matching buttons in an article.
 179
 180 Each entry has the form (REGEXP BUTTON FORM CALLBACK PAR...), where
 181 REGEXP: is the string matching text around the button,
 182 BUTTON: is the number of the regexp grouping actually matching the button,
 183 FORM: is a lisp expression which must eval to true for the button to
 184 be added,
 185 CALLBACK: is the function to call when the user push this button, and each
 186 PAR: is a number of a regexp grouping whose text will be passed to CALLBACK.
 187
 188 CALLBACK can also be a variable, in that case the value of that
 189 variable it the real callback function.")
 190
 191 (defvar gnus-button-url 'gnus-netscape-open-url
 192   "Function to fetch URL.
 193 The function will be called with one argument, the URL to fetch.
 194 Useful values of this function are:
 195
 196 w3-fetch:
 197    defined in the w3 emacs package by William M. Perry.
 198 gnus-netscape-open-url:
 199    open url in existing netscape, start netscape if none found.
 200 gnus-netscape-start-url:
 201    start new netscape with url.")
 202
 203 \f
 204
 205 (eval-and-compile
 206   (autoload 'nnkiboze-generate-groups "nnkiboze")
 207   (autoload 'gnus-cite-parse-maybe "gnus-cite" nil t))
 208
 209 ;;;
 210 ;;; gnus-menu
 211 ;;;
 212
 213 (defun gnus-visual-turn-off-edit-menu (type)
 214   (define-key (symbol-value (intern (format "gnus-%s-mode-map" type)))
 215     [menu-bar edit] 'undefined))
 216
 217 ;; Newsgroup buffer
 218
 219 (defun gnus-group-make-menu-bar ()
 220   (gnus-visual-turn-off-edit-menu 'group)
 221   (or
 222    (boundp 'gnus-group-reading-menu)
 223    (progn
 224      (easy-menu-define
 225       gnus-group-reading-menu
 226       gnus-group-mode-map
 227       ""
 228       '("Group"
 229         ["Read" gnus-group-read-group t]
 230         ["Select" gnus-group-select-group t]
 231         ["Catch up" gnus-group-catchup-current t]
 232         ["Catch up all articles" gnus-group-catchup-current-all t]
 233         ["Check for new articles" gnus-group-get-new-news-this-group t]
 234         ["Toggle subscription" gnus-group-unsubscribe-current-group t]
 235         ["Kill" gnus-group-kill-group t]
 236         ["Yank" gnus-group-yank-group t]
 237         ["Describe" gnus-group-describe-group t]
 238         ["Fetch FAQ" gnus-group-fetch-faq t]
 239         ["Edit kill file" gnus-group-edit-local-kill t]
 240         ["Expire articles" gnus-group-expire-articles t]
 241         ["Set group level" gnus-group-set-current-level t]
 242         ))
 243
 244      (easy-menu-define
 245       gnus-group-group-menu
 246       gnus-group-mode-map
 247       ""
 248       '("Groups"
 249         ("Listing"
 250          ["List subscribed groups" gnus-group-list-groups t]
 251          ["List all groups" gnus-group-list-all-groups t]
 252          ["List groups matching..." gnus-group-list-matching t]
 253          ["List killed groups" gnus-group-list-killed t]
 254          ["List zombie groups" gnus-group-list-zombies t]
 255          ["Describe all groups" gnus-group-describe-all-groups t]
 256          ["Group apropos" gnus-group-apropos t]
 257          ["Group and description apropos" gnus-group-description-apropos t]
 258          ["List groups matching..." gnus-group-list-matching t])
 259         ("Mark"
 260          ["Mark group" gnus-group-mark-group t]
 261          ["Unmark group" gnus-group-unmark-group t]
 262          ["Mark region" gnus-group-mark-region t])
 263         ("Subscribe"
 264          ["Subscribe to random group" gnus-group-unsubscribe-group t]
 265          ["Kill all newsgroups in region" gnus-group-kill-region t]
 266          ["Kill all zombie groups" gnus-group-kill-all-zombies t])
 267         ("Foreign groups"
 268          ["Make a foreign group" gnus-group-make-group t]
 269          ["Edit a group entry" gnus-group-edit-group t]
 270          ["Add a directory group" gnus-group-make-directory-group t]
 271          ["Add the help group" gnus-group-make-help-group t]
 272          ["Add the archive group" gnus-group-make-archive-group t]
 273          ["Make a doc group" gnus-group-make-doc-group t]
 274          ["Make a kiboze group" gnus-group-make-kiboze-group t]
 275          ["Make a virtual group" gnus-group-make-empty-virtual t]
 276          ["Add a group to a virtual" gnus-group-add-to-virtual t])
 277         ["Read a directory as a group" gnus-group-enter-directory t]
 278         ["Jump to group" gnus-group-jump-to-group t]
 279         ["Best unread group" gnus-group-best-unread-group t]
 280         ))
 281
 282      (easy-menu-define
 283       gnus-group-post-menu
 284       gnus-group-mode-map
 285       ""
 286       '("Post"
 287         ["Send a mail" gnus-group-mail t]
 288         ["Post an article" gnus-group-post-news t]
 289         ))
 290
 291      (easy-menu-define
 292       gnus-group-misc-menu
 293       gnus-group-mode-map
 294       ""
 295       '("Misc"
 296         ["Send a bug report" gnus-bug t]
 297         ["Check for new news" gnus-group-get-new-news t]
 298         ["Delete bogus groups" gnus-group-check-bogus-groups t]
 299         ["Find new newsgroups" gnus-find-new-newsgroups t]
 300         ["Restart Gnus" gnus-group-restart t]
 301         ["Read init file" gnus-group-read-init-file t]
 302         ["Browse foreign server" gnus-group-browse-foreign-server t]
 303         ["Enter server buffer" gnus-group-enter-server-mode t]
 304         ["Expire expirable articles" gnus-group-expire-all-groups t]
 305         ["Generate any kiboze groups" nnkiboze-generate-groups t]
 306         ["Gnus version" gnus-version t]
 307         ["Save .newsrc files" gnus-group-save-newsrc t]
 308         ["Suspend Gnus" gnus-group-suspend t]
 309         ["Clear dribble buffer" gnus-group-clear-dribble t]
 310         ["Exit from Gnus" gnus-group-exit t]
 311         ["Exit without saving" gnus-group-quit t]
 312         ["Edit global kill file" gnus-group-edit-global-kill t]
 313         ["Sort group buffer" gnus-group-sort-groups t]
 314         ))
 315      )))
 316
 317 ;; Server mode
 318 (defun gnus-server-make-menu-bar ()
 319   (gnus-visual-turn-off-edit-menu 'server)
 320   (or
 321    (boundp 'gnus-server-menu)
 322    (easy-menu-define
 323     gnus-server-menu
 324     gnus-server-mode-map
 325     ""
 326     '("Server"
 327       ["Add" gnus-server-add-server t]
 328       ["Browse" gnus-server-read-server t]
 329       ["List" gnus-server-list-servers t]
 330       ["Kill" gnus-server-kill-server t]
 331       ["Yank" gnus-server-yank-server t]
 332       ["Copy" gnus-server-copy-server t]
 333       ["Edit" gnus-server-edit-server t]
 334       ["Exit" gnus-server-exit t]
 335       ))))
 336
 337 ;; Browse mode
 338 (defun gnus-browse-make-menu-bar ()
 339   (gnus-visual-turn-off-edit-menu 'browse)
 340   (or
 341    (boundp 'gnus-browse-menu)
 342    (easy-menu-define
 343     gnus-browse-menu
 344     gnus-browse-mode-map
 345     ""
 346     '("Browse"
 347       ["Subscribe" gnus-browse-unsubscribe-current-group t]
 348       ["Read" gnus-group-read-group t]
 349       ["Exit" gnus-browse-exit t]
 350       ))))
 351
 352 ;; Summary buffer
 353 (defun gnus-summary-make-menu-bar ()
 354   (gnus-visual-turn-off-edit-menu 'summary)
 355
 356   (or
 357    (boundp 'gnus-summary-mark-menu)
 358    (progn
 359      (easy-menu-define
 360       gnus-summary-mark-menu
 361       gnus-summary-mode-map
 362       ""
 363       '("Mark"
 364         ("Read"
 365          ["Mark as read" gnus-summary-mark-as-read-forward t]
 366          ["Mark same subject and select" gnus-summary-kill-same-subject-and-select t]
 367          ["Mark same subject" gnus-summary-kill-same-subject t]
 368          ["Catchup" gnus-summary-catchup t]
 369          ["Catchup all" gnus-summary-catchup-all t]
 370          ["Catchup to here" gnus-summary-catchup-to-here t]
 371          ["Catchup region" gnus-summary-mark-region-as-read t])
 372         ("Various"
 373          ["Tick" gnus-summary-tick-article-forward t]
 374          ["Mark as dormant" gnus-summary-mark-as-dormant t]
 375          ["Remove marks" gnus-summary-clear-mark-forward t]
 376          ["Set expirable mark" gnus-summary-mark-as-expirable t]
 377          ["Set bookmark" gnus-summary-set-bookmark t]
 378          ["Remove bookmark" gnus-summary-remove-bookmark t])
 379         ("Display"
 380          ["Remove lines marked as read" gnus-summary-remove-lines-marked-as-read t]
 381          ["Remove lines marked with..." gnus-summary-remove-lines-marked-with t]
 382          ["Show dormant articles" gnus-summary-show-all-dormant t]
 383          ["Hide dormant articles" gnus-summary-hide-all-dormant t]
 384          ["Show expunged articles" gnus-summary-show-all-expunged t])
 385         ("Process mark"
 386          ["Set mark" gnus-summary-mark-as-processable t]
 387          ["Remove mark" gnus-summary-unmark-as-processable t]
 388          ["Remove all marks" gnus-summary-unmark-all-processable t]
 389          ["Mark series" gnus-uu-mark-series t]
 390          ["Mark region" gnus-uu-mark-region t]
 391          ["Mark by regexp" gnus-uu-mark-by-regexp t]
 392          ["Mark all" gnus-uu-mark-all t]
 393          ["Mark sparse" gnus-uu-mark-sparse t]
 394          ["Mark thread" gnus-uu-mark-thread t]
 395          )
 396         ))
 397
 398      (easy-menu-define
 399       gnus-summary-move-menu
 400       gnus-summary-mode-map
 401       ""
 402       '("Move"
 403         ["Scroll article forwards" gnus-summary-next-page t]
 404         ["Next unread article" gnus-summary-next-unread-article t]
 405         ["Previous unread article" gnus-summary-prev-unread-article t]
 406         ["Next article" gnus-summary-next-article t]
 407         ["Previous article" gnus-summary-prev-article t]
 408         ["Next article same subject" gnus-summary-next-same-subject t]
 409         ["Previous article same subject" gnus-summary-prev-same-subject t]
 410         ["First unread article" gnus-summary-first-unread-article t]
 411         ["Go to subject number..." gnus-summary-goto-subject t]
 412         ["Go to the last article" gnus-summary-goto-last-article t]
 413         ["Pop article off history" gnus-summary-pop-article t]
 414         ))
 415
 416      (easy-menu-define
 417       gnus-summary-article-menu
 418       gnus-summary-mode-map
 419       ""
 420       '("Article"
 421         ("Hide"
 422          ("Date"
 423           ["Local" gnus-article-date-local t]
 424           ["UT" gnus-article-date-local t]
 425           ["Lapsed" gnus-article-date-local t])
 426          ["Headers" gnus-article-hide-headers t]
 427          ["Signature" gnus-article-hide-signature t]
 428          ["Citation" gnus-article-hide-citation t]
 429          ["Overstrike" gnus-article-treat-overstrike t]
 430          ["Word wrap" gnus-article-word-wrap t]
 431          ["CR" gnus-article-remove-cr t]
 432          ["Show X-Face" gnus-article-display-x-face t]
 433          ["Quoted-Printable" gnus-article-de-quoted-unreadable t])
 434         ("Extract"
 435          ["Uudecode" gnus-uu-decode-uu t]
 436          ["Uudecode and save" gnus-uu-decode-uu-and-save t]
 437          ["Unshar" gnus-uu-decode-unshar t]
 438          ["Unshar and save" gnus-uu-decode-unshar-and-save t]
 439          ["Save" gnus-uu-decode-save t]
 440          ["Binhex" gnus-uu-decode-binhex t])
 441         ["Enter digest buffer" gnus-summary-enter-digest-group t]
 442         ["Isearch article" gnus-summary-isearch-article t]
 443         ["Search all articles" gnus-summary-search-article-forward t]
 444         ["Beginning of the article" gnus-summary-beginning-of-article t]
 445         ["End of the article" gnus-summary-end-of-article t]
 446         ["Fetch parent of article" gnus-summary-refer-parent-article t]
 447         ["Fetch article with id..." gnus-summary-refer-article t]
 448         ["Stop page breaking" gnus-summary-stop-page-breaking t]
 449         ["Rot 13" gnus-summary-caesar-message t]
 450         ["Redisplay" gnus-summary-show-article t]
 451         ["Toggle header" gnus-summary-toggle-header t]
 452         ["Toggle MIME" gnus-summary-toggle-mime t]
 453         ["Save" gnus-summary-save-article t]
 454         ["Save in mail format" gnus-summary-save-article-mail t]
 455         ["Pipe through a filter" gnus-summary-pipe-output t]
 456         ("Mail articles"
 457          ["Respool article" gnus-summary-respool-article t]
 458          ["Move article" gnus-summary-move-article t]
 459          ["Copy article" gnus-summary-copy-article t]
 460          ["Import file" gnus-summary-import-article t]
 461          ["Edit article" gnus-summary-edit-article t]
 462          ["Delete article" gnus-summary-delete-article t])
 463         ))
 464
 465      (easy-menu-define
 466       gnus-summary-thread-menu
 467       gnus-summary-mode-map
 468       ""
 469       '("Threads"
 470         ["Toggle threading" gnus-summary-toggle-threads t]
 471         ["Display hidden thread" gnus-summary-show-thread t]
 472         ["Hide thread" gnus-summary-hide-thread t]
 473         ["Go to next thread" gnus-summary-next-thread t]
 474         ["Go to previous thread" gnus-summary-prev-thread t]
 475         ["Go down thread" gnus-summary-down-thread t]
 476         ["Go up thread" gnus-summary-up-thread t]
 477         ["Mark thread as read" gnus-summary-kill-thread t]
 478         ["Lower thread score" gnus-summary-lower-thread t]
 479         ["Raise thread score" gnus-summary-raise-thread t]
 480         ))
 481
 482      (easy-menu-define
 483       gnus-summary-misc-menu
 484       gnus-summary-mode-map
 485       ""
 486       '("Misc"
 487         ("Sort"
 488          ["Sort by number" gnus-summary-sort-by-number t]
 489          ["Sort by author" gnus-summary-sort-by-author t]
 490          ["Sort by subject" gnus-summary-sort-by-subject t]
 491          ["Sort by date" gnus-summary-sort-by-date t]
 492          ["Sort by score" gnus-summary-sort-by-score t])
 493         ("Exit"
 494          ["Catchup and exit" gnus-summary-catchup-and-exit t]
 495          ["Catchup and goto next" gnus-summary-catchup-and-goto-next-group t]
 496          ["Exit group" gnus-summary-exit t]
 497          ["Exit group without updating" gnus-summary-exit-no-update t]
 498          ["Reselect group" gnus-summary-reselect-current-group t]
 499          ["Rescan group" gnus-summary-rescan-group t])
 500         ["Fetch group FAQ" gnus-summary-fetch-faq t]
 501         ["Filter articles" gnus-summary-execute-command t]
 502         ["Toggle line truncation" gnus-summary-toggle-truncation t]
 503         ["Expire expirable articles" gnus-summary-expire-articles t]
 504         ["Describe group" gnus-summary-describe-group t]
 505         ["Edit local kill file" gnus-summary-edit-local-kill t]
 506         ))
 507
 508      (easy-menu-define
 509       gnus-summary-post-menu
 510       gnus-summary-mode-map
 511       ""
 512       '("Post"
 513         ["Post an article" gnus-summary-post-news t]
 514         ["Followup" gnus-summary-followup t]
 515         ["Followup and yank" gnus-summary-followup-with-original t]
 516         ["Supersede article" gnus-summary-supersede-article t]
 517         ["Cancel article" gnus-summary-cancel-article t]
 518         ["Reply" gnus-summary-reply t]
 519         ["Reply and yank" gnus-summary-reply-with-original t]
 520         ["Mail forward" gnus-summary-mail-forward t]
 521         ["Post forward" gnus-summary-post-forward t]
 522         ["Digest and mail" gnus-uu-digest-mail-forward t]
 523         ["Digest and post" gnus-uu-digest-post-forward t]
 524         ["Send a mail" gnus-summary-mail-other-window t]
 525         ["Reply & followup" gnus-summary-followup-and-reply t]
 526         ["Reply & followup and yank" gnus-summary-followup-and-reply-with-original t]
 527         ["Uuencode and post" gnus-uu-post-news t]
 528         ))
 529
 530      (easy-menu-define
 531       gnus-summary-kill-menu
 532       gnus-summary-mode-map
 533       ""
 534       (cons
 535        "Score"
 536        (nconc
 537         (list
 538          ["Enter score" gnus-summary-score-entry t])
 539         (gnus-visual-score-map 'increase)
 540         (gnus-visual-score-map 'lower)
 541         '(["Current score" gnus-summary-current-score t]
 542           ["Set score" gnus-summary-set-score t]
 543           ("Score file"
 544            ["Customize score file" gnus-score-customize t]
 545            ["Switch current score file" gnus-score-change-score-file t]
 546            ["Set mark below" gnus-score-set-mark-below t]
 547            ["Set expunge below" gnus-score-set-expunge-below t]
 548            ["Edit current score file" gnus-score-edit-alist t]
 549            ["Edit score file" gnus-score-edit-file t]
 550            ["Trace score" gnus-score-find-trace t])
 551           ))))
 552      )))
 553
 554 (defun gnus-visual-score-map (type)
 555   (if t
 556       nil
 557     (let ((headers '(("author" "from" string)
 558                      ("subject" "subject" string)
 559                      ("article body" "body" string)
 560                      ("article head" "head" string)
 561                      ("xref" "xref" string)
 562                      ("lines" "lines" number)
 563                      ("followups to author" "followup" string)))
 564           (types '((number ("less than" <)
 565                            ("greater than" >)
 566                            ("equal" =))
 567                    (string ("substring" s)
 568                            ("exact string" e)
 569                            ("fuzzy string" f)
 570                            ("regexp" r))))
 571           (perms '(("temporary" (current-time-string))
 572                    ("permanent" nil)
 573                    ("immediate" now)))
 574           header)
 575       (list
 576        (apply
 577         'nconc
 578         (list
 579          (if (eq type 'lower)
 580              "Lower score"
 581            "Increase score"))
 582         (let (outh)
 583           (while headers
 584             (setq header (car headers))
 585             (setq outh
 586                   (cons
 587                    (apply
 588                     'nconc
 589                     (list (car header))
 590                     (let ((ts (cdr (assoc (nth 2 header) types)))
 591                           outt)
 592                       (while ts
 593                         (setq outt
 594                               (cons
 595                                (apply
 596                                 'nconc
 597                                 (list (car (car ts)))
 598                                 (let ((ps perms)
 599                                       outp)
 600                                   (while ps
 601                                     (setq outp
 602                                           (cons
 603                                            (vector
 604                                             (car (car ps))
 605                                             (list
 606                                              'gnus-summary-score-entry
 607                                              (nth 1 header)
 608                                              (if (or (string= (nth 1 header)
 609                                                               "head")
 610                                                      (string= (nth 1 header)
 611                                                               "body"))
 612                                                  ""
 613                                                (list 'gnus-summary-header
 614                                                      (nth 1 header)))
 615                                              (list 'quote (nth 1 (car ts)))
 616                                              (list 'gnus-score-default nil)
 617                                              (nth 1 (car ps))
 618                                              t)
 619                                             t)
 620                                            outp))
 621                                     (setq ps (cdr ps)))
 622                                   (list (nreverse outp))))
 623                                outt))
 624                         (setq ts (cdr ts)))
 625                       (list (nreverse outt))))
 626                    outh))
 627             (setq headers (cdr headers)))
 628           (list (nreverse outh))))))))
 629
 630 ;; Article buffer
 631 (defun gnus-article-make-menu-bar ()
 632   (gnus-visual-turn-off-edit-menu 'summary)
 633   (or
 634    (boundp 'gnus-article-article-menu)
 635    (progn
 636      (easy-menu-define
 637       gnus-article-article-menu
 638       gnus-article-mode-map
 639       ""
 640       '("Article"
 641         ["Scroll forwards" gnus-article-next-page t]
 642         ["Scroll backwards" gnus-article-prev-page t]
 643         ["Show summary" gnus-article-show-summary t]
 644         ["Fetch Message-ID at point" gnus-article-refer-article t]
 645         ["Mail to address at point" gnus-article-mail t]
 646         ["Mail to address at point and include original"
 647          gnus-article-mail-with-original t]
 648         ))
 649
 650      (easy-menu-define
 651       gnus-article-treatment-menu
 652       gnus-article-mode-map
 653       ""
 654       '("Treatment"
 655         ["Hide headers" gnus-article-hide-headers t]
 656         ["Hide signature" gnus-article-hide-signature t]
 657         ["Hide citation" gnus-article-hide-citation t]
 658         ["Treat overstrike" gnus-article-treat-overstrike t]
 659         ["Remove carriage return" gnus-article-remove-cr t]
 660         ["Remove quoted-unreadable" gnus-article-de-quoted-unreadable t]
 661         ))
 662      )))
 663
 664 ;;;
 665 ;;; summary highlights
 666 ;;;
 667
 668 (defun gnus-highlight-selected-summary ()
 669   ;; Added by Per Abrahamsen <amanda@iesd.auc.dk>.
 670   ;; Highlight selected article in summary buffer
 671   (if gnus-summary-selected-face
 672       (save-excursion
 673         (let* ((beg (progn (beginning-of-line) (point)))
 674                (end (progn (end-of-line) (point)))
 675                ;; Fix by Mike Dugan <dugan@bucrf16.bu.edu>.
 676                (from (if (get-text-property beg 'mouse-face)
 677                          beg
 678                        (1+ (or (next-single-property-change
 679                                 beg 'mouse-face nil end)
 680                                beg))))
 681                (to (1- (or (next-single-property-change
 682                             from 'mouse-face nil end)
 683                            end))))
 684           ;; If no mouse-face prop on line (e.g. xemacs) we
 685           ;; will have to = from = end, so we highlight the
 686           ;; entire line instead.
 687           (if (= to from)
 688               (progn
 689                 (setq from beg)
 690                 (setq to end)))
 691           (if gnus-newsgroup-selected-overlay
 692               (move-overlay gnus-newsgroup-selected-overlay
 693                             from to (current-buffer))
 694             (setq gnus-newsgroup-selected-overlay (make-overlay from to))
 695             (overlay-put gnus-newsgroup-selected-overlay 'face
 696                          gnus-summary-selected-face))))))
 697
 698 ;; New implementation by Christian Limpach <Christian.Limpach@nice.ch>.
 699 (defun gnus-summary-highlight-line ()
 700   "Highlight current line according to `gnus-summary-highlight'."
 701   (let* ((list gnus-summary-highlight)
 702          (p (point))
 703          (end (progn (end-of-line) (point)))
 704          ;; now find out where the line starts and leave point there.
 705          (beg (progn (beginning-of-line) (point)))
 706          (score (or (cdr (assq (or (get-text-property beg 'gnus-number)
 707                                    gnus-current-article)
 708                                gnus-newsgroup-scored))
 709                     gnus-summary-default-score 0))
 710          (default gnus-summary-default-score)
 711          (mark (get-text-property beg 'gnus-mark))
 712          (inhibit-read-only t))
 713     (while (and list (not (eval (car (car list)))))
 714       (setq list (cdr list)))
 715     (let ((face (and list (cdr (car list)))))
 716       (or (eobp)
 717           (eq face (get-text-property beg 'face))
 718           (put-text-property beg end 'face face)))
 719     (goto-char p)))
 720
 721 ;;;
 722 ;;; gnus-carpal
 723 ;;;
 724
 725 (defvar gnus-carpal-group-buffer-buttons
 726   '(("next" . gnus-group-next-unread-group)
 727     ("prev" . gnus-group-prev-unread-group)
 728     ("read" . gnus-group-read-group)
 729     ("select" . gnus-group-select-group)
 730     ("catch up" . gnus-group-catchup-current)
 731     ("new news" . gnus-group-get-new-news-this-group)
 732     ("toggle sub" . gnus-group-unsubscribe-current-group)
 733     ("subscribe" . gnus-group-unsubscribe-group)
 734     ("kill" . gnus-group-kill-group)
 735     ("yank" . gnus-group-yank-group)
 736     ("describe" . gnus-group-describe-group)
 737     "list"
 738     ("subscribed" . gnus-group-list-groups)
 739     ("all" . gnus-group-list-all-groups)
 740     ("killed" . gnus-group-list-killed)
 741     ("zombies" . gnus-group-list-zombies)
 742     ("matching" . gnus-group-list-matching)
 743     ("post" . gnus-group-post-news)
 744     ("mail" . gnus-group-mail)
 745     ("rescan" . gnus-group-get-new-news)
 746     ("browse foreign" . gnus-group-browse-foreign)
 747     ("exit" . gnus-group-exit)))
 748
 749 (defvar gnus-carpal-summary-buffer-buttons
 750   '("mark"
 751     ("read" . gnus-summary-mark-as-read-forward)
 752     ("tick" . gnus-summary-tick-article-forward)
 753     ("clear" . gnus-summary-clear-mark-forward)
 754     ("expirable" . gnus-summary-mark-as-expirable)
 755     "move"
 756     ("scroll" . gnus-summary-next-page)
 757     ("next unread" . gnus-summary-next-unread-article)
 758     ("prev unread" . gnus-summary-prev-unread-article)
 759     ("first" . gnus-summary-first-unread-article)
 760     ("best" . gnus-summary-best-unread-article)
 761     "article"
 762     ("headers" . gnus-summary-toggle-header)
 763     ("uudecode" . gnus-uu-decode-uu)
 764     ("enter digest" . gnus-summary-enter-digest-group)
 765     ("fetch parent" . gnus-summary-refer-parent-article)
 766     "mail"
 767     ("move" . gnus-summary-move-article)
 768     ("copy" . gnus-summary-copy-article)
 769     ("respool" . gnus-summary-respool-article)
 770     "threads"
 771     ("lower" . gnus-summary-lower-thread)
 772     ("kill" . gnus-summary-kill-thread)
 773     "post"
 774     ("post" . gnus-summary-post-news)
 775     ("mail" . gnus-summary-mail)
 776     ("followup" . gnus-summary-followup-with-original)
 777     ("reply" . gnus-summary-reply-with-original)
 778     ("cancel" . gnus-summary-cancel-article)
 779     "misc"
 780     ("exit" . gnus-summary-exit)
 781     ("fed up" . gnus-summary-catchup-and-goto-next-group)))
 782
 783 (defvar gnus-carpal-server-buffer-buttons
 784   '(("add" . gnus-server-add-server)
 785     ("browse" . gnus-server-browse-server)
 786     ("list" . gnus-server-list-servers)
 787     ("kill" . gnus-server-kill-server)
 788     ("yank" . gnus-server-yank-server)
 789     ("copy" . gnus-server-copy-server)
 790     ("exit" . gnus-server-exit)))
 791
 792 (defvar gnus-carpal-browse-buffer-buttons
 793   '(("subscribe" . gnus-browse-unsubscribe-current-group)
 794     ("exit" . gnus-browse-exit)))
 795
 796 (defvar gnus-carpal-group-buffer "*Carpal Group*")
 797 (defvar gnus-carpal-summary-buffer "*Carpal Summary*")
 798 (defvar gnus-carpal-server-buffer "*Carpal Server*")
 799 (defvar gnus-carpal-browse-buffer "*Carpal Browse*")
 800
 801 (defvar gnus-carpal-attached-buffer nil)
 802
 803 (defvar gnus-carpal-mode-hook nil
 804   "*Hook run in carpal mode buffers.")
 805
 806 (defvar gnus-carpal-button-face 'bold
 807   "*Face used on carpal buttons.")
 808
 809 (defvar gnus-carpal-header-face 'bold-italic
 810   "*Face used on carpal buffer headers.")
 811
 812 (defvar gnus-carpal-mode-map nil)
 813 (put 'gnus-carpal-mode 'mode-class 'special)
 814
 815 (if gnus-carpal-mode-map
 816     nil
 817   (setq gnus-carpal-mode-map (make-keymap))
 818   (suppress-keymap gnus-carpal-mode-map)
 819   (define-key gnus-carpal-mode-map " " 'gnus-carpal-select)
 820   (define-key gnus-carpal-mode-map "\r" 'gnus-carpal-select)
 821   (define-key gnus-carpal-mode-map gnus-mouse-2 'gnus-carpal-mouse-select))
 822
 823 (defun gnus-carpal-mode ()
 824   "Major mode for clicking buttons.
 825
 826 All normal editing commands are switched off.
 827 \\<gnus-carpal-mode-map>
 828 The following commands are available:
 829
 830 \\{gnus-carpal-mode-map}"
 831   (interactive)
 832   (kill-all-local-variables)
 833   (setq mode-line-modified "-- ")
 834   (setq major-mode 'gnus-carpal-mode)
 835   (setq mode-name "Gnus Carpal")
 836   (setq mode-line-process nil)
 837   (use-local-map gnus-carpal-mode-map)
 838   (buffer-disable-undo (current-buffer))
 839   (setq buffer-read-only t)
 840   (make-local-variable 'gnus-carpal-attached-buffer)
 841   (run-hooks 'gnus-carpal-mode-hook))
 842
 843 (defun gnus-carpal-setup-buffer (type)
 844   (let ((buffer (symbol-value (intern (format "gnus-carpal-%s-buffer" type)))))
 845     (if (get-buffer buffer)
 846         ()
 847       (save-excursion
 848         (set-buffer (get-buffer-create buffer))
 849         (gnus-carpal-mode)
 850         (setq gnus-carpal-attached-buffer
 851               (intern (format "gnus-%s-buffer" type)))
 852         (gnus-add-current-to-buffer-list)
 853         (let ((buttons (symbol-value
 854                         (intern (format "gnus-carpal-%s-buffer-buttons"
 855                                         type))))
 856               (buffer-read-only nil)
 857               button)
 858           (while buttons
 859             (setq button (car buttons)
 860                   buttons (cdr buttons))
 861             (if (stringp button)
 862                 (set-text-properties
 863                  (point)
 864                  (prog2 (insert button) (point) (insert " "))
 865                  (list 'face gnus-carpal-header-face))
 866               (set-text-properties
 867                (point)
 868                (prog2 (insert (car button)) (point) (insert " "))
 869                (list 'gnus-callback (cdr button)
 870                      'face gnus-carpal-button-face
 871                      'mouse-face 'highlight))))
 872           (let ((fill-column (- (window-width) 2)))
 873             (fill-region (point-min) (point-max)))
 874           (set-window-point (get-buffer-window (current-buffer))
 875                             (point-min)))))))
 876
 877 (defun gnus-carpal-select ()
 878   "Select the button under point."
 879   (interactive)
 880   (let ((func (get-text-property (point) 'gnus-callback)))
 881     (if (null func)
 882         ()
 883       (pop-to-buffer (symbol-value gnus-carpal-attached-buffer))
 884       (call-interactively func))))
 885
 886 (defun gnus-carpal-mouse-select (event)
 887   "Select the button under the mouse pointer."
 888   (interactive "e")
 889   (mouse-set-point event)
 890   (gnus-carpal-select))
 891
 892 ;;;
 893 ;;; article highlights
 894 ;;;
 895
 896 ;; Written by Per Abrahamsen <abraham@iesd.auc.dk>.
 897
 898 ;;; Internal Variables:
 899
 900 (defvar gnus-button-regexp nil)
 901 ;; Regexp matching any of the regexps from `gnus-button-alist'.
 902
 903 (defvar gnus-button-last nil)
 904 ;; The value of `gnus-button-alist' when `gnus-button-regexp' was build.
 905
 906 ;;; Commands:
 907
 908 (defun gnus-article-push-button (event)
 909   "Check text under the mouse pointer for a callback function.
 910 If the text under the mouse pointer has a `gnus-callback' property,
 911 call it with the value of the `gnus-data' text property."
 912   (interactive "e")
 913   (set-buffer (window-buffer (posn-window (event-start event))))
 914   (let* ((pos (posn-point (event-start event)))
 915          (data (get-text-property pos 'gnus-data))
 916          (fun (get-text-property pos 'gnus-callback)))
 917       (if fun (funcall fun data))))
 918
 919 (defun gnus-article-press-button ()
 920   "Check text at point for a callback function.
 921 If the text at point has a `gnus-callback' property,
 922 call it with the value of the `gnus-data' text property."
 923   (interactive)
 924   (let* ((data (get-text-property (point) 'gnus-data))
 925          (fun (get-text-property (point) 'gnus-callback)))
 926       (if fun (funcall fun data))))
 927
 928 ;; Suggested by Arne Elofsson <arne@hodgkin.mbi.ucla.edu>
 929 (defun gnus-article-next-button ()
 930   "Move point to next button."
 931   (interactive)
 932   (if (get-text-property (point) 'gnus-callback)
 933       (goto-char (next-single-property-change (point) 'gnus-callback
 934                                        nil (point-max))))
 935   (let ((pos (next-single-property-change (point) 'gnus-callback)))
 936     (if pos
 937         (goto-char pos)
 938       (setq pos (next-single-property-change (point-min) 'gnus-callback))
 939       (if pos
 940           (goto-char pos)
 941         (error "No buttons found")))))
 942
 943 (defun gnus-article-highlight ()
 944   "Highlight current article.
 945 This function calls `gnus-article-highlight-headers',
 946 `gnus-article-highlight-citation',
 947 `gnus-article-highlight-signature', and `gnus-article-add-buttons' to
 948 do the highlighting.  See the documentation for those functions."
 949   (interactive)
 950   (gnus-article-highlight-headers)
 951   (gnus-article-highlight-citation)
 952   (gnus-article-highlight-signature)
 953   (gnus-article-add-buttons))
 954
 955 (defun gnus-article-hide ()
 956   "Hide current article.
 957 This function calls `gnus-article-hide-headers',
 958 `gnus-article-hide-citation-maybe', and `gnus-article-hide-signature'
 959 to do the hiding.  See the documentation for those functions."
 960   (interactive)
 961   (gnus-article-hide-headers)
 962   (gnus-article-hide-citation-maybe)
 963   (gnus-article-hide-signature))
 964
 965 (defun gnus-article-highlight-headers ()
 966   "Highlight article headers as specified by `gnus-header-face-alist'."
 967   (interactive)
 968   (save-excursion
 969     (set-buffer gnus-article-buffer)
 970     (goto-char (point-min))
 971     (if (not (search-forward "\n\n" nil t))
 972         ()
 973       (beginning-of-line 0)
 974       (while (not (bobp))
 975         (let ((alist gnus-header-face-alist)
 976               (buffer-read-only nil)
 977               (case-fold-search t)
 978               (end (point))
 979               (inhibit-point-motion-hooks t)
 980               begin entry regexp header-face field-face
 981               header-found field-found)
 982           (re-search-backward "^[^ \t]" nil t)
 983           (setq begin (point))
 984           (while alist
 985             (setq entry (car alist)
 986                   regexp (nth 0 entry)
 987                   header-face (nth 1 entry)
 988                   field-face (nth 2 entry)
 989                   alist (cdr alist))
 990             (if (looking-at regexp)
 991                 (let ((from (point)))
 992                   (skip-chars-forward "^:\n")
 993                   (and (not header-found)
 994                        header-face
 995                        (progn
 996                          (put-text-property  from (point) 'face header-face)
 997                          (setq header-found t)))
 998                   (and (not field-found)
 999                        field-face
1000                        (progn
1001                          (skip-chars-forward ": \t")
1002                          (let ((from (point)))
1003                            (goto-char end)
1004                            (skip-chars-backward " \t")
1005                            (put-text-property from (point) 'face field-face)
1006                            (setq field-found t))))))
1007             (goto-char begin)))))))
1008
1009 (defun gnus-article-highlight-signature ()
1010   "Highlight the signature in an article.
1011 It does this by highlighting everything after
1012 `gnus-signature-separator' using `gnus-signature-face'."
1013   (interactive)
1014   (save-excursion
1015     (set-buffer gnus-article-buffer)
1016     (let ((buffer-read-only nil)
1017           (inhibit-point-motion-hooks t))
1018       (goto-char (point-max))
1019       (and (re-search-backward gnus-signature-separator nil t)
1020            gnus-signature-face
1021            (let ((start (match-beginning 0))
1022                  (end (match-end 0)))
1023              (gnus-article-add-button start end 'gnus-signature-toggle end)
1024              (overlay-put (make-overlay end (point-max))
1025                           'face gnus-signature-face))))))
1026
1027 (defun gnus-article-hide-signature ()
1028   "Hide the signature in an article.
1029 It does this by making everything after `gnus-signature-separator' invisible."
1030   (interactive)
1031   (save-excursion
1032     (set-buffer gnus-article-buffer)
1033     (let ((buffer-read-only nil))
1034       (goto-char (point-max))
1035       (and (re-search-backward gnus-signature-separator nil t)
1036            gnus-signature-face
1037            (add-text-properties (match-end 0) (point-max)
1038                                 gnus-hidden-properties)))))
1039
1040 (defun gnus-article-add-buttons ()
1041   "Find external references in article and make them to buttons.
1042
1043 External references are things like message-ids and URLs, as specified by
1044 `gnus-button-alist'."
1045   (interactive)
1046   (if (eq gnus-button-last gnus-button-alist)
1047       ()
1048     (setq gnus-button-regexp (mapconcat 'car gnus-button-alist  "\\|")
1049           gnus-button-last gnus-button-alist))
1050   (save-excursion
1051     (set-buffer gnus-article-buffer)
1052     (gnus-cite-parse-maybe)
1053     (let ((buffer-read-only nil)
1054           (inhibit-point-motion-hooks t)
1055           (case-fold-search t))
1056       (goto-char (point-min))
1057       (search-forward "\n\n")
1058       (while (re-search-forward gnus-button-regexp nil t)
1059         (goto-char (match-beginning 0))
1060         (let* ((from (point))
1061                (entry (gnus-button-entry))
1062                (start (and entry (match-beginning (nth 1 entry))))
1063                (end (and entry (match-end (nth 1 entry))))
1064                (form (nth 2 entry)))
1065           (if (not entry)
1066               ()
1067             (goto-char (match-end 0))
1068             (if (eval form)
1069                 (gnus-article-add-button start end 'gnus-button-push
1070                                          (set-marker (make-marker)
1071                                                      from)))))))))
1072 (defun gnus-netscape-open-url (url)
1073   "Open URL in netscape, or start new scape with URL."
1074   (let ((process (start-process (concat "netscape " url)
1075                                 nil
1076                                 "netscape"
1077                                 "-remote"
1078                                 (concat "openUrl(" url ")'"))))
1079     (set-process-sentinel process
1080                           (` (lambda (process change)
1081                                (or (eq (process-exit-status process) 0)
1082                                    (gnus-netscape-start-url (, url))))))))
1083
1084 (defun gnus-netscape-start-url (url)
1085   "Start netscape with URL."
1086   (shell-command (concat "netscape " url "&")))
1087
1088 ;;; External functions:
1089
1090 (defun gnus-article-add-button (from to fun &optional data)
1091   "Create a button between FROM and TO with callback FUN and data DATA."
1092   (and gnus-article-button-face
1093        (overlay-put (make-overlay from to) 'face gnus-article-button-face))
1094   (add-text-properties from to
1095                        (append (and gnus-article-mouse-face
1096                                     (list 'mouse-face gnus-article-mouse-face))
1097                                (list 'gnus-callback fun)
1098                                (and data (list 'gnus-data data)))))
1099
1100 ;;; Internal functions:
1101
1102 (defun gnus-signature-toggle (end)
1103   (save-excursion
1104     (set-buffer gnus-article-buffer)
1105     (let ((buffer-read-only nil))
1106       (if (get-text-property end 'invisible)
1107           (remove-text-properties end (point-max) gnus-hidden-properties)
1108         (add-text-properties end (point-max) gnus-hidden-properties)))))
1109
1110 (defun gnus-make-face (color)
1111   ;; Create entry for face with COLOR.
1112   (if gnus-make-foreground
1113       (custom-face-lookup color nil nil nil nil nil)
1114     (custom-face-lookup nil color nil nil nil nil)))
1115
1116 (defun gnus-button-entry ()
1117   ;; Return the first entry in `gnus-button-alist' matching this place.
1118   (let ((alist gnus-button-alist)
1119         (entry nil))
1120     (while alist
1121       (setq entry (car alist)
1122             alist (cdr alist))
1123       (if (looking-at (car entry))
1124           (setq alist nil)
1125         (setq entry nil)))
1126     entry))
1127
1128 (defun gnus-button-push (marker)
1129   ;; Push button starting at MARKER.
1130   (save-excursion
1131     (set-buffer gnus-article-buffer)
1132     (goto-char marker)
1133     (let* ((entry (gnus-button-entry))
1134            (inhibit-point-motion-hooks t)
1135            (fun (nth 3 entry))
1136            (args (mapcar (lambda (group)
1137                            (let ((string (buffer-substring
1138                                           (match-beginning group)
1139                                           (match-end group))))
1140                            (set-text-properties 0 (length string) nil string)
1141                            string))
1142                          (nthcdr 4 entry))))
1143       (cond ((fboundp fun)
1144              (apply fun args))
1145             ((and (boundp fun)
1146                   (fboundp (symbol-value fun)))
1147              (apply (symbol-value fun) args))
1148             (t
1149              (message "You must define `%S' to use this button"
1150                       (cons fun args)))))))
1151
1152 (defun gnus-button-message-id (message-id)
1153   ;; Push on MESSAGE-ID.
1154   (save-excursion
1155     (set-buffer gnus-summary-buffer)
1156     (gnus-summary-refer-article message-id)))
1157
1158 ;;; Compatibility Functions:
1159
1160 (or (fboundp 'rassoc)
1161     ;; Introduced in Emacs 19.29.
1162     (defun rassoc (elt list)
1163       "Return non-nil if ELT is `equal' to the cdr of an element of LIST.
1164 The value is actually the element of LIST whose cdr is ELT."
1165       (let (result)
1166         (while list
1167           (setq result (car list))
1168           (if (equal (cdr result) elt)
1169               (setq list nil)
1170             (setq result nil
1171                   list (cdr list))))
1172         result)))
1173
1174 (gnus-ems-redefine)
1175
1176 (provide 'gnus-vis)
1177
1178 ;;; gnus-vis.el ends here