GNU bug report logs - #43413
28.0.50; [PATCH] New gnus-score-func to support user-defined scoring functions

Previous Next

Full log

View this message in rfc822 format

From: Alex Bochannek <alex <at> bochannek.com>
To: Lars Ingebrigtsen <larsi <at> gnus.org>
Cc: 43413 <at> debbugs.gnu.org
Subject: bug#43413: 28.0.50; [PATCH] New gnus-score-func to support user-defined scoring functions
Date: Wed, 16 Sep 2020 11:11:57 -0700

[Message part 1 (text/plain, inline)]

Lars Ingebrigtsen <larsi <at> gnus.org> writes:

> Alex Bochannek <alex <at> bochannek.com> writes:
>
>> Although it's only ~40 lines of Elisp and ~30 lines of Texinfo, I am
>> pretty sure it's the largest code change I have submitted to Emacs and I
>> would not be surprised if I violated some coding standards. I have spent
>> a fair amount of time with testing, but cannot rule out corner cases, of
>> course. Let me know if you want me to make any improvements before
>> accepting this patch.
>
> Looks pretty good, but the main problem is neglecting to let-bind
> variables.  byte-compiling is a good way to catch these errors:

Please ignore the previous patch I sent that used let-forms, I found a
bug in it. I cleaned it up some more and I am attaching a new
patch. Thanks again for the feedback!

[Message part 2 (text/x-patch, inline)]

diff --git a/lisp/gnus/gnus-score.el b/lisp/gnus/gnus-score.el
index ffc6b8ca34..2bc9980852 100644
--- a/lisp/gnus/gnus-score.el
+++ b/lisp/gnus/gnus-score.el
@@ -497,6 +497,7 @@ gnus-header-index
     ("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 +1176,20 @@ gnus-score-edit-file-at-point
       (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)))))))
+	(let (move)
+	  (setq rule (if (symbolp (car rule))
+			 (format "(%S)" (car rule))
+		       (mapconcat #'(lambda (obj)
+				      (regexp-quote (format "%S" obj)))
+				  rule
+				  sep)))
+	  (goto-char (point-min))
+	  (setq 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 +1239,7 @@ gnus-score-load-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 +1575,14 @@ gnus-score-headers
 			    (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 +1648,35 @@ gnus-score-orphans
 		 (not (string= id "")))
 	(gnus-score-lower-thread thread score)))))
 
+(declare-function cl-pairlis "cl-lib")
+
+(defun gnus-score-func (scores &optional trace)
+  (let (articles alist entries)
+    (while scores
+      (setq articles gnus-scores-articles
+	    alist (car scores)
+	    scores (cdr scores)
+	    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))
+	    (if (integerp (setq fn-score (funcall score-fn
+						  article-alist score)))
+		(setcdr art (+ score fn-score)))
+	    (setq score (cdr art))
+	    (when trace
+	      (if (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)

[Message part 3 (text/plain, inline)]

-- 
Alex. <abochannek <at> google.com>

Previous Next

GNU bug tracking system
Copyright (C) 1999 Darren O. Benham, 1997,2003 nCipher Corporation Ltd, 1994-97 Ian Jackson.