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

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