xemacs-beta: lisp/gnus/gnus-cus.el comparison

comparison lisp/gnus/gnus-cus.el @ 70:131b0175ea99 r20-0b30

Import from CVS: tag r20-0b30

author	cvs
date	Mon, 13 Aug 2007 09:02:59 +0200
parents	ec9a17fef872
children	0d2f883870bc

comparison

equal deleted inserted replaced

-:804d1389bcd6
+:131b0175ea99
-;;; gnus-cus.el --- customization commands for Gnus
+;;; gnus-cus.el --- User friendly customization of Gnus
+;; Copyright (C) 1995,96 Free Software Foundation, Inc.
 ;;
-;; Copyright (C) 1996 Free Software Foundation, Inc.
+;; Author: Per Abrahamsen <abraham@iesd.auc.dk>
+;; Keywords: help, news
-;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
+;; Version: 0.1
-;; Keywords: news
 ;; This file is part of GNU Emacs.
 ;; GNU Emacs is free software; you can redistribute it and/or modify
 ;; it under the terms of the GNU General Public License as published by
 ;; the Free Software Foundation; either version 2, or (at your option)
 ;; any later version.
 ;; GNU Emacs is distributed in the hope that it will be useful,
 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.	 See the
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 ;; GNU General Public License for more details.
 ;; You should have received a copy of the GNU General Public License
 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
 ;;; Commentary:
 ;;; Code:
-(require 'wid-edit)
+(require 'custom)
-(require 'gnus-score)
+(require 'gnus-ems)
+(require 'browse-url)
-;;; Widgets:
+(eval-when-compile (require 'cl))
-;; There should be special validation for this.
+;; The following is just helper functions and data, not meant to be set
-(define-widget 'gnus-email-address 'string
+;; by the user.
-"An email address")
+(defun gnus-make-face (color)
+;; Create entry for face with COLOR.
-(defun gnus-custom-mode ()
+(custom-face-lookup color nil nil nil nil nil))
-"Major mode for editing Gnus customization buffers.
+(defvar gnus-face-light-name-list
-The following commands are available:
+'("light blue" "light cyan" "light yellow" "light pink"
+"pale green" "beige" "orange" "magenta" "violet" "medium purple"
-\\[widget-forward]		Move to next button or editable field.
+"turquoise"))
-\\[widget-backward]		Move to previous button or editable field.
-\\[widget-button-click]		Activate button under the mouse pointer.
+(defvar gnus-face-dark-name-list
-\\[widget-button-press]		Activate button under point.
+'("dark blue" "firebrick" "dark green" "OrangeRed"
+"dark khaki" "dark violet" "SteelBlue4"))
-Entry to this mode calls the value of `gnus-custom-mode-hook'
+; CornflowerBlue SeaGreen OrangeRed SteelBlue4 DeepPink3
-if that value is non-nil."
+; DarkOlviveGreen4
-(kill-all-local-variables)
-(setq major-mode 'gnus-custom-mode
+(custom-declare '()
-	mode-name "Gnus Customize")
+'((tag . "Gnus")
-(use-local-map widget-keymap)
+(doc . "\
-(run-hooks 'gnus-custom-mode-hook))
+The coffee-brewing, all singing, all dancing, kitchen sink newsreader.")
+(type . group)
-;;; Group Customization:
+(data
+((tag . "Visual")
-(defconst gnus-group-parameters
+(doc . "\
-'((to-address (gnus-email-address :tag "To Address") "\
+Gnus can be made colorful and fun or grey and dull as you wish.")
-This will be used when doing followups and posts.
+(type . group)
+(data
-This is primarily useful in mail groups that represent closed
+((tag . "Visual")
-mailing lists--mailing lists where it's expected that everybody that
+	(doc . "Enable visual features.
-writes to the mailing list is subscribed to it.  Since using this
+If `visual' is disabled, there will be no menus and few faces.  Most of
-parameter ensures that the mail only goes to the mailing list itself,
+the visual customization options below will be ignored.  Gnus will use
-it means that members won't receive two copies of your followups.
+less space and be faster as a result.")
+	(default .
-Using `to-address' will actually work whether the group is foreign or
+	  (summary-highlight group-highlight
-not.  Let's say there's a group on the server that is called
+			     article-highlight
-`fa.4ad-l'.  This is a real newsgroup, but the server has gotten the
+			     mouse-face
-articles from a mail-to-news gateway.  Posting directly to this group
+			     summary-menu group-menu article-menu
-is therefore impossible--you have to send mail to the mailing list
+			     tree-highlight menu highlight
-address instead.")
+			     browse-menu server-menu
+			     page-marker tree-menu binary-menu pick-menu
-(to-list (gnus-email-address :tag "To List") "\
+			     grouplens-menu))
-This address will be used when doing a `a' in the group.
+	(name . gnus-visual)
+	(type . sexp))
-It is totally ignored when doing a followup--except that if it is
+((tag . "WWW Browser")
-present in a news group, you'll get mail group semantics when doing
+	(doc . "\
-`f'.")
+WWW Browser to call when clicking on an URL button in the article buffer.
-(broken-reply-to (const :tag "Broken Reply To" t) "\
+You can choose between one of the predefined browsers, or `Other'.")
-Ignore `Reply-To' headers in this group.
+	(name . browse-url-browser-function)
+	(calculate . (cond ((boundp 'browse-url-browser-function)
-That can be useful if you're reading a mailing list group where the
+			    browse-url-browser-function)
-listserv has inserted `Reply-To' headers that point back to the
+			   ((fboundp 'w3-fetch)
-listserv itself.  This is broken behavior.  So there!")
+			    'w3-fetch)
+			   ((eq window-system 'x)
-(to-group (string :tag "To Group") "\
+			    'gnus-netscape-open-url)))
-All posts will be send to the specified group.")
+	(type . choice)
+	(data
-(gcc-self (choice :tag  "GCC"
+	 ((tag . "W3")
-		      :value t
+	  (type . const)
-		      (const t)
+	  (default . w3-fetch))
-		      (const none)
+	 ((tag . "Netscape")
-		      (string :format "%v" :hide-front-space t)) "\
+	  (type . const)
-Specify default value for GCC header.
+	  (default . browse-url-netscape))
+	 ((prompt . "Other")
-If this symbol is present in the group parameter list and set to `t',
+	  (doc . "\
-new composed messages will be `Gcc''d to the current group. If it is
+You must specify the name of a Lisp function here.  The lisp function
-present and set to `none', no `Gcc:' header will be generated, if it
+should open a WWW browser when called with an URL (a string).
-is present and a string, this string will be inserted literally as a
+")
-`gcc' header (this symbol takes precedence over any default `Gcc'
+	  (default . __uninitialized__)
-rules as described later).")
+	  (type . symbol))))
+((tag . "Mouse Face")
-(auto-expire (const :tag "Automatic Expire" t) "\
+	(doc . "\
-All articles that are read will be marked as expirable.")
+Face used for group or summary buffer mouse highlighting.
+The line beneath the mouse pointer will be highlighted with this
-(total-expire (const :tag "Total Expire" t) "\
+face.")
-All read articles will be put through the expiry process
+	(name . gnus-mouse-face)
+	(calculate . (condition-case ()
-This happens even if they are not marked as expirable.
+			 (if (gnus-visual-p 'mouse-face 'highlight)
-Use with caution.")
+			     (if (boundp 'gnus-mouse-face)
+				 gnus-mouse-face
-(expiry-wait (choice :tag  "Expire Wait"
+			       'highlight)
-			 :value never
+			   'default)
-			 (const never)
+		       (error nil)))
-			 (const immediate)
+	(type . face))
-			 (number :hide-front-space t
+((tag . "Article Display")
-				 :format "%v")) "\
+	(doc . "Controls how the article buffer will look.
-When to expire.
+If you leave the list empty, the article will appear exactly as it is
-Overrides any `nnmail-expiry-wait' and `nnmail-expiry-wait-function'
+stored on the disk.  The list entries will hide or highlight various
-when expiring expirable messages. The value can either be a number of
+parts of the article, making it easier to find the information you
-days (not necessarily an integer) or the symbols `never' or
+want.")
-`immediate'.")
+	(name . gnus-article-display-hook)
+	(type . list)
-(score-file (file :tag "Score File") "\
+	(calculate
-Make the specified file into the current score file.
+	 . (if (and (string-match "xemacs" emacs-version)
-This means that all score commands you issue will end up in this file.")
+		    (featurep 'xface))
+	       '(gnus-article-hide-headers-if-wanted
-(adapt-file (file :tag "Adapt File") "\
+		gnus-article-hide-boring-headers
-Make the specified file into the current adaptive file.
+		gnus-article-treat-overstrike
-All adaptive score entries will be put into this file.")
+		gnus-article-maybe-highlight
+		gnus-article-display-x-face)
-(admin-address (gnus-email-address :tag "Admin Address") "\
+	     '(gnus-article-hide-headers-if-wanted
-Administration address for a mailing list.
+	      gnus-article-hide-boring-headers
+	      gnus-article-treat-overstrike
-When unsubscribing to a mailing list you should never send the
+	      gnus-article-maybe-highlight)))
-unsubscription notice to the mailing list itself.  Instead, you'd
+	(data
-send messages to the administrative address.  This parameter allows
+	 ((type . repeat)
-you to put the admin address somewhere convenient.")
+	  (header . nil)
+	  (data
-(display (choice :tag "Display"
+	   (tag . "Filter")
-		     :value default
+	   (type . choice)
-		     (const all)
+	   (data
-		     (const default)) "\
+	    ((tag . "Treat Overstrike")
-Which articles to display on entering the group.
+	     (doc . "\
+Convert use of overstrike into bold and underline.
-`all'
-Display all articles, both read and unread.
+Two identical letters separated by a backspace are displayed as a
+single bold letter, while a letter followed by a backspace and an
-`default'
+underscore will be displayed as a single underlined letter.  This
-Display the default visible articles, which normally includes
+technique was developed for old line printers (think about it), and is
-unread and ticked articles.")
+still in use on some newsgroups, in particular the ClariNet
+hierarchy.
-(comment (string :tag  "Comment") "\
+")
-An arbitrary comment on the group."))
+	     (type . const)
-"Alist of valid group parameters.
+	     (default .
+	       gnus-article-treat-overstrike))
-Each entry has the form (NAME TYPE DOC), where NAME is the parameter
+	    ((tag . "Word Wrap")
-itself (a symbol), TYPE is the parameters type (a sexp widget), and
+	     (doc . "\
-DOC is a documentation string for the parameter.")
+Format too long lines.
+")
-(defvar gnus-custom-params)
+	     (type . const)
-(defvar gnus-custom-method)
+	     (default . gnus-article-word-wrap))
-(defvar gnus-custom-group)
+	    ((tag . "Remove CR")
+	     (doc . "\
-(defun gnus-group-customize (group &optional part)
+Remove carriage returns from an article.
-"Edit the group on the current line."
+")
-(interactive (list (gnus-group-group-name)))
+	     (type . const)
-(let ((part (or part 'info))
+	     (default . gnus-article-remove-cr))
-	info
+	    ((tag . "Display X-Face")
-	(types (mapcar (lambda (entry)
+	     (doc . "\
-			 `(cons :format "%v%h\n"
+Look for an X-Face header and display it if present.
-				:doc ,(nth 2 entry)
-				(const :format "" ,(nth 0 entry))
+See also `X Face Command' for a definition of the external command
-				,(nth 1 entry)))
+used for decoding and displaying the face.
-		       gnus-group-parameters)))
+")
-(unless group
+	     (type . const)
-(error "No group on current line"))
+	     (default . gnus-article-display-x-face))
-(unless (setq info (gnus-get-info group))
+	    ((tag . "Unquote Printable")
-(error "Killed group; can't be edited"))
+	     (doc . "\
-;; Ready.
+Transform MIME quoted printable into 8-bit characters.
-(kill-buffer (get-buffer-create "*Gnus Customize*"))
-(switch-to-buffer (get-buffer-create "*Gnus Customize*"))
+Quoted printable is often seen by strings like `=EF' where you would
-(gnus-custom-mode)
+expect a non-English letter.
-(make-local-variable 'gnus-custom-group)
+")
-(setq gnus-custom-group group)
+	     (type . const)
-(widget-insert "Customize the ")
+	     (default .
-(widget-create 'info-link
+	       gnus-article-de-quoted-unreadable))
-		   :help-echo "Push me to learn more."
+	    ((tag . "Universal Time")
-		   :tag "group parameters"
+	     (doc . "\
-		   "(gnus)Group Parameters")
+Convert date header to universal time.
-(widget-insert " for <")
+")
-(widget-insert group)
+	     (type . const)
-(widget-insert "> and press ")
+	     (default . gnus-article-date-ut))
-(widget-create 'push-button
+	    ((tag . "Local Time")
-		   :tag "done"
+	     (doc . "\
-		   :help-echo "Push me when done customizing."
+Convert date header to local timezone.
-		   :action 'gnus-group-customize-done)
+")
-(widget-insert ".\n\n")
+	     (type . const)
-(make-local-variable 'gnus-custom-params)
+	     (default . gnus-article-date-local))
-(setq gnus-custom-params
+	    ((tag . "Lapsed Time")
-	  (widget-create 'group
+	     (doc . "\
-			 :value (gnus-info-params info)
+Replace date header with a header showing the articles age.
-			 `(set :inline t
+")
-			       :greedy t
+	     (type . const)
-			       :tag "Parameters"
+	     (default . gnus-article-date-lapsed))
-			       :format "%t:\n%h%v"
+	    ((tag . "Highlight")
-			       :doc "\
+	     (doc . "\
-These special paramerters are recognized by Gnus.
+Highlight headers, citations, signature, and buttons.
-Check the [ ] for the parameters you want to apply to this group, then
+")
-edit the value to suit your taste."
+	     (type . const)
-			       ,@types)
+	     (default . gnus-article-highlight))
-			 '(repeat :inline t
+	    ((tag . "Maybe Highlight")
-				  :tag "Variables"
+	     (doc . "\
-				  :format "%t:\n%h%v%i\n\n"
+Highlight headers, signature, and buttons if `Visual' is turned on.
-				  :doc "\
+")
-Set variables local to the group you are entering.
+	     (type . const)
+	     (default .
-If you want to turn threading off in `news.answers', you could put
+	       gnus-article-maybe-highlight))
-`(gnus-show-threads nil)' in the group parameters of that group.
+	    ((tag . "Highlight Some")
-`gnus-show-threads' will be made into a local variable in the summary
+	     (doc . "\
-buffer you enter, and the form `nil' will be `eval'ed there.
+Highlight headers, signature, and buttons.
+")
-This can also be used as a group-specific hook function, if you'd
+	     (type . const)
-like.  If you want to hear a beep when you enter a group, you could
+	     (default . gnus-article-highlight-some))
-put something like `(dummy-variable (ding))' in the parameters of that
+	    ((tag . "Highlight Headers")
-group.  `dummy-variable' will be set to the result of the `(ding)'
+	     (doc . "\
-form, but who cares?"
+Highlight headers as specified by `Article Header Highlighting'.
-				  (group :value (nil nil)
+")
-					 (symbol :tag "Variable")
+	     (type . const)
-					 (sexp :tag
+	     (default .
-					       "Value")))
+	       gnus-article-highlight-headers))
+	    ((tag . "Highlight Signature")
-			 '(repeat :inline t
+	     (doc . "\
-				  :tag "Unknown entries"
+Highlight the signature as specified by `Article Signature Face'.
-				  sexp)))
+")
-(widget-insert "\n\nYou can also edit the ")
+	     (type . const)
-(widget-create 'info-link
+	     (default .
-		   :tag "select method"
+	       gnus-article-highlight-signature))
-		   :help-echo "Push me to learn more about select methods."
+	    ((tag . "Citation")
-		   "(gnus)Select Methods")
+	     (doc . "\
-(widget-insert " for the group.\n")
+Highlight the citations as specified by `Citation Faces'.
-(setq gnus-custom-method
+")
-	  (widget-create 'sexp
+	     (type . const)
-			 :tag "Method"
+	     (default .
-			 :value (gnus-info-method info)))
+	       gnus-article-highlight-citation))
-(use-local-map widget-keymap)
+	    ((tag . "Hide")
-(widget-setup)))
+	     (doc . "\
+Hide unwanted headers, excess citation, and the signature.
-(defun gnus-group-customize-done (&rest ignore)
+")
-"Apply changes and bury the buffer."
+	     (type . const)
-(interactive)
+	     (default . gnus-article-hide))
-(gnus-group-edit-group-done 'params gnus-custom-group
+	    ((tag . "Hide Headers If Wanted")
-			      (widget-value gnus-custom-params))
+	     (doc . "\
-(gnus-group-edit-group-done 'method gnus-custom-group
+Hide headers, but allow user to display them with `t' or `v'.
-			      (widget-value gnus-custom-method))
+")
-(bury-buffer))
+	     (type . const)
+	     (default .
-;;; Score Customization:
+	       gnus-article-hide-headers-if-wanted))
+	    ((tag . "Hide Headers")
-(defconst gnus-score-parameters
+	     (doc . "\
-'((mark (number :tag "Mark") "\
+Hide unwanted headers and possibly sort them as well.
-The value of this entry should be a number.
+Most likely you want to use `Hide Headers If Wanted' instead.
-Any articles with a score lower than this number will be marked as read.")
+")
+	     (type . const)
-(expunge (number :tag "Expunge") "\
+	     (default . gnus-article-hide-headers))
-The value of this entry should be a number.
+	    ((tag . "Hide Signature")
-Any articles with a score lower than this number will be removed from
+	     (doc . "\
-the summary buffer.")
+Hide the signature.
+")
-(mark-and-expunge (number :tag "Mark-and-expunge") "\
+	     (type . const)
-The value of this entry should be a number.
+	     (default . gnus-article-hide-signature))
-Any articles with a score lower than this number will be marked as
+	    ((tag . "Hide Excess Citations")
-read and removed from the summary buffer.")
+	     (doc . "\
+Hide excess citation.
-(thread-mark-and-expunge (number :tag "Thread-mark-and-expunge") "\
-The value of this entry should be a number.
+Excess is defined by `Citation Hide Percentage' and `Citation Hide Absolute'.
-All articles that belong to a thread that has a total score below this
+")
-number will be marked as read and removed from the summary buffer.
+	     (type . const)
-`gnus-thread-score-function' says how to compute the total score
+	     (default .
-for a thread.")
+	       gnus-article-hide-citation-maybe))
+	    ((tag . "Hide Citations")
-(files (repeat :tag "Files" file) "\
+	     (doc . "\
-The value of this entry should be any number of file names.
+Hide all cited text.
-These files are assumed to be score files as well, and will be loaded
+")
-the same way this one was.")
+	     (type . const)
+	     (default . gnus-article-hide-citation))
-(exclude-files (repeat :tag "Exclude-files" file) "\
+	    ((tag . "Add Buttons")
-The clue of this entry should be any number of files.
+	     (doc . "\
-These files will not be loaded, even though they would normally be so,
+Make URL's into clickable buttons.
-for some reason or other.")
+")
+	     (type . const)
-(eval (sexp :tag "Eval" :value nil) "\
+	     (default . gnus-article-add-buttons))
-The value of this entry will be `eval'el.
+	    ((prompt . "Other")
-This element will be ignored when handling global score files.")
+	     (doc . "\
+Name of Lisp function to call.
-(read-only (boolean :tag "Read-only" :value t) "\
-Read-only score files will not be updated or saved.
+Push the `Filter' button to select one of the predefined filters.
-Global score files should feature this atom.")
+")
+	     (type . symbol)))))))
-(orphan (number :tag "Orphan") "\
+((tag . "Article Button Face")
-The value of this entry should be a number.
+	(doc . "\
-Articles that do not have parents will get this number added to their
+Face used for highlighting buttons in the article buffer.
-scores.  Imagine you follow some high-volume newsgroup, like
-`comp.lang.c'.  Most likely you will only follow a few of the threads,
+An article button is a piece of text that you can activate by pressing
-also want to see any new threads.
+`RET' or `mouse-2' above it.")
+	(name . gnus-article-button-face)
-You can do this with the following two score file entries:
+	(default . bold)
+	(type . face))
-(orphan -500)
+((tag . "Article Mouse Face")
-(mark-and-expunge -100)
+	(doc . "\
+Face used for mouse highlighting in the article buffer.
-When you enter the group the first time, you will only see the new
-threads.  You then raise the score of the threads that you find
+Article buttons will be displayed in this face when the cursor is
-interesting (with `I T' or `I S'), and ignore (`C y') the rest.
+above them.")
-Next time you enter the group, you will see new articles in the
+	(name . gnus-article-mouse-face)
-interesting threads, plus any new threads.
+	(default . highlight)
+	(type . face))
-I.e.---the orphan score atom is for high-volume groups where there
+((tag . "Article Signature Face")
-exist a few interesting threads which can't be found automatically
+	(doc . "\
-by ordinary scoring rules.")
+Face used for highlighting a signature in the article buffer.")
+	(name . gnus-signature-face)
-(adapt (choice :tag "Adapt"
+	(default . italic)
-		   (const t)
+	(type . face))
-		   (const ignore)
+((tag . "Article Header Highlighting")
-		   (sexp :format "%v"
+	(doc . "\
-			 :hide-front-space t)) "\
+Controls highlighting of article header.
-This entry controls the adaptive scoring.
-If it is `t', the default adaptive scoring rules will be used.  If it
+Below is a list of article header names, and the faces used for
-is `ignore', no adaptive scoring will be performed on this group.  If
+displaying the name and content of the header.  The `Header' field
-it is a list, this list will be used as the adaptive scoring rules.
+should contain the name of the header.  The field actually contains a
-If it isn't present, or is something other than `t' or `ignore', the
+regular expression that should match the beginning of the header line,
-default adaptive scoring rules will be used.  If you want to use
+but if you don't know what a regular expression is, just write the
-adaptive scoring on most groups, you'd set `gnus-use-adaptive-scoring'
+name of the header.  The second field is the `Name' field, which
-to `t', and insert an `(adapt ignore)' in the groups where you do not
+determines how the header name (i.e. the part of the header left
-want adaptive scoring.  If you only want adaptive scoring in a few
+of the `:') is displayed.  The third field is the `Content' field,
-groups, you'd set `gnus-use-adaptive-scoring' to `nil', and insert
+which determines how the content (i.e. the part of the header right of
-`(adapt t)' in the score files of the groups where you want it.")
+the `:') is displayed.
-(adapt-file (file :tag "Adapt-file") "\
+If you leave the last `Header' field in the list empty, the `Name' and
-All adaptive score entries will go to the file named by this entry.
+`Content' fields will determine how headers not listed above are
-It will also be applied when entering the group.  This atom might
+displayed.
-be handy if you want to adapt on several groups at once, using the
-same adaptive file for a number of groups.")
+If you only want to change the display of the name part for a specific
+header, specify `None' in the `Content' field.  Similarly, specify
-(local (repeat :tag "Local"
+`None' in the `Name' field if you only want to leave the name part
-		   (group :value (nil nil)
+alone.")
-			  (symbol :tag "Variable")
+	(name . gnus-header-face-alist)
-			  (sexp :tag "Value"))) "\
+	(type . list)
-The value of this entry should be a list of `(VAR VALUE)' pairs.
+	(calculate
-Each VAR will be made buffer-local to the current summary buffer,
+	 . (cond
-and set to the value specified.  This is a convenient, if somewhat
+	    ((not (eq gnus-display-type 'color))
-strange, way of setting variables in some groups if you don't like
+	     '(("" bold italic)))
-hooks much.")
+	    ((eq gnus-background-mode 'dark)
-(touched (sexp :format "Touched\n") "Internal variable."))
+	     (list
-"Alist of valid symbolic score parameters.
+	      (list "From" nil
+		    (custom-face-lookup "light blue" nil nil t t nil))
-Each entry has the form (NAME TYPE DOC), where NAME is the parameter
+	      (list "Subject" nil
-itself (a symbol), TYPE is the parameters type (a sexp widget), and DOC is a
+		    (custom-face-lookup "pink" nil nil t t nil))
-documentation string for the parameter.")
+	      (list "Newsgroups:.*," nil
+		    (custom-face-lookup "yellow" nil nil t t nil))
-(define-widget 'gnus-score-string 'group
+	      (list
-"Edit score entries for string-valued headers."
+	       ""
-:convert-widget 'gnus-score-string-convert)
+	       (custom-face-lookup "cyan" nil nil t nil nil)
+	       (custom-face-lookup "forestgreen" nil nil nil t
-(defun gnus-score-string-convert (widget)
+				   nil))))
-;; Set args appropriately.
+	    (t
-(let* ((tag (widget-get widget :tag))
+	     (list
-	 (item `(const :format "" :value ,(downcase tag)))
+	      (list "From" nil
-	 (match '(string :tag "Match"))
+		    (custom-face-lookup "MidnightBlue" nil nil t t nil))
-	 (score '(choice :tag "Score"
+	      (list "Subject" nil
-			(const :tag "default" nil)
+		    (custom-face-lookup "firebrick" nil nil t t nil))
-			(integer :format "%v"
+	      (list "Newsgroups:.*," nil
-				 :hide-front-space t)))
+		    (custom-face-lookup "indianred" nil nil t t nil))
-	 (expire '(choice :tag "Expire"
+	      (list ""
-			  (const :tag "off" nil)
+		    (custom-face-lookup
-			  (integer :format "%v"
+		     "DarkGreen" nil nil t nil nil)
-				   :hide-front-space t)))
+		    (custom-face-lookup "DarkGreen" nil nil
-	 (type '(choice :tag "Type"
+					nil t nil))))))
-			:value s
+	(data
-			;; I should really create a forgiving :match
+	 ((type . repeat)
-			;; function for each type below, that only
+	  (header . nil)
-			;; looked at the first letter.
+	  (data
-			(const :tag "Regexp" r)
+	   (type . list)
-			(const :tag "Regexp (fixed case)" R)
+	   (compact . t)
-			(const :tag "Substring" s)
+	   (data
-			(const :tag "Substring (fixed case)" S)
+	    ((type . string)
-			(const :tag "Exact" e)
+	     (prompt . "Header")
-			(const :tag "Exact (fixed case)" E)
+	     (tag . "Header "))
-			(const :tag "Word" w)
+	    "\n            "
-			(const :tag "Word (fixed case)" W)
+	    ((type . face)
-			(const :tag "default" nil)))
+	     (prompt . "Name")
-	 (group `(group ,match ,score ,expire ,type))
+	     (tag . "Name   "))
-	 (doc (concat (or (widget-get widget :doc)
+	    "\n            "
-			  (concat "Change score based on the " tag
+	    ((type . face)
-				  " header.\n"))
+	     (tag . "Content"))
-		      "
+	    "\n")))))
-You can have an arbitrary number of score entries for this header,
+((tag . "Attribution Face")
-each score entry has four elements:
+	(doc . "\
+Face used for attribution lines.
-1. The \"match element\".  This should be the string to look for in the
+It is merged with the face for the cited text belonging to the attribution.")
-header.
+	(name . gnus-cite-attribution-face)
+	(default . underline)
-2. The \"score element\".  This number should be an integer in the
+	(type . face))
-neginf to posinf interval.  This number is added to the score
+((tag . "Citation Faces")
-of the article if the match is successful.  If this element is
+	(doc . "\
-not present, the `gnus-score-interactive-default-score' number
+List of faces used for highlighting citations.
-will be used instead.  This is 1000 by default.
+When there are citations from multiple articles in the same message,
-3. The \"date element\".  This date says when the last time this score
+Gnus will try to give each citation from each article its own face.
-entry matched, which provides a mechanism for expiring the
+This should make it easier to see who wrote what.")
-score entries.  It this element is not present, the score
+	(name . gnus-cite-face-list)
-entry is permanent.  The date is represented by the number of
+	(import . gnus-custom-import-cite-face-list)
-days since December 31, 1 ce.
+	(type . list)
+	(calculate . (cond ((not (eq gnus-display-type 'color))
-4. The \"type element\".  This element specifies what function should
+			    '(italic))
-be used to see whether this score entry matches the article.
+			   ((eq gnus-background-mode 'dark)
+			    (mapcar 'gnus-make-face
-There are the regexp, as well as substring types, and exact match,
+				    gnus-face-light-name-list))
-and word match types.  If this element is not present, Gnus will
+			   (t
-assume that substring matching should be used.  There is case
+			    (mapcar 'gnus-make-face
-sensitive variants of all match types.")))
+				    gnus-face-dark-name-list))))
-(widget-put widget :args `(,item
+	(data
-			       (repeat :inline t
+	 ((type . repeat)
-				       :indent 0
+	  (header . nil)
-				       :tag ,tag
+	  (data (type . face)
-				       :doc ,doc
+		(tag . "Face")))))
-				       :format "%t:\n%h%v%i\n\n"
+((tag . "Citation Hide Percentage")
-				       (choice :format "%v"
+	(doc . "\
-					       :value ("" nil nil s)
+Only hide excess citation if above this percentage of the body.")
-					       ,group
+	(name . gnus-cite-hide-percentage)
-					       sexp)))))
+	(default . 50)
-widget)
+	(type . integer))
+((tag . "Citation Hide Absolute")
-(define-widget 'gnus-score-integer 'group
+	(doc . "\
-"Edit score entries for integer-valued headers."
+Only hide excess citation if above this number of lines in the body.")
-:convert-widget 'gnus-score-integer-convert)
+	(name . gnus-cite-hide-absolute)
+	(default . 10)
-(defun gnus-score-integer-convert (widget)
+	(type . integer))
-;; Set args appropriately.
+((tag . "Summary Selected Face")
-(let* ((tag (widget-get widget :tag))
+	(doc . "\
-	 (item `(const :format "" :value ,(downcase tag)))
+Face used for highlighting the current article in the summary buffer.")
-	 (match '(integer :tag "Match"))
+	(name . gnus-summary-selected-face)
-	 (score '(choice :tag "Score"
+	(default . underline)
-			(const :tag "default" nil)
+	(type . face))
-			(integer :format "%v"
+((tag . "Summary Line Highlighting")
-				 :hide-front-space t)))
+	(doc . "\
-	 (expire '(choice :tag "Expire"
+Controls the highlighting of summary buffer lines.
-			  (const :tag "off" nil)
-			  (integer :format "%v"
+Below is a list of `Form'/`Face' pairs.  When deciding how a a
-				   :hide-front-space t)))
+particular summary line should be displayed, each form is
-	 (type '(choice :tag "Type"
+evaluated. The content of the face field after the first true form is
-			:value <
+used.  You can change how those summary lines are displayed, by
-			(const <)
+editing the face field.
-			(const >)
-			(const =)
+It is also possible to change and add form fields, but currently that
-			(const >=)
+requires an understanding of Lisp expressions.  Hopefully this will
-			(const <=)))
+change in a future release.  For now, you can use the following
-	 (group `(group ,match ,score ,expire ,type))
+variables in the Lisp expression:
-	 (doc (concat (or (widget-get widget :doc)
-			  (concat "Change score based on the " tag
+score:   The article's score
-				  " header.")))))
+default: The default article score.
-(widget-put widget :args `(,item
+below:   The score below which articles are automatically marked as read.
-			       (repeat :inline t
+mark:    The article's mark.")
-				       :indent 0
+	(name . gnus-summary-highlight)
-				       :tag ,tag
+	(type . list)
-				       :doc ,doc
+	(calculate
-				       :format "%t:\n%h%v%i\n\n"
+	 . (cond
-				       ,group))))
+	    ((not (eq gnus-display-type 'color))
-widget)
+	     '(((> score default) . bold)
+	       ((< score default) . italic)))
-(define-widget 'gnus-score-date 'group
+	    ((eq gnus-background-mode 'dark)
-"Edit score entries for date-valued headers."
+	     (list
-:convert-widget 'gnus-score-date-convert)
+	      (cons
+	       '(= mark gnus-canceled-mark)
-(defun gnus-score-date-convert (widget)
+	       (custom-face-lookup "yellow" "black" nil
-;; Set args appropriately.
+				   nil nil nil))
-(let* ((tag (widget-get widget :tag))
+	      (cons '(and (> score default)
-	 (item `(const :format "" :value ,(downcase tag)))
+			  (or (= mark gnus-dormant-mark)
-	 (match '(string :tag "Match"))
+			      (= mark gnus-ticked-mark)))
-	 (score '(choice :tag "Score"
+		    (custom-face-lookup
-			(const :tag "default" nil)
+		     "pink" nil nil t nil nil))
-			(integer :format "%v"
+	      (cons '(and (< score default)
-				 :hide-front-space t)))
+			  (or (= mark gnus-dormant-mark)
-	 (expire '(choice :tag "Expire"
+			      (= mark gnus-ticked-mark)))
-			  (const :tag "off" nil)
+		    (custom-face-lookup "pink" nil nil
-			  (integer :format "%v"
+					nil t nil))
-				   :hide-front-space t)))
+	      (cons '(or (= mark gnus-dormant-mark)
-	 (type '(choice :tag "Type"
+			 (= mark gnus-ticked-mark))
-			:value regexp
+		    (custom-face-lookup
-			(const regexp)
+		     "pink" nil nil nil nil nil))
-			(const before)
-			(const at)
+	      (cons
-			(const after)))
+	       '(and (> score default) (= mark gnus-ancient-mark))
-	 (group `(group ,match ,score ,expire ,type))
+	       (custom-face-lookup "medium blue" nil nil t
-	 (doc (concat (or (widget-get widget :doc)
+				   nil nil))
-			  (concat "Change score based on the " tag
+	      (cons
-				  " header."))
+	       '(and (< score default) (= mark gnus-ancient-mark))
-		      "
+	       (custom-face-lookup "SkyBlue" nil nil
-For the Date header we have three kinda silly match types: `before',
+				   nil t nil))
-`at' and `after'.  I can't really imagine this ever being useful, but,
+	      (cons
-like, it would feel kinda silly not to provide this function.  Just in
+	       '(= mark gnus-ancient-mark)
-case.  You never know.  Better safe than sorry.  Once burnt, twice
+	       (custom-face-lookup "SkyBlue" nil nil
-shy.  Don't judge a book by its cover.  Never not have sex on a first
+				   nil nil nil))
-date.  (I have been told that at least one person, and I quote,
+	      (cons '(and (> score default) (= mark gnus-unread-mark))
-\"found this function indispensable\", however.)
+		    (custom-face-lookup "white" nil nil t
+					nil nil))
-A more useful match type is `regexp'.  With it, you can match the date
+	      (cons '(and (< score default) (= mark gnus-unread-mark))
-string using a regular expression.  The date is normalized to ISO8601
+		    (custom-face-lookup "white" nil nil
-compact format first---`YYYYMMDDTHHMMSS'.  If you want to match all
+					nil t nil))
-articles that have been posted on April 1st in every year, you could
+	      (cons '(= mark gnus-unread-mark)
-use `....0401.........' as a match string, for instance.  (Note that
+		    (custom-face-lookup
-the date is kept in its original time zone, so this will match
+		     "white" nil nil nil nil nil))
-articles that were posted when it was April 1st where the article was
-posted from.  Time zones are such wholesome fun for the whole family,
+	      (cons '(> score default) 'bold)
-eh?")))
+	      (cons '(< score default) 'italic)))
-(widget-put widget :args `(,item
+	    (t
-			       (repeat :inline t
+	     (list
-				       :indent 0
+	      (cons
-				       :tag ,tag
+	       '(= mark gnus-canceled-mark)
-				       :doc ,doc
+	       (custom-face-lookup
-				       :format "%t:\n%h%v%i\n\n"
+		"yellow" "black" nil nil nil nil))
-				       ,group))))
+	      (cons '(and (> score default)
-widget)
+			  (or (= mark gnus-dormant-mark)
+			      (= mark gnus-ticked-mark)))
-(defvar gnus-custom-scores)
+		    (custom-face-lookup "firebrick" nil nil
-(defvar gnus-custom-score-alist)
+					t nil nil))
+	      (cons '(and (< score default)
-(defun gnus-score-customize (file)
+			  (or (= mark gnus-dormant-mark)
-"Customize score file FILE."
+			      (= mark gnus-ticked-mark)))
-(interactive (list gnus-current-score-file))
+		    (custom-face-lookup "firebrick" nil nil
-(let ((scores (gnus-score-load file))
+					nil t nil))
-	(types (mapcar (lambda (entry)
+	      (cons
-		 `(group :format "%v%h\n"
+	       '(or (= mark gnus-dormant-mark)
-			 :doc ,(nth 2 entry)
+		    (= mark gnus-ticked-mark))
-			 (const :format "" ,(nth 0 entry))
+	       (custom-face-lookup
-			 ,(nth 1 entry)))
+		"firebrick" nil nil nil nil nil))
-	       gnus-score-parameters)))
-;; Ready.
+	      (cons '(and (> score default) (= mark gnus-ancient-mark))
-(kill-buffer (get-buffer-create "*Gnus Customize*"))
+		    (custom-face-lookup "RoyalBlue" nil nil
-(switch-to-buffer (get-buffer-create "*Gnus Customize*"))
+					t nil nil))
-(gnus-custom-mode)
+	      (cons '(and (< score default) (= mark gnus-ancient-mark))
-(make-local-variable 'gnus-custom-score-alist)
+		    (custom-face-lookup "RoyalBlue" nil nil
-(setq gnus-custom-score-alist scores)
+					nil t nil))
-(widget-insert "Customize the ")
+	      (cons
-(widget-create 'info-link
+	       '(= mark gnus-ancient-mark)
-		   :help-echo "Push me to learn more."
+	       (custom-face-lookup
-		   :tag "score entries"
+		"RoyalBlue" nil nil nil nil nil))
-		   "(gnus)Score File Format")
-(widget-insert " for\n\t")
+	      (cons '(and (> score default) (/= mark gnus-unread-mark))
-(widget-insert file)
+		    (custom-face-lookup "DarkGreen" nil nil
-(widget-insert "\nand press ")
+					t nil nil))
-(widget-create 'push-button
+	      (cons '(and (< score default) (/= mark gnus-unread-mark))
-		   :tag "done"
+		    (custom-face-lookup "DarkGreen" nil nil
-		   :help-echo "Push me when done customizing."
+					nil t nil))
-		   :action 'gnus-score-customize-done)
+	      (cons
-(widget-insert ".\n
+	       '(/= mark gnus-unread-mark)
-Check the [ ] for the entries you want to apply to this score file, then
+	       (custom-face-lookup "DarkGreen" nil nil
-edit the value to suit your taste.  Don't forget to mark the checkbox,
+				   nil nil nil))
-if you do all your changes will be lost.  ")
-(widget-create 'push-button
+	      (cons '(> score default) 'bold)
-		   :action (lambda (&rest ignore)
+	      (cons '(< score default) 'italic)))))
-			     (require 'gnus-audio)
+	(data
-			     (gnus-audio-play "Evil_Laugh.au"))
+	 ((type . repeat)
-		   "Bhahahah!")
+	  (header . nil)
-(widget-insert "\n\n")
+	  (data (type . pair)
-(make-local-variable 'gnus-custom-scores)
+		(compact . t)
-(setq gnus-custom-scores
+		(data ((type . sexp)
-	  (widget-create 'group
+		       (width . 60)
-			 :value scores
+		       (tag . "Form"))
-			 `(checklist :inline t
+		      "\n            "
-				     :greedy t
+		      ((type . face)
-				     (gnus-score-string :tag "From")
+		       (tag . "Face"))
-				     (gnus-score-string :tag "Subject")
+		      "\n")))))
-				     (gnus-score-string :tag "References")
-				     (gnus-score-string :tag "Xref")
+((tag . "Group Line Highlighting")
-				     (gnus-score-string :tag "Message-ID")
+	(doc . "\
-				     (gnus-score-integer :tag "Lines")
+Controls the highlighting of group buffer lines.
-				     (gnus-score-integer :tag "Chars")
-				     (gnus-score-date :tag "Date")
+Below is a list of `Form'/`Face' pairs.  When deciding how a a
-				     (gnus-score-string :tag "Head"
+particular group line should be displayed, each form is
-							:doc "\
+evaluated. The content of the face field after the first true form is
-Match all headers in the article.
+used.  You can change how those group lines are displayed by
+editing the face field.
-Using one of `Head', `Body', `All' will slow down scoring considerable.
-")
+It is also possible to change and add form fields, but currently that
-				     (gnus-score-string :tag "Body"
+requires an understanding of Lisp expressions.  Hopefully this will
-							:doc "\
+change in a future release.  For now, you can use the following
-Match the body sans header of the article.
+variables in the Lisp expression:
-Using one of `Head', `Body', `All' will slow down scoring considerable.
+group: The name of the group.
-")
+unread: The number of unread articles in the group.
-				     (gnus-score-string :tag "All"
+method: The select method used.
-							:doc "\
+mailp: Whether it's a mail group or not.
-Match the entire article, including both headers and body.
+level: The level of the group.
+score: The score of the group.
-Using one of `Head', `Body', `All' will slow down scoring
+ticked: The number of ticked articles.")
-considerable.
+	(name . gnus-group-highlight)
-")
+	(type . list)
-				     (gnus-score-string :tag
+	(calculate
-							"Followup"
+	 . (cond
-							:doc "\
+	    ((not (eq gnus-display-type 'color))
-Score all followups to the specified authors.
+	     '((mailp . bold)
+	       ((= unread 0) . italic)))
-This entry is somewhat special, in that it will match the `From:'
+	    ((eq gnus-background-mode 'dark)
-header, and affect the score of not only the matching articles, but
+	     `(((and (not mailp) (eq level 1)) .
-also all followups to the matching articles.  This allows you
+		,(custom-face-lookup "PaleTurquoise" nil nil t))
-e.g. increase the score of followups to your own articles, or decrease
+	       ((and (not mailp) (eq level 2)) .
-the score of followups to the articles of some known trouble-maker.
+		,(custom-face-lookup "turquoise" nil nil t))
-")
+	       ((and (not mailp) (eq level 3)) .
-				     (gnus-score-string :tag "Thread"
+		,(custom-face-lookup "MediumTurquoise" nil nil t))
-							:doc "\
+	       ((and (not mailp) (>= level 4)) .
-Add a score entry on all articles that are part of a thread.
+		,(custom-face-lookup "DarkTurquoise" nil nil t))
+	       ((and mailp (eq level 1)) .
-This match key works along the same lines as the `Followup' match key.
+		,(custom-face-lookup "aquamarine1" nil nil t))
-If you say that you want to score on a (sub-)thread that is started by
+	       ((and mailp (eq level 2)) .
-an article with a `Message-ID' X, then you add a `thread' match.  This
+		,(custom-face-lookup "aquamarine2" nil nil t))
-will add a new `thread' match for each article that has X in its
+	       ((and mailp (eq level 3)) .
-`References' header.  (These new `thread' matches will use the
+		,(custom-face-lookup "aquamarine3" nil nil t))
-`Message-ID's of these matching articles.)  This will ensure that you
+	       ((and mailp (>= level 4)) .
-can raise/lower the score of an entire thread, even though some
+		,(custom-face-lookup "aquamarine4" nil nil t))
-articles in the thread may not have complete `References' headers.
+	       ))
-Note that using this may lead to undeterministic scores of the
+	    (t
-articles in the thread.
+	     `(((and (not mailp) (<= level 3)) .
-")
+		,(custom-face-lookup "ForestGreen" nil nil t))
-				     ,@types)
+	       ((and (not mailp) (eq level 4)) .
-			 '(repeat :inline t
+		,(custom-face-lookup "DarkGreen" nil nil t))
-				  :tag "Unknown entries"
+	       ((and (not mailp) (eq level 5)) .
-				  sexp)))
+		,(custom-face-lookup "CadetBlue4" nil nil t))
-(use-local-map widget-keymap)
+	       ((and mailp (eq level 1)) .
-(widget-setup)))
+		,(custom-face-lookup "DeepPink3" nil nil t))
+	       ((and mailp (eq level 2)) .
-(defun gnus-score-customize-done (&rest ignore)
+		,(custom-face-lookup "HotPink3" nil nil t))
-"Reset the score alist with the present value."
+	       ((and mailp (eq level 3)) .
-(let ((alist gnus-custom-score-alist)
+		,(custom-face-lookup "dark magenta" nil nil t))
-	(value (widget-value gnus-custom-scores)))
+	       ((and mailp (eq level 4)) .
-(setcar alist (car value))
+		,(custom-face-lookup "DeepPink4" nil nil t))
-(setcdr alist (cdr value))
+	       ((and mailp (> level 4)) .
-(gnus-score-set 'touched '(t) alist))
+		,(custom-face-lookup "DarkOrchid4" nil nil t))
-(bury-buffer))
+	       ))))
+	(data
-;;; The End:
+	 ((type . repeat)
+	  (header . nil)
+	  (data (type . pair)
+		(compact . t)
+		(data ((type . sexp)
+		       (width . 60)
+		       (tag . "Form"))
+		      "\n            "
+		      ((type . face)
+		       (tag . "Face"))
+		      "\n")))))
+;; Do not define `gnus-button-alist' before we have
+;; some `complexity' attribute so we can hide it from
+;; beginners.
+)))))
+(defun gnus-custom-import-cite-face-list (custom alist)
+;; Backward compatible grokking of light and dark.
+(cond ((eq alist 'light)
+	 (setq alist (mapcar 'gnus-make-face gnus-face-light-name-list)))
+	((eq alist 'dark)
+	 (setq alist (mapcar 'gnus-make-face gnus-face-dark-name-list))))
+(funcall (custom-super custom 'import) custom alist))
 (provide 'gnus-cus)
 ;;; gnus-cus.el ends here

Mercurial > hg > xemacs-beta

comparison lisp/gnus/gnus-cus.el @ 70:131b0175ea99 r20-0b30