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

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