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