From: Alex Bochannek Date: Thu, 17 Sep 2020 15:02:48 +0000 (+0200) Subject: Allow user-defined scoring in Gnus X-Git-Tag: emacs-28.0.90~6037 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=12aea1fa80f6db85dc58a54fa7486c58928206e7;p=emacs.git 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 50eeb3efa32..76aaca16995 100644 --- 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 721da44811c..1ee86de128c 100644 --- 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 ffc6b8ca34e..2e3abe7832d 100644 --- 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)