From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.io!.POSTED.blaine.gmane.org!not-for-mail From: Alex Bochannek Newsgroups: gmane.emacs.bugs 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-ID: References: <875z8f9pbs.fsf@gnus.org> Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" Injection-Info: ciao.gmane.io; posting-host="blaine.gmane.org:116.202.254.214"; logging-data="15121"; mail-complaints-to="usenet@ciao.gmane.io" User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/27.1 (darwin) Cc: 43413@debbugs.gnu.org To: Lars Ingebrigtsen Original-X-From: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane-mx.org@gnu.org Wed Sep 16 20:13:19 2020 Return-path: Envelope-to: geb-bug-gnu-emacs@m.gmane-mx.org Original-Received: from lists.gnu.org ([209.51.188.17]) by ciao.gmane.io with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.92) (envelope-from ) id 1kIbvj-0003oC-JM for geb-bug-gnu-emacs@m.gmane-mx.org; Wed, 16 Sep 2020 20:13:19 +0200 Original-Received: from localhost ([::1]:51062 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1kIbvi-0004BU-EH for geb-bug-gnu-emacs@m.gmane-mx.org; Wed, 16 Sep 2020 14:13:18 -0400 Original-Received: from eggs.gnu.org ([2001:470:142:3::10]:55644) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1kIbvS-0004B5-7J for bug-gnu-emacs@gnu.org; Wed, 16 Sep 2020 14:13:02 -0400 Original-Received: from debbugs.gnu.org ([209.51.188.43]:52529) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1kIbvR-0007mJ-Uh for bug-gnu-emacs@gnu.org; Wed, 16 Sep 2020 14:13:01 -0400 Original-Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1kIbvR-0005pa-Ot for bug-gnu-emacs@gnu.org; Wed, 16 Sep 2020 14:13:01 -0400 X-Loop: help-debbugs@gnu.org Resent-From: Alex Bochannek Original-Sender: "Debbugs-submit" Resent-CC: bug-gnu-emacs@gnu.org Resent-Date: Wed, 16 Sep 2020 18:13:01 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 43413 X-GNU-PR-Package: emacs X-GNU-PR-Keywords: patch Original-Received: via spool by 43413-submit@debbugs.gnu.org id=B43413.160027993222358 (code B ref 43413); Wed, 16 Sep 2020 18:13:01 +0000 Original-Received: (at 43413) by debbugs.gnu.org; 16 Sep 2020 18:12:12 +0000 Original-Received: from localhost ([127.0.0.1]:35842 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1kIbue-0005oX-BT for submit@debbugs.gnu.org; Wed, 16 Sep 2020 14:12:12 -0400 Original-Received: from 50-0-39-243.dsl.static.fusionbroadband.com ([50.0.39.243]:16106 helo=mail.lapseofthought.com) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1kIbuW-0005nx-Sp for 43413@debbugs.gnu.org; Wed, 16 Sep 2020 14:12:10 -0400 Original-Received: from localhost (localhost [127.0.0.1]) by mail.lapseofthought.com (Postfix) with ESMTP id 4Bs7Tp5v1Zz3jjyr; Wed, 16 Sep 2020 11:11:58 -0700 (PDT) X-Virus-Scanned: Debian amavisd-new at lapseofthought.com Original-Received: from mail.lapseofthought.com ([127.0.0.1]) by localhost (mail.lapseofthought.com [127.0.0.1]) (amavisd-new, port 10024) with ESMTP id LXllExmxh-h0; Wed, 16 Sep 2020 11:11:57 -0700 (PDT) Original-Received: from awb-mbp.local (unknown [IPv6:2601:646:4200:b470:4872:ffca:52c3:4605]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits)) (No client certificate requested) by mail.lapseofthought.com (Postfix) with ESMTPSA id 4Bs7Tn5mV2z3jhlV; Wed, 16 Sep 2020 11:11:57 -0700 (PDT) In-Reply-To: <875z8f9pbs.fsf@gnus.org> (Lars Ingebrigtsen's message of "Tue, 15 Sep 2020 14:50:15 +0200") X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-BeenThere: bug-gnu-emacs@gnu.org List-Id: "Bug reports for GNU Emacs, the Swiss army knife of text editors" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane-mx.org@gnu.org Original-Sender: "bug-gnu-emacs" Xref: news.gmane.io gmane.emacs.bugs:188177 Archived-At: --=-=-= Content-Type: text/plain Lars Ingebrigtsen writes: > Alex Bochannek 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! --=-=-= Content-Type: text/x-patch Content-Disposition: inline Content-Description: New gnus-score-func to support user-defined scoring functions (code) 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) --=-=-= Content-Type: text/plain -- Alex. --=-=-=--