lisp/gnus-vis.el

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