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