comparison lisp/gnus/gnus-score.el @ 88155:d7ddb3e565de

sync with trunk

88154:8ce476d3ba36

;;; gnus-score.el --- scoring code for Gnus
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001
;;        Free Software Foundation, Inc.

;; Author: Per Abrahamsen <[e-mail]>
;;	Lars Magne Ingebrigtsen <[e-mail]>
;; Keywords: news

;; 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,
;; Boston, MA 02111-1307, USA.

;;; Commentary:

;;; Code:

(eval-when-compile (require 'cl))

(require 'gnus)
(require 'gnus-sum)
(require 'gnus-range)
(require 'message)
(require 'score-mode)

(defcustom gnus-global-score-files nil
  "List of global score files and directories.
Set this variable if you want to use people's score files.  One entry
for each score file or each score file directory.  Gnus will decide

\"/ftp.gnus.org@ftp:/pub/larsi/ding/score/soc.motss.SCORE\" and all
score files in the \"/ftp.some-where:/pub/score\" directory.

 (setq gnus-global-score-files
       '(\"/ftp.gnus.org:/pub/larsi/ding/score/soc.motss.SCORE\"
         \"/ftp.some-where:/pub/score\"))"
  :group 'gnus-score-files
  :type '(repeat file))

(defcustom gnus-score-file-single-match-alist nil
  "Alist mapping regexps to lists of score files.

  :group 'gnus-score-expire
  :type '(choice (const :tag "never" nil)
		 number))

(defcustom gnus-update-score-entry-dates t
  "*In non-nil, update matching score entry dates.
If this variable is nil, then score entries that provide matches
will be expired along with non-matching score entries."
  :group 'gnus-score-expire
  :type 'boolean)

(defcustom gnus-home-score-file nil
  "Variable to control where interactive score entries are to go.
It can be:

 * A string
   This file file will be used as the home score file.

 * A function
   The result of this function will be used as the home score file.
   The function will be passed the name of the group as its
   parameter.

 * A list
   The elements in this list can be:

   * `(regexp file-name ...)'
     If the `regexp' matches the group name, the first `file-name' will
     will be used as the home score file.  (Multiple filenames are
     allowed so that one may use gnus-score-file-single-match-alist to
     set this variable.)

   * A function.

				 (cons regexp (repeat file))
				 (function :value fun)))
		 (function :value fun)))

(defcustom gnus-default-adaptive-score-alist
  '((gnus-kill-file-mark)
    (gnus-unread-mark)
    (gnus-read-mark (from 3) (subject 30))
    (gnus-catchup-mark (subject -10))
    (gnus-killed-mark (from -1) (subject -20))
    (gnus-del-mark (from -2) (subject -15)))
  "*Alist of marks and scores."
  :group 'gnus-score-adapt
  :type '(repeat (cons (symbol :tag "Mark")
		       (repeat (list (choice :tag "Header"
					     (const from)
					     (const subject)
					     (symbol :tag "other"))
				     (integer :tag "Score"))))))

(defcustom gnus-ignored-adaptive-words nil
  "List of words to be ignored when doing adaptive word scoring."
  :group 'gnus-score-adapt
  :type '(repeat string))

(defun gnus-summary-lower-score (&optional score symp)
  "Make a score entry based on the current article.
The user will be prompted for header to score on, match type,
permanence, and the string to be used.  The numerical prefix will be
used as score."
  (interactive (gnus-interactive "P\ny"))
  (gnus-summary-increase-score (- (gnus-score-delta-default score)) symp))

(defun gnus-score-kill-help-buffer ()
  (when (get-buffer "*Score Help*")

(defun gnus-summary-increase-score (&optional score symp)
  "Make a score entry based on the current article.
The user will be prompted for header to score on, match type,
permanence, and the string to be used.  The numerical prefix will be
used as score."
  (interactive (gnus-interactive "P\ny"))
  (let* ((nscore (gnus-score-delta-default score))
	 (prefix (if (< nscore 0) ?L ?I))
	 (increase (> nscore 0))
	 (char-to-header

	    (when (or (= pchar ??) (= pchar ?\C-h))
	      (setq pchar nil)
	      (gnus-score-insert-help "Match permanence" char-to-perm 2)))

	  (gnus-score-kill-help-buffer)
	  (if mimic (message "%c %c %c" prefix hchar tchar pchar)
	    (message ""))
	  (unless (setq temporary (cadr (assq pchar char-to-perm)))
	    ;; Deal with der(r)ided superannuated paradigms.
	    (when (and (eq (1+ prefix) 77)
		       (eq (+ hchar 12) 109)

    ;; we must find out which header is in question.
    (setq extra
	  (and gnus-extra-headers
	       (equal (nth 1 entry) "extra")
	       (intern			; need symbol
		(gnus-completing-read
		 (symbol-name (car gnus-extra-headers))	; default response
		 "Score extra header:"	; prompt
		 (mapcar (lambda (x)	; completion list
			   (cons (symbol-name x) x))
			 gnus-extra-headers)
		 nil			; no completion limit
		 t))))			; require match

	(setq pad (- width 3))
	(setq format (concat "%c: %-" (int-to-string pad) "s"))
	(insert (format format (caar alist) (nth idx (car alist))))
	(setq alist (cdr alist))
	(setq i (1+ i))))
    ;; display ourselves in a small window at the bottom
    (gnus-appt-select-lowest-window)
    (split-window)
    (pop-to-buffer "*Score Help*")
    (let ((window-min-height 1))
      (shrink-window-if-larger-than-buffer))
    (select-window (get-buffer-window gnus-summary-buffer t))))

(defun gnus-summary-header (header &optional no-err extra)
  ;; Return HEADER for current articles, or error.
  (let ((article (gnus-summary-article-number))
	headers)

		     match))))

    ;; If this is an integer comparison, we transform from string to int.
    (if (eq (nth 2 (assoc header gnus-header-index)) 'gnus-score-integer)
	(if (stringp match)
	    (setq match (string-to-int match)))
      (set-text-properties 0 (length match) nil match))

    (unless (eq date 'now)
      ;; Add the score entry to the score file.
      (when (= score gnus-score-interactive-default-score)

	(gnus-summary-rescore)))

    ;; Return the new scoring rule.
    new))

(defun gnus-summary-score-effect (header match type score extra)
  "Simulate the effect of a score file entry.
HEADER is the header being scored.
MATCH is the string we are looking for.
TYPE is the score type.
SCORE is the score to add.

  (interactive (list (completing-read "Header: "
				      gnus-header-index
				      (lambda (x) (fboundp (nth 2 x)))
				      t)
		     (read-string "Match: ")
		     (y-or-n-p "Use regexp match? ")
		     (prefix-numeric-value current-prefix-arg)))
  (save-excursion
    (unless (and (stringp match) (> (length match) 0))
      (error "No match"))
    (goto-char (point-min))
    (let ((regexp (cond ((eq type 'f)

;;; Gnus Score Files
;;;

;; All score code written by Per Abrahamsen <[e-mail]>.

;; Added by Per Abrahamsen <[e-mail]>.
(defun gnus-score-set-mark-below (score)
  "Automatically mark articles with score below SCORE as read."
  (interactive
   (list (or (and current-prefix-arg (prefix-numeric-value current-prefix-arg))
	     (string-to-int (read-string "Mark below: ")))))
  (setq score (or score gnus-summary-default-score 0))
  (gnus-score-set 'mark (list score))
  (gnus-score-set 'touched '(t))
  (setq gnus-summary-mark-below score)
  (gnus-score-update-lines))

(defun gnus-score-set-expunge-below (score)
  "Automatically expunge articles with score below SCORE."
  (interactive
   (list (or (and current-prefix-arg (prefix-numeric-value current-prefix-arg))
	     (string-to-int (read-string "Set expunge below: ")))))
  (setq score (or score gnus-summary-default-score 0))
  (gnus-score-set 'expunge (list score))
  (gnus-score-set 'touched '(t)))

(defun gnus-score-followup-article (&optional score)

    (make-local-variable 'gnus-prev-winconf)
    (setq gnus-prev-winconf winconf))
  (gnus-message
   4 (substitute-command-keys
      "\\<gnus-score-mode-map>\\[gnus-score-edit-exit] to save edits")))

(defun gnus-score-load-file (file)
  ;; Load score file FILE.  Returns a list a retrieved score-alists.
  (let* ((file (expand-file-name
		(or (and (string-match

    (let ((mark (car (gnus-score-get 'mark alist)))
	  (expunge (car (gnus-score-get 'expunge alist)))
	  (mark-and-expunge (car (gnus-score-get 'mark-and-expunge alist)))
	  (files (gnus-score-get 'files alist))
	  (exclude-files (gnus-score-get 'exclude-files alist))
          (orphan (car (gnus-score-get 'orphan alist)))
	  (adapt (gnus-score-get 'adapt alist))
	  (thread-mark-and-expunge
	   (car (gnus-score-get 'thread-mark-and-expunge alist)))
	  (adapt-file (car (gnus-score-get 'adapt-file alist)))
	  (local (gnus-score-get 'local alist))

		   (setq gnus-newsgroup-adaptive nil))
		  ((consp adapt)
		   (setq gnus-newsgroup-adaptive t)
		   adapt)
		  (t
		   ;;(setq gnus-newsgroup-adaptive gnus-use-adaptive-scoring)
		   gnus-default-adaptive-score-alist)))
      (setq gnus-thread-expunge-below
	    (or thread-mark-and-expunge gnus-thread-expunge-below))
      (setq gnus-summary-mark-below
	    (or mark mark-and-expunge gnus-summary-mark-below))

		;; are not meant to be edited by human hands.
		(gnus-prin1 score)
	      ;; This is a normal score file, so we print it very
	      ;; prettily.
	      (let ((lisp-mode-syntax-table score-mode-syntax-table))
		(pp score (current-buffer)))))
	  (gnus-make-directory (file-name-directory file))
	  ;; If the score file is empty, we delete it.
	  (if (zerop (buffer-size))
	      (delete-file file)
	    ;; There are scores, so we write the file.

	       (expire (and gnus-score-expiry-days
			    (- now gnus-score-expiry-days)))
	       (headers gnus-newsgroup-headers)
	       (current-score-file gnus-current-score-file)
	       entry header new)
	  (gnus-message 5 "Scoring...")
	  ;; Create articles, an alist of the form `(HEADER . SCORE)'.
	  (while (setq header (pop headers))
	    ;; WARNING: The assq makes the function O(N*S) while it could
	    ;; be written as O(N+S), where N is (length gnus-newsgroup-headers)
	    ;; and S is (length gnus-newsgroup-scored).

	    (when (gnus-buffer-live-p gnus-summary-buffer)
	      (let ((scored gnus-newsgroup-scored))
		(with-current-buffer gnus-summary-buffer
		  (setq gnus-newsgroup-scored scored))))
	    ;; Remove the buffer.
	    (kill-buffer (current-buffer)))

	  ;; Add articles to `gnus-newsgroup-scored'.
	  (while gnus-scores-articles
	    (when (or (/= gnus-summary-default-score
			  (cdar gnus-scores-articles))

	      (while score
		(when (consp (caar score))
		  (gnus-score-advanced (car score) trace))
		(pop score))))

	  (gnus-message 5 "Scoring...done"))))))

(defun gnus-score-lower-thread (thread score-adjust)
  "Lower the score on THREAD with SCORE-ADJUST.
THREAD is expected to contain a list of the form `(PARENT [CHILD1
CHILD2 ...])' where PARENT is a header array and each CHILD is a list
of the same form as THREAD.  The empty list `nil' is valid.  For each
article in the tree, the score of the corresponding entry in
`gnus-newsgroup-scored' is adjusted by SCORE-ADJUST."
  (while thread
    (let ((head (car thread)))
      (if (listp head)

  "Score orphans.
A root is an article with no references.  An orphan is an article
which has references, but is not connected via its references to a
root article.  This function finds all the orphans, and adjusts their
score in `gnus-newsgroup-scored' by SCORE."
  (let ((threads (gnus-make-threads)))
    ;; gnus-make-threads produces a list, where each entry is a "thread"
    ;; as described in the gnus-score-lower-thread docs.  This function
    ;; will be called again (after limiting has been done) if the display
    ;; is threaded.  It would be nice to somehow save this info and use
    ;; it later.
    (while threads
      (let* ((thread (car threads))
	     (id (aref (car thread) gnus-score-index)))
	;; If the parent of the thread is not a root, lower the score of
	;; it and its descendants.  Note that some roots seem to satisfy
	;; (eq id nil) and some (eq id "");  not sure why.
	(if (and id (not (string= id "")))
	    (gnus-score-lower-thread thread score)))
      (setq threads (cdr threads)))))

(defun gnus-score-integer (scores header now expire &optional trace)
  (let ((gnus-score-index (nth 1 (assoc header gnus-header-index)))
	entries alist)
    ;; Find matches.

			;; Found a match, update scores.
			(setcdr (car articles) (+ score (cdar articles)))
			(setq found t)
			(when trace
			  (push
			   (cons (car-safe (rassq alist gnus-score-cache)) kill)
			   gnus-score-trace)))
		      ;; Update expire date
		      (unless trace
			(cond
			 ((null date))	;Permanent entry.

	  (when last
	    (insert last ?\n)
	    (put-text-property (1- (point)) (point) 'articles alike))
	  (setq alike (list art)
		last this)))
      (when last ; Bwadr, duplicate code.
	(insert last ?\n)
	(put-text-property (1- (point)) (point) 'articles alike))

      ;; Find matches.
      (while scores
	(setq alist (car scores)
	      scores (cdr scores)
	      entries (assoc header alist))
	(while (cdr entries) ;First entry is the header index.
	  (let* ((rest (cdr entries))
		 (kill (car rest))
		 (match (nth 0 kill))
		 (type (or (nth 3 kill) 's))
		 (score (or (nth 1 kill) gnus-score-interactive-default-score))

			(t (error "Invalid match type: %s" type))))
		 arts art)
	    (goto-char (point-min))
	    (if (= dmt ?e)
		(while (funcall search-func match nil t)
		  (and (= (progn (beginning-of-line) (point))
			  (match-beginning 0))
		       (= (progn (end-of-line) (point))
			  (match-end 0))
		       (progn
			 (setq found (setq arts (get-text-property

	      (while (funcall search-func match nil t)
		(end-of-line)
		(setq found (setq arts (get-text-property (point) 'articles)))
		;; Found a match, update scores.
		(while (setq art (pop arts))
		  (when (setq new (gnus-score-add-followups
				   (car art) score all-scores thread))
		    (push new news)))))
	    ;; Update expire date
	    (cond ((null date))		;Permanent entry.

  ;; than EXPIRE.

  ;; Insert the unique article headers in the buffer.
  (let ((gnus-score-index (nth 1 (assoc header gnus-header-index)))
	;; gnus-score-index is used as a free variable.
        (simplify (and gnus-score-thread-simplify
                       (string= "subject" header)))
	alike last this art entries alist articles
	fuzzies arts words kill)

    ;; Sorting the articles costs os O(N*log N) but will allow us to
    ;; only match with each unique header.  Thus the actual matching

      ;; If we're working with non-standard headers, we are stuck
      ;; with working on them as a group.  What a hassle.
      ;; Just wait 'til you see what horrors we commit against `match'...
      (if (= gnus-score-index 9)
	  (setq this (prin1-to-string this))) ; ick.

      (if simplify
	  (setq this (gnus-map-function gnus-simplify-subject-functions this)))
      (if (equal last this)
	  ;; O(N*H) cons-cells used here, where H is the number of

	       (mt (aref (symbol-name type) 0))
	       (case-fold-search (not (memq mt '(?R ?S ?E ?F))))
	       (dmt (downcase mt))
	       ;; Assume user already simplified regexp and fuzzies
	       (match (if (and simplify (not (memq dmt '(?f ?r))))
                          (gnus-map-function
                           gnus-simplify-subject-functions
                           (nth 0 kill))
                        (nth 0 kill)))
	       (search-func
		(cond ((= dmt ?r) 're-search-forward)
		      ((or (= dmt ?e) (= dmt ?s) (= dmt ?f)) 'search-forward)
		      ((= dmt ?w) nil)
		      (t (error "Invalid match type: %s" type)))))

	  ;; Evil hackery to make match usable in non-standard headers.
	  (when extra
	    (setq match (concat "[ (](" extra " \\. \"[^)]*"
				match "[^(]*\")[ )]")
		  search-func 're-search-forward)) ; XXX danger?!?

	  (cond
	   ;; Fuzzy matches.  We save these for later.
	   ((= dmt ?f)

		    (goto-char (point-min))
		    (while (re-search-forward "\\b\\w+\\b" nil t)
		      ;; Put the word and score into the hashtb.
		      (setq val (gnus-gethash (setq word (match-string 0))
					      hashtb))
		      (setq val (+ score (or val 0)))
		      (if (and gnus-adaptive-word-minimum
			       (< val gnus-adaptive-word-minimum))
			  (setq val gnus-adaptive-word-minimum))
		      (gnus-sethash word val hashtb))
		    (erase-buffer))))
	    (set-syntax-table syntab))
	  ;; Make all the ignorable words ignored.
	  (let ((ignored (append gnus-ignored-adaptive-words
				 (if gnus-adaptive-word-no-group-words

  (interactive)
  (let ((old-scored gnus-newsgroup-scored))
    (let ((gnus-newsgroup-headers
	   (list (gnus-summary-article-header)))
	  (gnus-newsgroup-scored nil)
	  trace)
      (save-excursion
	(nnheader-set-temp-buffer "*Score Trace*"))
      (setq gnus-score-trace nil)
      (gnus-possibly-score-headers 'trace)
      (if (not (setq trace gnus-score-trace))
	  (gnus-error
	   1 "No score rules apply to the current article (default score %d)."
	   gnus-summary-default-score)
	(set-buffer "*Score Trace*")
	(setq truncate-lines t)
	(while trace
	  (insert (format "%S  ->  %s\n" (cdar trace)
			  (or (caar trace) "(non-file rule)")))
	  (setq trace (cdr trace)))
	(goto-char (point-min))
	(gnus-configure-windows 'score-trace)))
    (set-buffer gnus-summary-buffer)
    (setq gnus-newsgroup-scored old-scored)))

  (gnus-summary-raise-same-subject (- score)))

(defun gnus-summary-lower-thread (&optional score)
  "Lower score of articles in the current thread with SCORE."
  (interactive "P")
  (gnus-summary-raise-thread (- (1- (gnus-score-delta-default score)))))

;;; Finding score files.

(defun gnus-score-score-files (group)
  "Return a list of all possible score files."

       ;; Add files to the list of score files.
       ((string-match regexp file)
	(push file out))))
    (or out
	;; Return a dummy value.
	(list "~/News/this.file.does.not.exist.SCORE"))))

(defun gnus-score-file-regexp ()
  "Return a regexp that match all score files."
  (concat "\\(" (regexp-quote gnus-score-file-suffix )
	  "\\|" (regexp-quote gnus-adaptive-file-suffix) "\\)\\'"))

			   (not (string-match regexp group-trans))))
		    (and (not not-match)
			 (ignore-errors (string-match regexp group-trans))))
	    (push (car sfiles) ofiles)))
	(setq sfiles (cdr sfiles)))
      (kill-buffer (current-buffer))
      ;; Slight kludge here - the last score file returned should be
      ;; the local score file, whether it exists or not.  This is so
      ;; that any score commands the user enters will go to the right
      ;; file, and not end up in some global score file.
      (let ((localscore (gnus-score-file-name group)))

	    (push param-file score-files)
	    (setq gnus-newsgroup-adaptive-score-file param-file))))
      ;; Go through all the functions for finding score files (or actual
      ;; scores) and add them to a list.
      (while funcs
	(when (gnus-functionp (car funcs))
	  (setq score-files
		(nconc score-files (nreverse (funcall (car funcs) group)))))
	(setq funcs (cdr funcs)))
      (when gnus-score-use-all-scores
	;; Add any home score files.
	(let ((home (gnus-home-score-file group)))
	  (when home

  ;; available global score files.
  (interactive (list gnus-global-score-files))
  (let (out)
    (while files
      ;; #### /$ Unix-specific?
      (if (string-match "/$" (car files))
	  (setq out (nconc (directory-files
			    (car files) t
			    (concat (gnus-score-file-regexp) "$"))))
	(push (car files) out))
      (setq files (cdr files)))

	    (cond
	     ;; Simple string.
	     ((stringp elem)
	      elem)
	     ;; Function.
	     ((gnus-functionp elem)
	      (funcall elem group))
	     ;; Regexp-file cons.
	     ((consp elem)
	      (when (string-match (gnus-globalify-regexp (car elem)) group)
		(replace-match (cadr elem) t nil group))))))
    (when found
      (if (file-name-absolute-p found)
          found
        (nnheader-concat gnus-kill-files-directory found)))))

(defun gnus-hierarchial-home-score-file (group)
  "Return the score file of the top-level hierarchy of GROUP."
  (if (string-match "^[^.]+\\." group)
      (concat (match-string 0 group) gnus-score-file-suffix)

;;; Score decays
;;;

(defun gnus-decay-score (score)
  "Decay SCORE according to `gnus-score-decay-constant' and `gnus-score-decay-scale'."
  (floor
   (- score
      (* (if (< score 0) -1 1)
	 (min (abs score)
	      (max gnus-score-decay-constant
		   (* (abs score)
		      gnus-score-decay-scale)))))))

(defun gnus-decay-scores (alist day)
  "Decay non-permanent scores in ALIST."
  (let ((times (- (time-to-days (current-time)) day))
	kill entry updated score n)

cons cell (SYM . STRING), where the symbol SYM is `new' or `bad'.
In the `new' case, the string is a safe replacement for REGEXP.
In the `bad' case, the string is a unsafe subexpression of REGEXP,
and we do not have a simple replacement to suggest.

See `(Gnus)Scoring Tips' for examples of good regular expressions."
  (let (case-fold-search)
    (and
     ;; First, try a relatively fast necessary condition.
     ;; Notice ranges (like [^:] or [\t-\r]), \s>, \Sw, \W, \', \`:
     (string-match "\n\\|\\\\[SsW`']\\|\\[\\^\\|[\0-\n]-" regexp)

	(new (cons 'new new))
	(t nil))))))

(provide 'gnus-score)

;;; gnus-score.el ends here

88155:d7ddb3e565de

;;; gnus-score.el --- scoring code for Gnus

;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
;;   2004, 2005 Free Software Foundation, Inc.

;; Author: Per Abrahamsen <[e-mail]>
;;	Lars Magne Ingebrigtsen <[e-mail]>
;; Keywords: news

;; 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., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.

;;; Commentary:

;;; Code:

(eval-when-compile (require 'cl))

(require 'gnus)
(require 'gnus-sum)
(require 'gnus-range)
(require 'gnus-win)
(require 'message)
(require 'score-mode)

(autoload 'ffap-string-at-point "ffap")

(defcustom gnus-global-score-files nil
  "List of global score files and directories.
Set this variable if you want to use people's score files.  One entry
for each score file or each score file directory.  Gnus will decide

\"/ftp.gnus.org@ftp:/pub/larsi/ding/score/soc.motss.SCORE\" and all
score files in the \"/ftp.some-where:/pub/score\" directory.

 (setq gnus-global-score-files
       '(\"/ftp.gnus.org:/pub/larsi/ding/score/soc.motss.SCORE\"
	 \"/ftp.some-where:/pub/score\"))"
  :group 'gnus-score-files
  :type '(repeat file))

(defcustom gnus-score-file-single-match-alist nil
  "Alist mapping regexps to lists of score files.

  :group 'gnus-score-expire
  :type '(choice (const :tag "never" nil)
		 number))

(defcustom gnus-update-score-entry-dates t
  "*If non-nil, update matching score entry dates.
If this variable is nil, then score entries that provide matches
will be expired along with non-matching score entries."
  :group 'gnus-score-expire
  :type 'boolean)

(defcustom gnus-home-score-file nil
  "Variable to control where interactive score entries are to go.
It can be:

 * A string
   This file will be used as the home score file.

 * A function
   The result of this function will be used as the home score file.
   The function will be passed the name of the group as its
   parameter.

 * A list
   The elements in this list can be:

   * `(regexp file-name ...)'
     If the `regexp' matches the group name, the first `file-name'
     will be used as the home score file.  (Multiple filenames are
     allowed so that one may use gnus-score-file-single-match-alist to
     set this variable.)

   * A function.

				 (cons regexp (repeat file))
				 (function :value fun)))
		 (function :value fun)))

(defcustom gnus-default-adaptive-score-alist
  `((gnus-kill-file-mark)
    (gnus-unread-mark)
    (gnus-read-mark
     (from , (+ 2 gnus-score-decay-constant))
     (subject , (+ 27 gnus-score-decay-constant)))
    (gnus-catchup-mark
     (subject , (+ -7 (* -1 gnus-score-decay-constant))))
    (gnus-killed-mark
     (from , (- -1 gnus-score-decay-constant))
     (subject , (+ -17 (* -1 gnus-score-decay-constant))))
    (gnus-del-mark
     (from , (- -1 gnus-score-decay-constant))
     (subject , (+ -12 (* -1 gnus-score-decay-constant)))))
  "Alist of marks and scores.
If you use score decays, you might want to set values higher than
`gnus-score-decay-constant'."
  :group 'gnus-score-adapt
  :type '(repeat (cons (symbol :tag "Mark")
		       (repeat (list (choice :tag "Header"
					     (const from)
					     (const subject)
					     (symbol :tag "other"))
				     (integer :tag "Score"))))))

(defcustom gnus-adaptive-word-length-limit nil
  "*Words of a length lesser than this limit will be ignored when doing adaptive scoring."
  :version "22.1"
  :group 'gnus-score-adapt
  :type '(radio (const :format "Unlimited " nil)
		(integer :format "Maximum length: %v")))

(defcustom gnus-ignored-adaptive-words nil
  "List of words to be ignored when doing adaptive word scoring."
  :group 'gnus-score-adapt
  :type '(repeat string))

(defun gnus-summary-lower-score (&optional score symp)
  "Make a score entry based on the current article.
The user will be prompted for header to score on, match type,
permanence, and the string to be used.  The numerical prefix will be
used as score.  A symbolic prefix of `a' says to use the `all.SCORE'
file for the command instead of the current score file."
  (interactive (gnus-interactive "P\ny"))
  (gnus-summary-increase-score (- (gnus-score-delta-default score)) symp))

(defun gnus-score-kill-help-buffer ()
  (when (get-buffer "*Score Help*")

(defun gnus-summary-increase-score (&optional score symp)
  "Make a score entry based on the current article.
The user will be prompted for header to score on, match type,
permanence, and the string to be used.  The numerical prefix will be
used as score.  A symbolic prefix of `a' says to use the `all.SCORE'
file for the command instead of the current score file."
  (interactive (gnus-interactive "P\ny"))
  (let* ((nscore (gnus-score-delta-default score))
	 (prefix (if (< nscore 0) ?L ?I))
	 (increase (> nscore 0))
	 (char-to-header

	    (when (or (= pchar ??) (= pchar ?\C-h))
	      (setq pchar nil)
	      (gnus-score-insert-help "Match permanence" char-to-perm 2)))

	  (gnus-score-kill-help-buffer)
	  (if mimic (message "%c %c %c %c" prefix hchar tchar pchar)
	    (message ""))
	  (unless (setq temporary (cadr (assq pchar char-to-perm)))
	    ;; Deal with der(r)ided superannuated paradigms.
	    (when (and (eq (1+ prefix) 77)
		       (eq (+ hchar 12) 109)

    ;; we must find out which header is in question.
    (setq extra
	  (and gnus-extra-headers
	       (equal (nth 1 entry) "extra")
	       (intern			; need symbol
		(gnus-completing-read-with-default
		 (symbol-name (car gnus-extra-headers))	; default response
		 "Score extra header"	; prompt
		 (mapcar (lambda (x)	; completion list
			   (cons (symbol-name x) x))
			 gnus-extra-headers)
		 nil			; no completion limit
		 t))))			; require match

	(setq pad (- width 3))
	(setq format (concat "%c: %-" (int-to-string pad) "s"))
	(insert (format format (caar alist) (nth idx (car alist))))
	(setq alist (cdr alist))
	(setq i (1+ i))))
    (goto-char (point-min))
    ;; display ourselves in a small window at the bottom
    (gnus-appt-select-lowest-window)
    (if (< (/ (window-height) 2) window-min-height)
	(switch-to-buffer "*Score Help*")
      (split-window)
      (pop-to-buffer "*Score Help*"))
    (let ((window-min-height 1))
      (shrink-window-if-larger-than-buffer))
    (select-window (gnus-get-buffer-window gnus-summary-buffer t))))

(defun gnus-summary-header (header &optional no-err extra)
  ;; Return HEADER for current articles, or error.
  (let ((article (gnus-summary-article-number))
	headers)

		     match))))

    ;; If this is an integer comparison, we transform from string to int.
    (if (eq (nth 2 (assoc header gnus-header-index)) 'gnus-score-integer)
	(if (stringp match)
	    (setq match (string-to-number match)))
      (set-text-properties 0 (length match) nil match))

    (unless (eq date 'now)
      ;; Add the score entry to the score file.
      (when (= score gnus-score-interactive-default-score)

	(gnus-summary-rescore)))

    ;; Return the new scoring rule.
    new))

(defun gnus-summary-score-effect (header match type score &optional extra)
  "Simulate the effect of a score file entry.
HEADER is the header being scored.
MATCH is the string we are looking for.
TYPE is the score type.
SCORE is the score to add.

  (interactive (list (completing-read "Header: "
				      gnus-header-index
				      (lambda (x) (fboundp (nth 2 x)))
				      t)
		     (read-string "Match: ")
		     (if (y-or-n-p "Use regexp match? ") 'r 's)
		     (string-to-number (read-string "Score: "))))
  (save-excursion
    (unless (and (stringp match) (> (length match) 0))
      (error "No match"))
    (goto-char (point-min))
    (let ((regexp (cond ((eq type 'f)

;;; Gnus Score Files
;;;

;; All score code written by Per Abrahamsen <[e-mail]>.

(defun gnus-score-set-mark-below (score)
  "Automatically mark articles with score below SCORE as read."
  (interactive
   (list (or (and current-prefix-arg (prefix-numeric-value current-prefix-arg))
	     (string-to-number (read-string "Mark below: ")))))
  (setq score (or score gnus-summary-default-score 0))
  (gnus-score-set 'mark (list score))
  (gnus-score-set 'touched '(t))
  (setq gnus-summary-mark-below score)
  (gnus-score-update-lines))

(defun gnus-score-set-expunge-below (score)
  "Automatically expunge articles with score below SCORE."
  (interactive
   (list (or (and current-prefix-arg (prefix-numeric-value current-prefix-arg))
	     (string-to-number (read-string "Set expunge below: ")))))
  (setq score (or score gnus-summary-default-score 0))
  (gnus-score-set 'expunge (list score))
  (gnus-score-set 'touched '(t)))

(defun gnus-score-followup-article (&optional score)

    (make-local-variable 'gnus-prev-winconf)
    (setq gnus-prev-winconf winconf))
  (gnus-message
   4 (substitute-command-keys
      "\\<gnus-score-mode-map>\\[gnus-score-edit-exit] to save edits")))

(defun gnus-score-edit-file-at-point (&optional format)
  "Edit score file at point in Score Trace buffers.
If FORMAT, also format the current score file."
  (let* ((rule (save-excursion
		 (beginning-of-line)
		 (read (current-buffer))))
	 (sep "[ \n\r\t]*")
	 ;; Must be synced with `gnus-score-find-trace':
	 (reg " -> +")
	 (file (save-excursion
		 (end-of-line)
		 (if (and (re-search-backward reg (gnus-point-at-bol) t)
			  (re-search-forward  reg (gnus-point-at-eol) t))
		     (buffer-substring (point) (gnus-point-at-eol))
		   nil))))
    (if (or (not file)
	    (string-match "\\<\\(non-file rule\\|A file\\)\\>" file)
	    ;; (see `gnus-score-find-trace' and `gnus-score-advanced')
	    (string= "" file))
	(gnus-error 3 "Can't find a score file in current line.")
      (gnus-score-edit-file file)
      (when format
	(gnus-score-pretty-print))
      (when (consp rule) ;; the rule exists
	(setq rule (mapconcat #'(lambda (obj)
				  (regexp-quote (format "%S" obj)))
			      rule
			      sep))
	(goto-char (point-min))
	(re-search-forward rule nil t)
	;; make it easy to use `kill-sexp':
	(goto-char (1- (match-beginning 0)))))))

(defun gnus-score-load-file (file)
  ;; Load score file FILE.  Returns a list a retrieved score-alists.
  (let* ((file (expand-file-name
		(or (and (string-match

    (let ((mark (car (gnus-score-get 'mark alist)))
	  (expunge (car (gnus-score-get 'expunge alist)))
	  (mark-and-expunge (car (gnus-score-get 'mark-and-expunge alist)))
	  (files (gnus-score-get 'files alist))
	  (exclude-files (gnus-score-get 'exclude-files alist))
	  (orphan (car (gnus-score-get 'orphan alist)))
	  (adapt (gnus-score-get 'adapt alist))
	  (thread-mark-and-expunge
	   (car (gnus-score-get 'thread-mark-and-expunge alist)))
	  (adapt-file (car (gnus-score-get 'adapt-file alist)))
	  (local (gnus-score-get 'local alist))

		   (setq gnus-newsgroup-adaptive nil))
		  ((consp adapt)
		   (setq gnus-newsgroup-adaptive t)
		   adapt)
		  (t
		   gnus-default-adaptive-score-alist)))
      (setq gnus-thread-expunge-below
	    (or thread-mark-and-expunge gnus-thread-expunge-below))
      (setq gnus-summary-mark-below
	    (or mark mark-and-expunge gnus-summary-mark-below))

		;; are not meant to be edited by human hands.
		(gnus-prin1 score)
	      ;; This is a normal score file, so we print it very
	      ;; prettily.
	      (let ((lisp-mode-syntax-table score-mode-syntax-table))
		(gnus-pp score))))
	  (gnus-make-directory (file-name-directory file))
	  ;; If the score file is empty, we delete it.
	  (if (zerop (buffer-size))
	      (delete-file file)
	    ;; There are scores, so we write the file.

	       (expire (and gnus-score-expiry-days
			    (- now gnus-score-expiry-days)))
	       (headers gnus-newsgroup-headers)
	       (current-score-file gnus-current-score-file)
	       entry header new)
	  (gnus-message 7 "Scoring...")
	  ;; Create articles, an alist of the form `(HEADER . SCORE)'.
	  (while (setq header (pop headers))
	    ;; WARNING: The assq makes the function O(N*S) while it could
	    ;; be written as O(N+S), where N is (length gnus-newsgroup-headers)
	    ;; and S is (length gnus-newsgroup-scored).

	    (when (gnus-buffer-live-p gnus-summary-buffer)
	      (let ((scored gnus-newsgroup-scored))
		(with-current-buffer gnus-summary-buffer
		  (setq gnus-newsgroup-scored scored))))
	    ;; Remove the buffer.
	    (gnus-kill-buffer (current-buffer)))

	  ;; Add articles to `gnus-newsgroup-scored'.
	  (while gnus-scores-articles
	    (when (or (/= gnus-summary-default-score
			  (cdar gnus-scores-articles))

	      (while score
		(when (consp (caar score))
		  (gnus-score-advanced (car score) trace))
		(pop score))))

	  (gnus-message 7 "Scoring...done"))))))

(defun gnus-score-lower-thread (thread score-adjust)
  "Lower the score on THREAD with SCORE-ADJUST.
THREAD is expected to contain a list of the form `(PARENT [CHILD1
CHILD2 ...])' where PARENT is a header array and each CHILD is a list
of the same form as THREAD.  The empty list nil is valid.  For each
article in the tree, the score of the corresponding entry in
`gnus-newsgroup-scored' is adjusted by SCORE-ADJUST."
  (while thread
    (let ((head (car thread)))
      (if (listp head)

  "Score orphans.
A root is an article with no references.  An orphan is an article
which has references, but is not connected via its references to a
root article.  This function finds all the orphans, and adjusts their
score in `gnus-newsgroup-scored' by SCORE."
  ;; gnus-make-threads produces a list, where each entry is a "thread"
  ;; as described in the gnus-score-lower-thread docs.  This function
  ;; will be called again (after limiting has been done) if the display
  ;; is threaded.  It would be nice to somehow save this info and use
  ;; it later.
  (dolist (thread (gnus-make-threads))
    (let ((id (aref (car thread) gnus-score-index)))
      ;; If the parent of the thread is not a root, lower the score of
      ;; it and its descendants.  Note that some roots seem to satisfy
      ;; (eq id nil) and some (eq id "");  not sure why.
      (when (and id
		 (not (string= id "")))
	(gnus-score-lower-thread thread score)))))

(defun gnus-score-integer (scores header now expire &optional trace)
  (let ((gnus-score-index (nth 1 (assoc header gnus-header-index)))
	entries alist)
    ;; Find matches.

			;; Found a match, update scores.
			(setcdr (car articles) (+ score (cdar articles)))
			(setq found t)
			(when trace
			  (push
			   (cons (car-safe (rassq alist gnus-score-cache))
				 kill)
			   gnus-score-trace)))
		      ;; Update expire date
		      (unless trace
			(cond
			 ((null date))	;Permanent entry.

	  (when last
	    (insert last ?\n)
	    (put-text-property (1- (point)) (point) 'articles alike))
	  (setq alike (list art)
		last this)))
      (when last			; Bwadr, duplicate code.
	(insert last ?\n)
	(put-text-property (1- (point)) (point) 'articles alike))

      ;; Find matches.
      (while scores
	(setq alist (car scores)
	      scores (cdr scores)
	      entries (assoc header alist))
	(while (cdr entries)		;First entry is the header index.
	  (let* ((rest (cdr entries))
		 (kill (car rest))
		 (match (nth 0 kill))
		 (type (or (nth 3 kill) 's))
		 (score (or (nth 1 kill) gnus-score-interactive-default-score))

			(t (error "Invalid match type: %s" type))))
		 arts art)
	    (goto-char (point-min))
	    (if (= dmt ?e)
		(while (funcall search-func match nil t)
		  (and (= (gnus-point-at-bol)
			  (match-beginning 0))
		       (= (progn (end-of-line) (point))
			  (match-end 0))
		       (progn
			 (setq found (setq arts (get-text-property

	      (while (funcall search-func match nil t)
		(end-of-line)
		(setq found (setq arts (get-text-property (point) 'articles)))
		;; Found a match, update scores.
		(while (setq art (pop arts))
		  (setcdr art (+ score (cdr art)))
		  (when trace
		    (push (cons
			   (car-safe (rassq alist gnus-score-cache))
			   kill)
			  gnus-score-trace))
		  (when (setq new (gnus-score-add-followups
				   (car art) score all-scores thread))
		    (push new news)))))
	    ;; Update expire date
	    (cond ((null date))		;Permanent entry.

  ;; than EXPIRE.

  ;; Insert the unique article headers in the buffer.
  (let ((gnus-score-index (nth 1 (assoc header gnus-header-index)))
	;; gnus-score-index is used as a free variable.
	(simplify (and gnus-score-thread-simplify
		       (string= "subject" header)))
	alike last this art entries alist articles
	fuzzies arts words kill)

    ;; Sorting the articles costs os O(N*log N) but will allow us to
    ;; only match with each unique header.  Thus the actual matching

      ;; If we're working with non-standard headers, we are stuck
      ;; with working on them as a group.  What a hassle.
      ;; Just wait 'til you see what horrors we commit against `match'...
      (if (= gnus-score-index 9)
	  (setq this (gnus-prin1-to-string this))) ; ick.

      (if simplify
	  (setq this (gnus-map-function gnus-simplify-subject-functions this)))
      (if (equal last this)
	  ;; O(N*H) cons-cells used here, where H is the number of

	       (mt (aref (symbol-name type) 0))
	       (case-fold-search (not (memq mt '(?R ?S ?E ?F))))
	       (dmt (downcase mt))
	       ;; Assume user already simplified regexp and fuzzies
	       (match (if (and simplify (not (memq dmt '(?f ?r))))
			  (gnus-map-function
			   gnus-simplify-subject-functions
			   (nth 0 kill))
			(nth 0 kill)))
	       (search-func
		(cond ((= dmt ?r) 're-search-forward)
		      ((or (= dmt ?e) (= dmt ?s) (= dmt ?f)) 'search-forward)
		      ((= dmt ?w) nil)
		      (t (error "Invalid match type: %s" type)))))

	  ;; Evil hackery to make match usable in non-standard headers.
	  (when extra
	    (setq match (concat "[ (](" extra " \\. \"[^)]*"
				match "[^\"]*\")[ )]")
		  search-func 're-search-forward)) ; XXX danger?!?

	  (cond
	   ;; Fuzzy matches.  We save these for later.
	   ((= dmt ?f)

		    (goto-char (point-min))
		    (while (re-search-forward "\\b\\w+\\b" nil t)
		      ;; Put the word and score into the hashtb.
		      (setq val (gnus-gethash (setq word (match-string 0))
					      hashtb))
		      (when (or (not gnus-adaptive-word-length-limit)
				(> (length word)
				   gnus-adaptive-word-length-limit))
			(setq val (+ score (or val 0)))
			(if (and gnus-adaptive-word-minimum
				 (< val gnus-adaptive-word-minimum))
			    (setq val gnus-adaptive-word-minimum))
			(gnus-sethash word val hashtb)))
		    (erase-buffer))))
	    (set-syntax-table syntab))
	  ;; Make all the ignorable words ignored.
	  (let ((ignored (append gnus-ignored-adaptive-words
				 (if gnus-adaptive-word-no-group-words

  (interactive)
  (let ((old-scored gnus-newsgroup-scored))
    (let ((gnus-newsgroup-headers
	   (list (gnus-summary-article-header)))
	  (gnus-newsgroup-scored nil)
	  ;; Must be synced with `gnus-score-edit-file-at-point':
	  (frmt "%S [%s] -> %s\n")
	  trace
	  file)
      (save-excursion
	(nnheader-set-temp-buffer "*Score Trace*"))
      (setq gnus-score-trace nil)
      (gnus-possibly-score-headers 'trace)
      (if (not (setq trace gnus-score-trace))
	  (gnus-error
	   1 "No score rules apply to the current article (default score %d)."
	   gnus-summary-default-score)
	(set-buffer "*Score Trace*")
	;; Use a keymap instead?
	(local-set-key "q"
		       (lambda ()
			 (interactive)
			 (bury-buffer nil)
			 (gnus-summary-expand-window)))
	(local-set-key "e" (lambda ()
			     "Run `gnus-score-edit-file-at-point'."
			     (interactive)
			     (gnus-score-edit-file-at-point)))
	(local-set-key "f" (lambda ()
			     "Run `gnus-score-edit-file-at-point'."
			     (interactive)
			     (gnus-score-edit-file-at-point 'format)))
	(local-set-key "t" 'toggle-truncate-lines)
	(setq truncate-lines t)
	(dolist (entry trace)
	  (setq file (or (car entry)
			 ;; Must be synced with
			 ;; `gnus-score-edit-file-at-point':
			 "(non-file rule)"))
	  (insert
	   (format frmt
		   (cdr entry)
		   ;; Don't use `file-name-sans-extension' to see .SCORE and
		   ;; .ADAPT directly:
		   (file-name-nondirectory file)
		   (abbreviate-file-name file))))
	(insert
	 "\n\nQuick help:

Type `e' to edit score file corresponding to the score rule on current line,
`f' to format (pretty print) the score file and edit it,
`t' toggle to truncate long lines in this buffer,
`q' to quit.

The first sexp on each line is the score rule, followed by the file name of
the score file and its full name, including the directory.")
	(goto-char (point-min))
	(gnus-configure-windows 'score-trace)))
    (set-buffer gnus-summary-buffer)
    (setq gnus-newsgroup-scored old-scored)))

  (gnus-summary-raise-same-subject (- score)))

(defun gnus-summary-lower-thread (&optional score)
  "Lower score of articles in the current thread with SCORE."
  (interactive "P")
  (gnus-summary-raise-thread (- (gnus-score-delta-default score))))

;;; Finding score files.

(defun gnus-score-score-files (group)
  "Return a list of all possible score files."

       ;; Add files to the list of score files.
       ((string-match regexp file)
	(push file out))))
    (or out
	;; Return a dummy value.
	(list (expand-file-name "this.file.does.not.exist.SCORE"
				gnus-kill-files-directory)))))

(defun gnus-score-file-regexp ()
  "Return a regexp that match all score files."
  (concat "\\(" (regexp-quote gnus-score-file-suffix )
	  "\\|" (regexp-quote gnus-adaptive-file-suffix) "\\)\\'"))

			   (not (string-match regexp group-trans))))
		    (and (not not-match)
			 (ignore-errors (string-match regexp group-trans))))
	    (push (car sfiles) ofiles)))
	(setq sfiles (cdr sfiles)))
      (gnus-kill-buffer (current-buffer))
      ;; Slight kludge here - the last score file returned should be
      ;; the local score file, whether it exists or not.  This is so
      ;; that any score commands the user enters will go to the right
      ;; file, and not end up in some global score file.
      (let ((localscore (gnus-score-file-name group)))

	    (push param-file score-files)
	    (setq gnus-newsgroup-adaptive-score-file param-file))))
      ;; Go through all the functions for finding score files (or actual
      ;; scores) and add them to a list.
      (while funcs
	(when (functionp (car funcs))
	  (setq score-files
		(append score-files
			(nreverse (funcall (car funcs) group)))))
	(setq funcs (cdr funcs)))
      (when gnus-score-use-all-scores
	;; Add any home score files.
	(let ((home (gnus-home-score-file group)))
	  (when home

  ;; available global score files.
  (interactive (list gnus-global-score-files))
  (let (out)
    (while files
      ;; #### /$ Unix-specific?
      (if (file-directory-p (car files))
	  (setq out (nconc (directory-files
			    (car files) t
			    (concat (gnus-score-file-regexp) "$"))))
	(push (car files) out))
      (setq files (cdr files)))

	    (cond
	     ;; Simple string.
	     ((stringp elem)
	      elem)
	     ;; Function.
	     ((functionp elem)
	      (funcall elem group))
	     ;; Regexp-file cons.
	     ((consp elem)
	      (when (string-match (gnus-globalify-regexp (car elem)) group)
		(replace-match (cadr elem) t nil group))))))
    (when found
      (setq found (nnheader-translate-file-chars found))
      (if (file-name-absolute-p found)
	  found
	(nnheader-concat gnus-kill-files-directory found)))))

(defun gnus-hierarchial-home-score-file (group)
  "Return the score file of the top-level hierarchy of GROUP."
  (if (string-match "^[^.]+\\." group)
      (concat (match-string 0 group) gnus-score-file-suffix)

;;; Score decays
;;;

(defun gnus-decay-score (score)
  "Decay SCORE according to `gnus-score-decay-constant' and `gnus-score-decay-scale'."
  (let ((n (- score
	      (* (if (< score 0) -1 1)
		 (min (abs score)
		      (max gnus-score-decay-constant
			   (* (abs score)
			      gnus-score-decay-scale)))))))
    (if (and (featurep 'xemacs)
	     ;; XEmacs' floor can handle only the floating point
	     ;; number below the half of the maximum integer.
	     (> (abs n) (lsh -1 -2)))
	(string-to-number
	 (car (split-string (number-to-string n) "\\.")))
      (floor n))))

(defun gnus-decay-scores (alist day)
  "Decay non-permanent scores in ALIST."
  (let ((times (- (time-to-days (current-time)) day))
	kill entry updated score n)

cons cell (SYM . STRING), where the symbol SYM is `new' or `bad'.
In the `new' case, the string is a safe replacement for REGEXP.
In the `bad' case, the string is a unsafe subexpression of REGEXP,
and we do not have a simple replacement to suggest.

See Info node `(gnus)Scoring Tips' for examples of good regular expressions."
  (let (case-fold-search)
    (and
     ;; First, try a relatively fast necessary condition.
     ;; Notice ranges (like [^:] or [\t-\r]), \s>, \Sw, \W, \', \`:
     (string-match "\n\\|\\\\[SsW`']\\|\\[\\^\\|[\0-\n]-" regexp)

	(new (cons 'new new))
	(t nil))))))

(provide 'gnus-score)

;;; arch-tag: d3922589-764d-46ae-9954-9330fd192634
;;; gnus-score.el ends here