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

comparison lisp/gnus/gnus-cus.el @ 98:0d2f883870bc r20-1b1

Import from CVS: tag r20-1b1

author	cvs
date	Mon, 13 Aug 2007 09:13:56 +0200
parents	131b0175ea99
children	8ff55ebd4be9

comparison

equal deleted inserted replaced

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