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          ["Add a directory group" gnus-group-make-directory-group t]
 309          ["Add the help group" gnus-group-make-help-group t]
 310          ["Add the archive group" gnus-group-make-archive-group t]
 311          ["Make a doc group" gnus-group-make-doc-group t]
 312          ["Make a kiboze group" gnus-group-make-kiboze-group t]
 313          ["Make a virtual group" gnus-group-make-empty-virtual t]
 314          ["Add a group to a virtual" gnus-group-add-to-virtual t])
 315         ("Editing groups"
 316          ["Parameters" gnus-group-edit-group-parameters t]
 317          ["Select method" gnus-group-edit-group-method t]
 318          ["Info" gnus-group-edit-group t])
 319         ["Read a directory as a group" gnus-group-enter-directory t]
 320         ["Jump to group" gnus-group-jump-to-group t]
 321         ["Best unread group" gnus-group-best-unread-group t]
 322         ))
 323
 324      (easy-menu-define
 325       gnus-group-misc-menu
 326       gnus-group-mode-map
 327       ""
 328       '("Misc"
 329         ["Send a bug report" gnus-bug t]
 330         ["Send a mail" gnus-group-mail t]
 331         ["Post an article" gnus-group-post-news t]
 332         ["Customize score file" gnus-score-customize (not (string-match "XEmacs" emacs-version)) ]
 333         ["Check for new news" gnus-group-get-new-news t]
 334         ["Delete bogus groups" gnus-group-check-bogus-groups t]
 335         ["Find new newsgroups" gnus-find-new-newsgroups t]
 336         ["Restart Gnus" gnus-group-restart t]
 337         ["Read init file" gnus-group-read-init-file t]
 338         ["Browse foreign server" gnus-group-browse-foreign-server t]
 339         ["Enter server buffer" gnus-group-enter-server-mode t]
 340         ["Expire expirable articles" gnus-group-expire-all-groups t]
 341         ["Generate any kiboze groups" nnkiboze-generate-groups t]
 342         ["Gnus version" gnus-version t]
 343         ["Save .newsrc files" gnus-group-save-newsrc t]
 344         ["Suspend Gnus" gnus-group-suspend t]
 345         ["Clear dribble buffer" gnus-group-clear-dribble t]
 346         ["Exit from Gnus" gnus-group-exit t]
 347         ["Exit without saving" gnus-group-quit t]
 348         ["Edit global kill file" gnus-group-edit-global-kill t]
 349         ["Sort group buffer" gnus-group-sort-groups t]
 350         ))
 351      )))
 352
 353 ;; Server mode
 354 (defun gnus-server-make-menu-bar ()
 355   (gnus-visual-turn-off-edit-menu 'server)
 356   (or
 357    (boundp 'gnus-server-menu)
 358    (easy-menu-define
 359     gnus-server-menu
 360     gnus-server-mode-map
 361     ""
 362     '("Server"
 363       ["Add" gnus-server-add-server t]
 364       ["Browse" gnus-server-read-server t]
 365       ["List" gnus-server-list-servers t]
 366       ["Kill" gnus-server-kill-server t]
 367       ["Yank" gnus-server-yank-server t]
 368       ["Copy" gnus-server-copy-server t]
 369       ["Edit" gnus-server-edit-server t]
 370       ["Exit" gnus-server-exit t]
 371       ))))
 372
 373 ;; Browse mode
 374 (defun gnus-browse-make-menu-bar ()
 375   (gnus-visual-turn-off-edit-menu 'browse)
 376   (or
 377    (boundp 'gnus-browse-menu)
 378    (easy-menu-define
 379     gnus-browse-menu
 380     gnus-browse-mode-map
 381     ""
 382     '("Browse"
 383       ["Subscribe" gnus-browse-unsubscribe-current-group t]
 384       ["Read" gnus-group-read-group t]
 385       ["Exit" gnus-browse-exit t]
 386       ))))
 387
 388 ;; Summary buffer
 389 (defun gnus-summary-make-menu-bar ()
 390   (gnus-visual-turn-off-edit-menu 'summary)
 391
 392   (or
 393    (boundp 'gnus-summary-mark-menu)
 394    (progn
 395
 396      (easy-menu-define
 397       gnus-summary-misc-menu
 398       gnus-summary-mode-map
 399       ""
 400       '("Misc"
 401         ("Mark"
 402          ("Read"
 403           ["Mark as read" gnus-summary-mark-as-read-forward t]
 404           ["Mark same subject and select" gnus-summary-kill-same-subject-and-select t]
 405           ["Mark same subject" gnus-summary-kill-same-subject t]
 406           ["Catchup" gnus-summary-catchup t]
 407           ["Catchup all" gnus-summary-catchup-all t]
 408           ["Catchup to here" gnus-summary-catchup-to-here t]
 409           ["Catchup region" gnus-summary-mark-region-as-read t])
 410          ("Various"
 411           ["Tick" gnus-summary-tick-article-forward t]
 412           ["Mark as dormant" gnus-summary-mark-as-dormant t]
 413           ["Remove marks" gnus-summary-clear-mark-forward t]
 414           ["Set expirable mark" gnus-summary-mark-as-expirable t]
 415           ["Set bookmark" gnus-summary-set-bookmark t]
 416           ["Remove bookmark" gnus-summary-remove-bookmark t])
 417          ("Display"
 418           ["Remove lines marked as read" gnus-summary-remove-lines-marked-as-read t]
 419           ["Remove lines marked with..." gnus-summary-remove-lines-marked-with t]
 420           ["Show dormant articles" gnus-summary-show-all-dormant t]
 421           ["Hide dormant articles" gnus-summary-hide-all-dormant t]
 422           ["Show expunged articles" gnus-summary-show-all-expunged t])
 423          ("Process mark"
 424           ["Set mark" gnus-summary-mark-as-processable t]
 425           ["Remove mark" gnus-summary-unmark-as-processable t]
 426           ["Remove all marks" gnus-summary-unmark-all-processable t]
 427           ["Mark series" gnus-uu-mark-series t]
 428           ["Mark region" gnus-uu-mark-region t]
 429           ["Mark by regexp" gnus-uu-mark-by-regexp t]
 430           ["Mark all" gnus-uu-mark-all t]
 431           ["Mark sparse" gnus-uu-mark-sparse t]
 432           ["Mark thread" gnus-uu-mark-thread t]))
 433         ("Move"
 434          ["Scroll article forwards" gnus-summary-next-page t]
 435          ["Next unread article" gnus-summary-next-unread-article t]
 436          ["Previous unread article" gnus-summary-prev-unread-article t]
 437          ["Next article" gnus-summary-next-article t]
 438          ["Previous article" gnus-summary-prev-article t]
 439          ["Next article same subject" gnus-summary-next-same-subject t]
 440          ["Previous article same subject" gnus-summary-prev-same-subject t]
 441          ["First unread article" gnus-summary-first-unread-article t]
 442          ["Go to subject number..." gnus-summary-goto-subject t]
 443          ["Go to the last article" gnus-summary-goto-last-article t]
 444          ["Pop article off history" gnus-summary-pop-article t])
 445         ("Sort"
 446          ["Sort by number" gnus-summary-sort-by-number t]
 447          ["Sort by author" gnus-summary-sort-by-author t]
 448          ["Sort by subject" gnus-summary-sort-by-subject t]
 449          ["Sort by date" gnus-summary-sort-by-date t]
 450          ["Sort by score" gnus-summary-sort-by-score t])
 451         ("Exit"
 452          ["Catchup and exit" gnus-summary-catchup-and-exit t]
 453          ["Catchup and goto next" gnus-summary-catchup-and-goto-next-group t]
 454          ["Exit group" gnus-summary-exit t]
 455          ["Exit group without updating" gnus-summary-exit-no-update t]
 456          ["Reselect group" gnus-summary-reselect-current-group t]
 457          ["Rescan group" gnus-summary-rescan-group t])
 458         ["Fetch group FAQ" gnus-summary-fetch-faq t]
 459         ["Filter articles" gnus-summary-execute-command t]
 460         ["Toggle line truncation" gnus-summary-toggle-truncation t]
 461         ["Expire expirable articles" gnus-summary-expire-articles t]
 462         ["Describe group" gnus-summary-describe-group t]
 463         ["Edit local kill file" gnus-summary-edit-local-kill t]
 464         ))
 465
 466      (easy-menu-define
 467       gnus-summary-kill-menu
 468       gnus-summary-mode-map
 469       ""
 470       (cons
 471        "Score"
 472        (nconc
 473         (list
 474          ["Enter score" gnus-summary-score-entry t])
 475         (gnus-visual-score-map 'increase)
 476         (gnus-visual-score-map 'lower)
 477         '(["Current score" gnus-summary-current-score t]
 478           ["Set score" gnus-summary-set-score t]
 479           ["Customize score file" gnus-score-customize t]
 480           ["Switch current score file" gnus-score-change-score-file t]
 481           ["Set mark below" gnus-score-set-mark-below t]
 482           ["Set expunge below" gnus-score-set-expunge-below t]
 483           ["Edit current score file" gnus-score-edit-alist t]
 484           ["Edit score file" gnus-score-edit-file t]
 485           ["Trace score" gnus-score-find-trace t]
 486           ["Increase score" gnus-summary-increase-score t]
 487           ["Lower score" gnus-summary-lower-score t]))))
 488
 489      (and nil
 490           '(("Default header"
 491              ["Ask" (gnus-score-set-default 'gnus-score-default-header nil)
 492               :style radio
 493               :selected (null gnus-score-default-header)]
 494              ["From" (gnus-score-set-default 'gnus-score-default-header 'a)
 495               :style radio
 496               :selected (eq gnus-score-default-header 'a )]
 497              ["Subject" (gnus-score-set-default 'gnus-score-default-header 's)
 498               :style radio
 499               :selected (eq gnus-score-default-header 's )]
 500              ["Article body"
 501               (gnus-score-set-default 'gnus-score-default-header 'b)
 502               :style radio
 503               :selected (eq gnus-score-default-header 'b )]
 504              ["All headers"
 505               (gnus-score-set-default 'gnus-score-default-header 'h)
 506               :style radio
 507               :selected (eq gnus-score-default-header 'h )]
 508              ["Message-Id" (gnus-score-set-default 'gnus-score-default-header 'i)
 509               :style radio
 510               :selected (eq gnus-score-default-header 'i )]
 511              ["Thread" (gnus-score-set-default 'gnus-score-default-header 't)
 512               :style radio
 513               :selected (eq gnus-score-default-header 't )]
 514              ["Crossposting"
 515               (gnus-score-set-default 'gnus-score-default-header 'x)
 516               :style radio
 517               :selected (eq gnus-score-default-header 'x )]
 518              ["Lines" (gnus-score-set-default 'gnus-score-default-header 'l)
 519               :style radio
 520               :selected (eq gnus-score-default-header 'l )]
 521              ["Date" (gnus-score-set-default 'gnus-score-default-header 'd)
 522               :style radio
 523               :selected (eq gnus-score-default-header 'd )]
 524              ["Followups to author"
 525               (gnus-score-set-default 'gnus-score-default-header 'f)
 526               :style radio
 527               :selected (eq gnus-score-default-header 'f )])
 528             ("Default type"
 529              ["Ask" (gnus-score-set-default 'gnus-score-default-type nil)
 530               :style radio
 531               :selected (null gnus-score-default-type)]
 532              ;; The `:active' key is commented out in the following,
 533              ;; because the GNU Emacs hack to support radio buttons use
 534              ;; active to indicate which button is selected.
 535              ["Substring" (gnus-score-set-default 'gnus-score-default-type 's)
 536               :style radio
 537               ;; :active (not (memq gnus-score-default-header '(l d)))
 538               :selected (eq gnus-score-default-type 's)]
 539              ["Regexp" (gnus-score-set-default 'gnus-score-default-type 'r)
 540               :style radio
 541               ;; :active (not (memq gnus-score-default-header '(l d)))
 542               :selected (eq gnus-score-default-type 'r)]
 543              ["Exact" (gnus-score-set-default 'gnus-score-default-type 'e)
 544               :style radio
 545               ;; :active (not (memq gnus-score-default-header '(l d)))
 546               :selected (eq gnus-score-default-type 'e)]
 547              ["Fuzzy" (gnus-score-set-default 'gnus-score-default-type 'f)
 548               :style radio
 549               ;; :active (not (memq gnus-score-default-header '(l d)))
 550               :selected (eq gnus-score-default-type 'f)]
 551              ["Before date" (gnus-score-set-default 'gnus-score-default-type 'b)
 552               :style radio
 553               ;; :active (eq (gnus-score-default-header 'd))
 554               :selected (eq gnus-score-default-type 'b)]
 555              ["At date" (gnus-score-set-default 'gnus-score-default-type 'n)
 556               :style radio
 557               ;; :active (eq (gnus-score-default-header 'd))
 558               :selected (eq gnus-score-default-type 'n)]
 559              ["After date" (gnus-score-set-default 'gnus-score-default-type 'a)
 560               :style radio
 561               ;; :active (eq (gnus-score-default-header 'd))
 562               :selected (eq gnus-score-default-type 'a)]
 563              ["Less than number"
 564               (gnus-score-set-default 'gnus-score-default-type '<)
 565               :style radio
 566               ;; :active (eq (gnus-score-default-header 'l))
 567               :selected (eq gnus-score-default-type '<)]
 568              ["Equal to number"
 569               (gnus-score-set-default 'gnus-score-default-type '=)
 570               :style radio
 571               ;; :active (eq (gnus-score-default-header 'l))
 572               :selected (eq gnus-score-default-type '=)]
 573              ["Greater than number"
 574               (gnus-score-set-default 'gnus-score-default-type '>)
 575               :style radio
 576               ;; :active (eq (gnus-score-default-header 'l))
 577               :selected (eq gnus-score-default-type '>)])
 578             ["Default fold" gnus-score-default-fold-toggle
 579              :style toggle
 580              :selected gnus-score-default-fold]
 581             ("Default duration"
 582              ["Ask" (gnus-score-set-default 'gnus-score-default-duration nil)
 583               :style radio
 584               :selected (null gnus-score-default-duration)]
 585              ["Permanent"
 586               (gnus-score-set-default 'gnus-score-default-duration 'p)
 587               :style radio
 588               :selected (eq gnus-score-default-duration 'p)]
 589              ["Temporary"
 590               (gnus-score-set-default 'gnus-score-default-duration 't)
 591               :style radio
 592               :selected (eq gnus-score-default-duration 't)]
 593              ["Immediate"
 594               (gnus-score-set-default 'gnus-score-default-duration 'i)
 595               :style radio
 596               :selected (eq gnus-score-default-duration 'i)])
 597             ))
 598
 599      (easy-menu-define
 600       gnus-summary-article-menu
 601       gnus-summary-mode-map
 602       ""
 603       '("Article"
 604         ("Hide"
 605          ["All" gnus-article-hide t]
 606          ["Headers" gnus-article-hide-headers t]
 607          ["Signature" gnus-article-hide-signature t]
 608          ["Citation" gnus-article-hide-citation t])
 609         ("Highlight"
 610          ["All" gnus-article-highlight t]
 611          ["Headers" gnus-article-highlight-headers t]
 612          ["Signature" gnus-article-highlight-signature t]
 613          ["Citation" gnus-article-highlight-citation t])
 614         ("Date"
 615          ["Local" gnus-article-date-local t]
 616          ["UT" gnus-article-date-ut t]
 617          ["Lapsed" gnus-article-date-lapsed t])
 618         ("Filter"
 619          ["Overstrike" gnus-article-treat-overstrike t]
 620          ["Word wrap" gnus-article-word-wrap t]
 621          ["CR" gnus-article-remove-cr t]
 622          ["Show X-Face" gnus-article-display-x-face t]
 623          ["Quoted-Printable" gnus-article-de-quoted-unreadable t]
 624          ["Rot 13" gnus-summary-caesar-message t]
 625          ["Add buttons" gnus-article-add-buttons t]
 626          ["Stop page breaking" gnus-summary-stop-page-breaking t]
 627          ["Toggle MIME" gnus-summary-toggle-mime t]
 628          ["Toggle header" gnus-summary-toggle-header t])
 629         ("Output"
 630          ["Save in default format" gnus-summary-save-article t]
 631          ["Save in file" gnus-summary-save-article-file t]
 632          ["Save in Unix mail format" gnus-summary-save-article-mail t]
 633          ["Save in MH folder" gnus-summary-save-article-folder t]
 634          ["Save in VM folder" gnus-summary-save-article-vm t]
 635          ["Save in RMAIL mbox" gnus-summary-save-article-rmail t]
 636          ["Pipe through a filter" gnus-summary-pipe-output t])
 637         ("Backend"
 638          ["Respool article" gnus-summary-respool-article t]
 639          ["Move article" gnus-summary-move-article t]
 640          ["Copy article" gnus-summary-copy-article t]
 641          ["Import file" gnus-summary-import-article t]
 642          ["Edit article" gnus-summary-edit-article t]
 643          ["Delete article" gnus-summary-delete-article t])
 644         ("Extract"
 645          ["Uudecode" gnus-uu-decode-uu t]
 646          ["Uudecode and save" gnus-uu-decode-uu-and-save t]
 647          ["Unshar" gnus-uu-decode-unshar t]
 648          ["Unshar and save" gnus-uu-decode-unshar-and-save t]
 649          ["Save" gnus-uu-decode-save t]
 650          ["Binhex" gnus-uu-decode-binhex t])
 651         ["Enter digest buffer" gnus-summary-enter-digest-group t]
 652         ["Isearch article" gnus-summary-isearch-article t]
 653         ["Search all articles" gnus-summary-search-article-forward t]
 654         ["Beginning of the article" gnus-summary-beginning-of-article t]
 655         ["End of the article" gnus-summary-end-of-article t]
 656         ["Fetch parent of article" gnus-summary-refer-parent-article t]
 657         ["Fetch article with id..." gnus-summary-refer-article t]
 658         ["Redisplay" gnus-summary-show-article t]))
 659
 660
 661      (easy-menu-define
 662       gnus-summary-thread-menu
 663       gnus-summary-mode-map
 664       ""
 665       '("Threads"
 666         ["Toggle threading" gnus-summary-toggle-threads t]
 667         ["Display hidden thread" gnus-summary-show-thread t]
 668         ["Hide thread" gnus-summary-hide-thread t]
 669         ["Go to next thread" gnus-summary-next-thread t]
 670         ["Go to previous thread" gnus-summary-prev-thread t]
 671         ["Go down thread" gnus-summary-down-thread t]
 672         ["Go up thread" gnus-summary-up-thread t]
 673         ["Mark thread as read" gnus-summary-kill-thread t]
 674         ["Lower thread score" gnus-summary-lower-thread t]
 675         ["Raise thread score" gnus-summary-raise-thread t]
 676         ))
 677      (easy-menu-define
 678       gnus-summary-post-menu
 679       gnus-summary-mode-map
 680       ""
 681       '("Post"
 682         ["Post an article" gnus-summary-post-news t]
 683         ["Followup" gnus-summary-followup t]
 684         ["Followup and yank" gnus-summary-followup-with-original t]
 685         ["Supersede article" gnus-summary-supersede-article t]
 686         ["Cancel article" gnus-summary-cancel-article t]
 687         ["Reply" gnus-summary-reply t]
 688         ["Reply and yank" gnus-summary-reply-with-original t]
 689         ["Mail forward" gnus-summary-mail-forward t]
 690         ["Post forward" gnus-summary-post-forward t]
 691         ["Digest and mail" gnus-uu-digest-mail-forward t]
 692         ["Digest and post" gnus-uu-digest-post-forward t]
 693         ["Send a mail" gnus-summary-mail-other-window t]
 694         ["Reply & followup" gnus-summary-followup-and-reply t]
 695         ["Reply & followup and yank" gnus-summary-followup-and-reply-with-original t]
 696         ["Uuencode and post" gnus-uu-post-news t]
 697         ))
 698
 699      )))
 700
 701 (defun gnus-score-set-default (var value)
 702   ;; A version of set that updates the GNU Emacs menu-bar.
 703   (set var value)
 704   ;; It is the message that forces the active status to be updated.
 705   (message ""))
 706
 707 (defvar gnus-score-default-header nil
 708   "Default header when entering new scores.
 709
 710 Should be one of the following symbols.
 711
 712  a: from
 713  s: subject
 714  b: body
 715  h: head
 716  i: message-id
 717  t: references
 718  x: xref
 719  l: lines
 720  d: date
 721  f: followup
 722
 723 If nil, the user will be asked for a header.")
 724
 725 (defvar gnus-score-default-type nil
 726   "Default match type when entering new scores.
 727
 728 Should be one of the following symbols.
 729
 730  s: substring
 731  e: exact string
 732  f: fuzzy string
 733  r: regexp string
 734  b: before date
 735  a: at date
 736  n: this date
 737  <: less than number
 738  >: greater than number
 739  =: equal to number
 740
 741 If nil, the user will be asked for a match type.")
 742
 743 (defvar gnus-score-default-fold nil
 744   "Use case folding for new score file entries iff not nil.")
 745
 746
 747 (defun gnus-score-default-fold-toggle ()
 748   "Toggle folding for new score file entries."
 749   (interactive)
 750   (setq gnus-score-default-fold (not gnus-score-default-fold))
 751   (if gnus-score-default-fold
 752       (message "New score file entries will be case insensitive.")
 753     (message "New score file entries will be case sensitive.")))
 754
 755 (defvar gnus-score-default-duration nil
 756   "Default duration of effect when entering new scores.
 757
 758 Should be one of the following symbols.
 759
 760  t: temporary
 761  p: permanent
 762  i: immediate
 763
 764 If nil, the user will be asked for a duration.")
 765
 766 (defun gnus-visual-score-map (type)
 767   (if t
 768       nil
 769     (let ((headers '(("author" "from" string)
 770                      ("subject" "subject" string)
 771                      ("article body" "body" string)
 772                      ("article head" "head" string)
 773                      ("xref" "xref" string)
 774                      ("lines" "lines" number)
 775                      ("followups to author" "followup" string)))
 776           (types '((number ("less than" <)
 777                            ("greater than" >)
 778                            ("equal" =))
 779                    (string ("substring" s)
 780                            ("exact string" e)
 781                            ("fuzzy string" f)
 782                            ("regexp" r))))
 783           (perms '(("temporary" (current-time-string))
 784                    ("permanent" nil)
 785                    ("immediate" now)))
 786           header)
 787       (list
 788        (apply
 789         'nconc
 790         (list
 791          (if (eq type 'lower)
 792              "Lower score"
 793            "Increase score"))
 794         (let (outh)
 795           (while headers
 796             (setq header (car headers))
 797             (setq outh
 798                   (cons
 799                    (apply
 800                     'nconc
 801                     (list (car header))
 802                     (let ((ts (cdr (assoc (nth 2 header) types)))
 803                           outt)
 804                       (while ts
 805                         (setq outt
 806                               (cons
 807                                (apply
 808                                 'nconc
 809                                 (list (car (car ts)))
 810                                 (let ((ps perms)
 811                                       outp)
 812                                   (while ps
 813                                     (setq outp
 814                                           (cons
 815                                            (vector
 816                                             (car (car ps))
 817                                             (list
 818                                              'gnus-summary-score-entry
 819                                              (nth 1 header)
 820                                              (if (or (string= (nth 1 header)
 821                                                               "head")
 822                                                      (string= (nth 1 header)
 823                                                               "body"))
 824                                                  ""
 825                                                (list 'gnus-summary-header
 826                                                      (nth 1 header)))
 827                                              (list 'quote (nth 1 (car ts)))
 828                                              (list 'gnus-score-default nil)
 829                                              (nth 1 (car ps))
 830                                              t)
 831                                             t)
 832                                            outp))
 833                                     (setq ps (cdr ps)))
 834                                   (list (nreverse outp))))
 835                                outt))
 836                         (setq ts (cdr ts)))
 837                       (list (nreverse outt))))
 838                    outh))
 839             (setq headers (cdr headers)))
 840           (list (nreverse outh))))))))
 841
 842 ;; Article buffer
 843 (defun gnus-article-make-menu-bar ()
 844   (gnus-visual-turn-off-edit-menu 'summary)
 845   (or
 846    (boundp 'gnus-article-article-menu)
 847    (progn
 848      (easy-menu-define
 849       gnus-article-article-menu
 850       gnus-article-mode-map
 851       ""
 852       '("Article"
 853         ["Scroll forwards" gnus-article-next-page t]
 854         ["Scroll backwards" gnus-article-prev-page t]
 855         ["Show summary" gnus-article-show-summary t]
 856         ["Fetch Message-ID at point" gnus-article-refer-article t]
 857         ["Mail to address at point" gnus-article-mail t]
 858         ["Mail to address at point and include original"
 859          gnus-article-mail-with-original t]
 860         ))
 861
 862      (easy-menu-define
 863       gnus-article-treatment-menu
 864       gnus-article-mode-map
 865       ""
 866       '("Treatment"
 867         ["Hide headers" gnus-article-hide-headers t]
 868         ["Hide signature" gnus-article-hide-signature t]
 869         ["Hide citation" gnus-article-hide-citation t]
 870         ["Treat overstrike" gnus-article-treat-overstrike t]
 871         ["Remove carriage return" gnus-article-remove-cr t]
 872         ["Remove quoted-unreadable" gnus-article-de-quoted-unreadable t]
 873         ))
 874      )))
 875
 876 ;;;
 877 ;;; summary highlights
 878 ;;;
 879
 880 (defun gnus-highlight-selected-summary ()
 881   ;; Added by Per Abrahamsen <amanda@iesd.auc.dk>.
 882   ;; Highlight selected article in summary buffer
 883   (if gnus-summary-selected-face
 884       (save-excursion
 885         (let* ((beg (progn (beginning-of-line) (point)))
 886                (end (progn (end-of-line) (point)))
 887                ;; Fix by Mike Dugan <dugan@bucrf16.bu.edu>.
 888                (from (if (get-text-property beg 'mouse-face)
 889                          beg
 890                        (1+ (or (next-single-property-change
 891                                 beg 'mouse-face nil end)
 892                                beg))))
 893                (to (1- (or (next-single-property-change
 894                             from 'mouse-face nil end)
 895                            end))))
 896           ;; If no mouse-face prop on line (e.g. xemacs) we
 897           ;; will have to = from = end, so we highlight the
 898           ;; entire line instead.
 899           (if (= (+ to 2) from)
 900               (progn
 901                 (setq from beg)
 902                 (setq to end)))
 903           (if gnus-newsgroup-selected-overlay
 904               (gnus-move-overlay gnus-newsgroup-selected-overlay
 905                                  from to (current-buffer))
 906             (setq gnus-newsgroup-selected-overlay (gnus-make-overlay from to))
 907             (gnus-overlay-put gnus-newsgroup-selected-overlay 'face
 908                               gnus-summary-selected-face))))))
 909
 910 ;; New implementation by Christian Limpach <Christian.Limpach@nice.ch>.
 911 (defun gnus-summary-highlight-line ()
 912   "Highlight current line according to `gnus-summary-highlight'."
 913   (let* ((list gnus-summary-highlight)
 914          (p (point))
 915          (end (progn (end-of-line) (point)))
 916          ;; now find out where the line starts and leave point there.
 917          (beg (progn (beginning-of-line) (point)))
 918          (score (or (cdr (assq (or (get-text-property beg 'gnus-number)
 919                                    gnus-current-article)
 920                                gnus-newsgroup-scored))
 921                     gnus-summary-default-score 0))
 922          (default gnus-summary-default-score)
 923          (mark (get-text-property beg 'gnus-mark))
 924          (inhibit-read-only t))
 925     (while (and list (not (eval (car (car list)))))
 926       (setq list (cdr list)))
 927     (let ((face (and list (cdr (car list)))))
 928       (or (eobp)
 929           (eq face (get-text-property beg 'face))
 930           (put-text-property beg end 'face
 931                              (if (boundp face) (symbol-value face) face))))
 932     (goto-char p)))
 933
 934 ;;;
 935 ;;; gnus-carpal
 936 ;;;
 937
 938 (defvar gnus-carpal-group-buffer-buttons
 939   '(("next" . gnus-group-next-unread-group)
 940     ("prev" . gnus-group-prev-unread-group)
 941     ("read" . gnus-group-read-group)
 942     ("select" . gnus-group-select-group)
 943     ("catch up" . gnus-group-catchup-current)
 944     ("new news" . gnus-group-get-new-news-this-group)
 945     ("toggle sub" . gnus-group-unsubscribe-current-group)
 946     ("subscribe" . gnus-group-unsubscribe-group)
 947     ("kill" . gnus-group-kill-group)
 948     ("yank" . gnus-group-yank-group)
 949     ("describe" . gnus-group-describe-group)
 950     "list"
 951     ("subscribed" . gnus-group-list-groups)
 952     ("all" . gnus-group-list-all-groups)
 953     ("killed" . gnus-group-list-killed)
 954     ("zombies" . gnus-group-list-zombies)
 955     ("matching" . gnus-group-list-matching)
 956     ("post" . gnus-group-post-news)
 957     ("mail" . gnus-group-mail)
 958     ("rescan" . gnus-group-get-new-news)
 959     ("browse foreign" . gnus-group-browse-foreign)
 960     ("exit" . gnus-group-exit)))
 961
 962 (defvar gnus-carpal-summary-buffer-buttons
 963   '("mark"
 964     ("read" . gnus-summary-mark-as-read-forward)
 965     ("tick" . gnus-summary-tick-article-forward)
 966     ("clear" . gnus-summary-clear-mark-forward)
 967     ("expirable" . gnus-summary-mark-as-expirable)
 968     "move"
 969     ("scroll" . gnus-summary-next-page)
 970     ("next unread" . gnus-summary-next-unread-article)
 971     ("prev unread" . gnus-summary-prev-unread-article)
 972     ("first" . gnus-summary-first-unread-article)
 973     ("best" . gnus-summary-best-unread-article)
 974     "article"
 975     ("headers" . gnus-summary-toggle-header)
 976     ("uudecode" . gnus-uu-decode-uu)
 977     ("enter digest" . gnus-summary-enter-digest-group)
 978     ("fetch parent" . gnus-summary-refer-parent-article)
 979     "mail"
 980     ("move" . gnus-summary-move-article)
 981     ("copy" . gnus-summary-copy-article)
 982     ("respool" . gnus-summary-respool-article)
 983     "threads"
 984     ("lower" . gnus-summary-lower-thread)
 985     ("kill" . gnus-summary-kill-thread)
 986     "post"
 987     ("post" . gnus-summary-post-news)
 988     ("mail" . gnus-summary-mail)
 989     ("followup" . gnus-summary-followup-with-original)
 990     ("reply" . gnus-summary-reply-with-original)
 991     ("cancel" . gnus-summary-cancel-article)
 992     "misc"
 993     ("exit" . gnus-summary-exit)
 994     ("fed up" . gnus-summary-catchup-and-goto-next-group)))
 995
 996 (defvar gnus-carpal-server-buffer-buttons
 997   '(("add" . gnus-server-add-server)
 998     ("browse" . gnus-server-browse-server)
 999     ("list" . gnus-server-list-servers)
1000     ("kill" . gnus-server-kill-server)
1001     ("yank" . gnus-server-yank-server)
1002     ("copy" . gnus-server-copy-server)
1003     ("exit" . gnus-server-exit)))
1004
1005 (defvar gnus-carpal-browse-buffer-buttons
1006   '(("subscribe" . gnus-browse-unsubscribe-current-group)
1007     ("exit" . gnus-browse-exit)))
1008
1009 (defvar gnus-carpal-group-buffer "*Carpal Group*")
1010 (defvar gnus-carpal-summary-buffer "*Carpal Summary*")
1011 (defvar gnus-carpal-server-buffer "*Carpal Server*")
1012 (defvar gnus-carpal-browse-buffer "*Carpal Browse*")
1013
1014 (defvar gnus-carpal-attached-buffer nil)
1015
1016 (defvar gnus-carpal-mode-hook nil
1017   "*Hook run in carpal mode buffers.")
1018
1019 (defvar gnus-carpal-button-face 'bold
1020   "*Face used on carpal buttons.")
1021
1022 (defvar gnus-carpal-header-face 'bold-italic
1023   "*Face used on carpal buffer headers.")
1024
1025 (defvar gnus-carpal-mode-map nil)
1026 (put 'gnus-carpal-mode 'mode-class 'special)
1027
1028 (if gnus-carpal-mode-map
1029     nil
1030   (setq gnus-carpal-mode-map (make-keymap))
1031   (suppress-keymap gnus-carpal-mode-map)
1032   (define-key gnus-carpal-mode-map " " 'gnus-carpal-select)
1033   (define-key gnus-carpal-mode-map "\r" 'gnus-carpal-select)
1034   (define-key gnus-carpal-mode-map gnus-mouse-2 'gnus-carpal-mouse-select))
1035
1036 (defun gnus-carpal-mode ()
1037   "Major mode for clicking buttons.
1038
1039 All normal editing commands are switched off.
1040 \\<gnus-carpal-mode-map>
1041 The following commands are available:
1042
1043 \\{gnus-carpal-mode-map}"
1044   (interactive)
1045   (kill-all-local-variables)
1046   (setq mode-line-modified "-- ")
1047   (setq major-mode 'gnus-carpal-mode)
1048   (setq mode-name "Gnus Carpal")
1049   (setq mode-line-process nil)
1050   (use-local-map gnus-carpal-mode-map)
1051   (buffer-disable-undo (current-buffer))
1052   (setq buffer-read-only t)
1053   (make-local-variable 'gnus-carpal-attached-buffer)
1054   (run-hooks 'gnus-carpal-mode-hook))
1055
1056 (defun gnus-carpal-setup-buffer (type)
1057   (let ((buffer (symbol-value (intern (format "gnus-carpal-%s-buffer" type)))))
1058     (if (get-buffer buffer)
1059         ()
1060       (save-excursion
1061         (set-buffer (get-buffer-create buffer))
1062         (gnus-carpal-mode)
1063         (setq gnus-carpal-attached-buffer
1064               (intern (format "gnus-%s-buffer" type)))
1065         (gnus-add-current-to-buffer-list)
1066         (let ((buttons (symbol-value
1067                         (intern (format "gnus-carpal-%s-buffer-buttons"
1068                                         type))))
1069               (buffer-read-only nil)
1070               button)
1071           (while buttons
1072             (setq button (car buttons)
1073                   buttons (cdr buttons))
1074             (if (stringp button)
1075                 (set-text-properties
1076                  (point)
1077                  (prog2 (insert button) (point) (insert " "))
1078                  (list 'face gnus-carpal-header-face))
1079               (set-text-properties
1080                (point)
1081                (prog2 (insert (car button)) (point) (insert " "))
1082                (list 'gnus-callback (cdr button)
1083                      'face gnus-carpal-button-face
1084                      'mouse-face 'highlight))))
1085           (let ((fill-column (- (window-width) 2)))
1086             (fill-region (point-min) (point-max)))
1087           (set-window-point (get-buffer-window (current-buffer))
1088                             (point-min)))))))
1089
1090 (defun gnus-carpal-select ()
1091   "Select the button under point."
1092   (interactive)
1093   (let ((func (get-text-property (point) 'gnus-callback)))
1094     (if (null func)
1095         ()
1096       (pop-to-buffer (symbol-value gnus-carpal-attached-buffer))
1097       (call-interactively func))))
1098
1099 (defun gnus-carpal-mouse-select (event)
1100   "Select the button under the mouse pointer."
1101   (interactive "e")
1102   (mouse-set-point event)
1103   (gnus-carpal-select))
1104
1105 ;;;
1106 ;;; article highlights
1107 ;;;
1108
1109 ;; Written by Per Abrahamsen <abraham@iesd.auc.dk>.
1110
1111 ;;; Internal Variables:
1112
1113 (defvar gnus-button-regexp nil)
1114 ;; Regexp matching any of the regexps from `gnus-button-alist'.
1115
1116 (defvar gnus-button-last nil)
1117 ;; The value of `gnus-button-alist' when `gnus-button-regexp' was build.
1118
1119 ;;; Commands:
1120
1121 (defun gnus-article-push-button (event)
1122   "Check text under the mouse pointer for a callback function.
1123 If the text under the mouse pointer has a `gnus-callback' property,
1124 call it with the value of the `gnus-data' text property."
1125   (interactive "e")
1126   (set-buffer (window-buffer (posn-window (event-start event))))
1127   (let* ((pos (posn-point (event-start event)))
1128          (data (get-text-property pos 'gnus-data))
1129          (fun (get-text-property pos 'gnus-callback)))
1130     (if fun (funcall fun data))))
1131
1132 (defun gnus-article-press-button ()
1133   "Check text at point for a callback function.
1134 If the text at point has a `gnus-callback' property,
1135 call it with the value of the `gnus-data' text property."
1136   (interactive)
1137   (let* ((data (get-text-property (point) 'gnus-data))
1138          (fun (get-text-property (point) 'gnus-callback)))
1139     (if fun (funcall fun data))))
1140
1141 ;; Suggested by Arne Elofsson <arne@hodgkin.mbi.ucla.edu>
1142 (defun gnus-article-next-button ()
1143   "Move point to next button."
1144   (interactive)
1145   (if (get-text-property (point) 'gnus-callback)
1146       (goto-char (next-single-property-change (point) 'gnus-callback
1147                                               nil (point-max))))
1148   (let ((pos (next-single-property-change (point) 'gnus-callback)))
1149     (if pos
1150         (goto-char pos)
1151       (setq pos (next-single-property-change (point-min) 'gnus-callback))
1152       (if pos
1153           (goto-char pos)
1154         (error "No buttons found")))))
1155
1156 (defun gnus-article-highlight ()
1157   "Highlight current article.
1158 This function calls `gnus-article-highlight-headers',
1159 `gnus-article-highlight-citation',
1160 `gnus-article-highlight-signature', and `gnus-article-add-buttons' to
1161 do the highlighting.  See the documentation for those functions."
1162   (interactive)
1163   (gnus-article-highlight-headers)
1164   (gnus-article-highlight-citation)
1165   (gnus-article-highlight-signature)
1166   (gnus-article-add-buttons))
1167
1168 (defun gnus-article-highlight-some ()
1169   "Highlight current article.
1170 This function calls `gnus-article-highlight-headers',
1171 `gnus-article-highlight-signature', and `gnus-article-add-buttons' to
1172 do the highlighting.  See the documentation for those functions."
1173   (interactive)
1174   (gnus-article-highlight-headers)
1175   (gnus-article-highlight-signature)
1176   (gnus-article-add-buttons))
1177
1178 (defun gnus-article-hide ()
1179   "Hide current article.
1180 This function calls `gnus-article-hide-headers',
1181 `gnus-article-hide-citation-maybe', and `gnus-article-hide-signature'
1182 to do the hiding.  See the documentation for those functions."
1183   (interactive)
1184   (gnus-article-hide-headers)
1185   (gnus-article-hide-citation-maybe)
1186   (gnus-article-hide-signature))
1187
1188 (defun gnus-article-highlight-headers ()
1189   "Highlight article headers as specified by `gnus-header-face-alist'."
1190   (interactive)
1191   (save-excursion
1192     (set-buffer gnus-article-buffer)
1193     (goto-char (point-min))
1194     (if (not (search-forward "\n\n" nil t))
1195         ()
1196       (beginning-of-line 0)
1197       (while (not (bobp))
1198         (let ((alist gnus-header-face-alist)
1199               (buffer-read-only nil)
1200               (case-fold-search t)
1201               (end (point))
1202               (inhibit-point-motion-hooks t)
1203               begin entry regexp header-face field-face
1204               header-found field-found)
1205           (re-search-backward "^[^ \t]" nil t)
1206           (setq begin (point))
1207           (while alist
1208             (setq entry (car alist)
1209                   regexp (nth 0 entry)
1210                   header-face (nth 1 entry)
1211                   field-face (nth 2 entry)
1212                   alist (cdr alist))
1213             (if (looking-at regexp)
1214                 (let ((from (point)))
1215                   (skip-chars-forward "^:\n")
1216                   (and (not header-found)
1217                        header-face
1218                        (progn
1219                          (put-text-property  from (point) 'face header-face)
1220                          (setq header-found t)))
1221                   (and (not field-found)
1222                        field-face
1223                        (progn
1224                          (skip-chars-forward ": \t")
1225                          (let ((from (point)))
1226                            (goto-char end)
1227                            (skip-chars-backward " \t")
1228                            (put-text-property from (point) 'face field-face)
1229                            (setq field-found t))))))
1230             (goto-char begin)))))))
1231
1232 (defun gnus-article-highlight-signature ()
1233   "Highlight the signature in an article.
1234 It does this by highlighting everything after
1235 `gnus-signature-separator' using `gnus-signature-face'."
1236   (interactive)
1237   (save-excursion
1238     (set-buffer gnus-article-buffer)
1239     (let ((buffer-read-only nil)
1240           (inhibit-point-motion-hooks t))
1241       (goto-char (point-max))
1242       (and (re-search-backward gnus-signature-separator nil t)
1243            gnus-signature-face
1244            (let ((start (match-beginning 0))
1245                  (end (match-end 0)))
1246              (gnus-article-add-button start end 'gnus-signature-toggle end)
1247              (gnus-overlay-put (gnus-make-overlay end (point-max))
1248                                'face gnus-signature-face))))))
1249
1250 (defun gnus-article-hide-signature ()
1251   "Hide the signature in an article.
1252 It does this by making everything after `gnus-signature-separator' invisible."
1253   (interactive)
1254   (save-excursion
1255     (set-buffer gnus-article-buffer)
1256     (let ((buffer-read-only nil))
1257       (goto-char (point-max))
1258       (and (re-search-backward gnus-signature-separator nil t)
1259            gnus-signature-face
1260            (add-text-properties (match-end 0) (point-max)
1261                                 gnus-hidden-properties)))))
1262
1263 (defun gnus-article-add-buttons ()
1264   "Find external references in article and make them to buttons.
1265
1266 External references are things like message-ids and URLs, as specified by
1267 `gnus-button-alist'."
1268   (interactive)
1269   (if (eq gnus-button-last gnus-button-alist)
1270       ()
1271     (setq gnus-button-regexp (mapconcat 'car gnus-button-alist  "\\|")
1272           gnus-button-last gnus-button-alist))
1273   (save-excursion
1274     (set-buffer gnus-article-buffer)
1275     (gnus-cite-parse-maybe)
1276     (let ((buffer-read-only nil)
1277           (inhibit-point-motion-hooks t)
1278           (case-fold-search t))
1279       (goto-char (point-min))
1280       (or (search-forward "\n\n" nil t)
1281           (goto-char (point-max)))
1282       (while (re-search-forward gnus-button-regexp nil t)
1283         (goto-char (match-beginning 0))
1284         (let* ((from (point))
1285                (entry (gnus-button-entry))
1286                (start (and entry (match-beginning (nth 1 entry))))
1287                (end (and entry (match-end (nth 1 entry))))
1288                (form (nth 2 entry)))
1289           (if (not entry)
1290               ()
1291             (goto-char (match-end 0))
1292             (if (eval form)
1293                 (gnus-article-add-button start end 'gnus-button-push
1294                                          (set-marker (make-marker)
1295                                                      from)))))))))
1296 (defun gnus-netscape-open-url (url)
1297   "Open URL in netscape, or start new scape with URL."
1298   (let ((process (start-process (concat "netscape " url)
1299                                 nil
1300                                 "netscape"
1301                                 "-remote"
1302                                 (concat "openUrl(" url ")'"))))
1303     (set-process-sentinel process
1304                           (` (lambda (process change)
1305                                (or (eq (process-exit-status process) 0)
1306                                    (gnus-netscape-start-url (, url))))))))
1307
1308 (defun gnus-netscape-start-url (url)
1309   "Start netscape with URL."
1310   (start-process (concat "netscape" url) nil "netscape" url))
1311
1312 ;;; External functions:
1313
1314 (defun gnus-article-add-button (from to fun &optional data)
1315   "Create a button between FROM and TO with callback FUN and data DATA."
1316   (and gnus-article-button-face
1317        (gnus-overlay-put (gnus-make-overlay from to)
1318                          'face gnus-article-button-face))
1319   (add-text-properties from to
1320                        (append (and gnus-article-mouse-face
1321                                     (list 'mouse-face gnus-article-mouse-face))
1322                                (list 'gnus-callback fun)
1323                                (and data (list 'gnus-data data)))))
1324
1325 ;;; Internal functions:
1326
1327 (defun gnus-signature-toggle (end)
1328   (save-excursion
1329     (set-buffer gnus-article-buffer)
1330     (let ((buffer-read-only nil))
1331       (if (get-text-property end 'invisible)
1332           (remove-text-properties end (point-max) gnus-hidden-properties)
1333         (add-text-properties end (point-max) gnus-hidden-properties)))))
1334
1335 ;see gnus-cus.el
1336 ;(defun gnus-make-face (color)
1337 ;  ;; Create entry for face with COLOR.
1338 ;  (if gnus-make-foreground
1339 ;      (custom-face-lookup color nil nil nil nil nil)
1340 ;    (custom-face-lookup nil color nil nil nil nil)))
1341
1342 (defun gnus-button-entry ()
1343   ;; Return the first entry in `gnus-button-alist' matching this place.
1344   (let ((alist gnus-button-alist)
1345         (entry nil))
1346     (while alist
1347       (setq entry (car alist)
1348             alist (cdr alist))
1349       (if (looking-at (car entry))
1350           (setq alist nil)
1351         (setq entry nil)))
1352     entry))
1353
1354 (defun gnus-button-push (marker)
1355   ;; Push button starting at MARKER.
1356   (save-excursion
1357     (set-buffer gnus-article-buffer)
1358     (goto-char marker)
1359     (let* ((entry (gnus-button-entry))
1360            (inhibit-point-motion-hooks t)
1361            (fun (nth 3 entry))
1362            (args (mapcar (lambda (group)
1363                            (let ((string (buffer-substring
1364                                           (match-beginning group)
1365                                           (match-end group))))
1366                              (set-text-properties 0 (length string) nil string)
1367                              string))
1368                          (nthcdr 4 entry))))
1369       (cond ((fboundp fun)
1370              (apply fun args))
1371             ((and (boundp fun)
1372                   (fboundp (symbol-value fun)))
1373              (apply (symbol-value fun) args))
1374             (t
1375              (message "You must define `%S' to use this button"
1376                       (cons fun args)))))))
1377
1378 (defun gnus-button-message-id (message-id)
1379   ;; Push on MESSAGE-ID.
1380   (save-excursion
1381     (set-buffer gnus-summary-buffer)
1382     (gnus-summary-refer-article message-id)))
1383
1384 ;;; Compatibility Functions:
1385
1386 (or (fboundp 'rassoc)
1387     ;; Introduced in Emacs 19.29.
1388     (defun rassoc (elt list)
1389       "Return non-nil if ELT is `equal' to the cdr of an element of LIST.
1390 The value is actually the element of LIST whose cdr is ELT."
1391       (let (result)
1392         (while list
1393           (setq result (car list))
1394           (if (equal (cdr result) elt)
1395               (setq list nil)
1396             (setq result nil
1397                   list (cdr list))))
1398         result)))
1399
1400 ; (require 'gnus-cus)
1401 (gnus-ems-redefine)
1402 (provide 'gnus-vis)
1403
1404 ;;; gnus-vis.el ends here