Allow user-defined scoring in Gnus

* lisp/gnus/gnus-score.el (gnus-score-func): New function (bug#43413).
* doc/misc/gnus.texi (Score File Format): Document it.

diff --git a/doc/misc/gnus.texi b/doc/misc/gnus.texi
index 50eeb3efa325eaf13f5c78b0969a7d7f06570ef8..76aaca16995441aaf235936c0b960a7b0f15df86 100644 (file)
--- a/doc/misc/gnus.texi
+++ b/doc/misc/gnus.texi
@@ -20394,6 +20394,36 @@ key will lead to creation of @file{ADAPT} files.)
 @end enumerate
 
 @cindex score file atoms
+@item score-fn
+The value of this entry should be one or more user-defined function
+names in parentheses. Each function will be called in order and the
+returned value is required to be an integer.
+
+@example
+(score-fn (custom-scoring))
+@end example
+
+The user-defined function is called with an associative list with the
+keys @code{number subject from date id refs chars lines xref extra}
+followed by the article's score before the function is run.
+
+The following (somewhat contrived) example shows how to use a
+user-defined function that increases an article's score by 10 if the
+year of the article's date is also mentioned in its subject.
+
+@example
+(defun custom-scoring (article-alist score)
+  (let ((subject (cdr (assoc 'subject article-alist)))
+        (date (cdr (assoc 'date article-alist))))
+    (if (string-match (number-to-string
+                       (nth 5 (parse-time-string date)))
+                      subject)
+        10)))
+@end example
+
+@code{score-fn} entries are permanent and can only be added or
+modified directly in the @code{SCORE} file.
+
 @item mark
 The value of this entry should be a number.  Any articles with a score
 lower than this number will be marked as read.

diff --git a/etc/NEWS b/etc/NEWS
index 721da44811c662005215eaa910adcf923e0eb808..1ee86de128c4d57fcce92ca84785888995ec05eb 100644 (file)
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -365,6 +365,11 @@ tags to be considered as well.
 You can now score based on the relative age of an article with the new
 '<' and '>' date scoring types.
 
++++
+*** User-defined scoring is now possible.
+The new type is 'score-fn'.  More information in
+(Gnus)Score File Format.
+
 +++
 *** New backend 'nnselect'.
 The newly added 'nnselect' backend allows creating groups from an

diff --git a/lisp/gnus/gnus-score.el b/lisp/gnus/gnus-score.el
index ffc6b8ca34e2b1714f540372da7a91555a093d8c..2e3abe7832df810737300ad2dc1a29273966e511 100644 (file)
--- a/lisp/gnus/gnus-score.el
+++ b/lisp/gnus/gnus-score.el
@@ -25,8 +25,6 @@
 
 ;;; Code:
 
-(eval-when-compile (require 'cl-lib))
-
 (require 'gnus)
 (require 'gnus-sum)
 (require 'gnus-art)
@@ -35,6 +33,7 @@
 (require 'message)
 (require 'score-mode)
 (require 'gmm-utils)
+(require 'cl-lib)
 
 (defcustom gnus-global-score-files nil
   "List of global score files and directories.
@@ -497,6 +496,7 @@ of the last successful match.")
     ("head" -1 gnus-score-body)
     ("body" -1 gnus-score-body)
     ("all" -1 gnus-score-body)
+    (score-fn -1 nil)
     ("followup" 2 gnus-score-followup)
     ("thread" 5 gnus-score-thread)))
 
@@ -1175,14 +1175,19 @@ If FORMAT, also format the current score 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))
+       (setq rule (if (symbolp (car rule))
+                      (format "(%S)" (car 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)))))))
+       (let ((move (if (string-match "(.*)" rule)
+                       0
+                     -1)))
+         (re-search-forward rule nil t)
+         ;; make it easy to use `kill-sexp':
+         (goto-char (+ move (match-beginning 0))))))))
 
 (defun gnus-score-load-file (file)
   ;; Load score file FILE.  Returns a list a retrieved score-alists.
@@ -1232,6 +1237,7 @@ If FORMAT, also format the current score file."
     (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)))
+         (score-fn (car (gnus-score-get 'score-fn alist)))
          (files (gnus-score-get 'files alist))
          (exclude-files (gnus-score-get 'exclude-files alist))
          (orphan (car (gnus-score-get 'orphan alist)))
@@ -1567,10 +1573,14 @@ If FORMAT, also format the current score file."
                            (gnus-message
                             7 "Scoring on headers or body skipped.")
                            nil)
+                       ;; Run score-fn
+                       (if (eq header 'score-fn)
+                           (setq new (gnus-score-func scores trace))
                        ;; Call the scoring function for this type of "header".
                        (setq new (funcall (nth 2 entry) scores header
-                                          now expire trace)))
+                                          now expire trace))))
                  (push new news))))
+
            (when (gnus-buffer-live-p gnus-summary-buffer)
              (let ((scored gnus-newsgroup-scored))
                (with-current-buffer gnus-summary-buffer
@@ -1636,6 +1646,30 @@ score in `gnus-newsgroup-scored' by SCORE."
                 (not (string= id "")))
        (gnus-score-lower-thread thread score)))))
 
+(defun gnus-score-func (scores &optional trace)
+  (dolist (alist scores)
+    (let ((articles gnus-scores-articles)
+         (entries (assoc 'score-fn alist)))
+      (dolist (score-fn (cdr entries))
+       (let ((score-fn (car score-fn))
+             article-alist score fn-score)
+         (dolist (art articles)
+           (setq article-alist
+                 (cl-pairlis
+                  '(number subject from date id
+                           refs chars lines xref extra)
+                  (car art))
+                 score (cdr art))
+           (when (integerp (setq fn-score (funcall score-fn
+                                                   article-alist score)))
+             (setcdr art (+ score fn-score)))
+           (setq score (cdr art))
+           (when (and trace
+                      (integerp fn-score))
+             (push (cons (car-safe (rassq alist gnus-score-cache))
+                         (list score-fn fn-score))
+                   gnus-score-trace))))))))
+
 (defun gnus-score-integer (scores header now expire &optional trace)
   (let ((gnus-score-index (nth 1 (assoc header gnus-header-index)))
        entries alist)