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