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

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