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

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