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