code.delx.au - gnu-emacs/blob - lisp/gnus-vis.el

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