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