1 |
;;; gnus-logic.el --- advanced scoring code for Gnus |
;;; gnus-logic.el --- advanced scoring code for Gnus |
2 |
;; Copyright (C) 1996, 1997, 1998, 1999, 2000 |
;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002 |
3 |
;; Free Software Foundation, Inc. |
;; Free Software Foundation, Inc. |
4 |
|
|
5 |
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> |
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> |
59 |
|
|
60 |
(defun gnus-score-advanced (rule &optional trace) |
(defun gnus-score-advanced (rule &optional trace) |
61 |
"Apply advanced scoring RULE to all the articles in the current group." |
"Apply advanced scoring RULE to all the articles in the current group." |
62 |
(let ((headers gnus-newsgroup-headers) |
(let (new-score score multiple) |
63 |
gnus-advanced-headers score) |
(dolist (gnus-advanced-headers gnus-newsgroup-headers) |
64 |
(while (setq gnus-advanced-headers (pop headers)) |
(when (setq multiple (gnus-advanced-score-rule (car rule))) |
65 |
(when (gnus-advanced-score-rule (car rule)) |
(setq new-score (or (nth 1 rule) |
66 |
;; This rule was successful, so we add the score to |
gnus-score-interactive-default-score)) |
67 |
;; this article. |
(when (numberp multiple) |
68 |
|
(setq new-score (* multiple new-score))) |
69 |
|
;; This rule was successful, so we add the score to this |
70 |
|
;; article. |
71 |
(if (setq score (assq (mail-header-number gnus-advanced-headers) |
(if (setq score (assq (mail-header-number gnus-advanced-headers) |
72 |
gnus-newsgroup-scored)) |
gnus-newsgroup-scored)) |
73 |
(setcdr score |
(setcdr score |
74 |
(+ (cdr score) |
(+ (cdr score) new-score)) |
|
(or (nth 1 rule) |
|
|
gnus-score-interactive-default-score))) |
|
75 |
(push (cons (mail-header-number gnus-advanced-headers) |
(push (cons (mail-header-number gnus-advanced-headers) |
76 |
(or (nth 1 rule) |
new-score) |
|
gnus-score-interactive-default-score)) |
|
77 |
gnus-newsgroup-scored) |
gnus-newsgroup-scored) |
78 |
(when trace |
(when trace |
79 |
(push (cons "A file" rule) |
(push (cons "A file" rule) |
80 |
|
;; Must be synced with `gnus-score-edit-file-at-point'. |
81 |
gnus-score-trace))))))) |
gnus-score-trace))))))) |
82 |
|
|
83 |
(defun gnus-advanced-score-rule (rule) |
(defun gnus-advanced-score-rule (rule) |
117 |
;; 1- type redirection. |
;; 1- type redirection. |
118 |
(string-to-number |
(string-to-number |
119 |
(substring (symbol-name type) |
(substring (symbol-name type) |
120 |
(match-beginning 0) (match-end 0))) |
(match-beginning 1) (match-end 1))) |
121 |
;; ^^^ type redirection. |
;; ^^^ type redirection. |
122 |
(length (symbol-name type)))))) |
(length (symbol-name type)))))) |
123 |
(when gnus-advanced-headers |
(when gnus-advanced-headers |
130 |
(error "Unknown advanced score type: %s" rule))))) |
(error "Unknown advanced score type: %s" rule))))) |
131 |
|
|
132 |
(defun gnus-advanced-score-article (rule) |
(defun gnus-advanced-score-article (rule) |
133 |
;; `rule' is a semi-normal score rule, so we find out |
;; `rule' is a semi-normal score rule, so we find out what function |
134 |
;; what function that's supposed to do the actual |
;; that's supposed to do the actual processing. |
|
;; processing. |
|
135 |
(let* ((header (car rule)) |
(let* ((header (car rule)) |
136 |
(func (assoc (downcase header) gnus-advanced-index))) |
(func (assoc (downcase header) gnus-advanced-index))) |
137 |
(if (not func) |
(if (not func) |
162 |
(defun gnus-advanced-integer (index match type) |
(defun gnus-advanced-integer (index match type) |
163 |
(if (not (memq type '(< > <= >= =))) |
(if (not (memq type '(< > <= >= =))) |
164 |
(error "No such integer score type: %s" type) |
(error "No such integer score type: %s" type) |
165 |
(funcall type match (or (aref gnus-advanced-headers index) 0)))) |
(funcall type (or (aref gnus-advanced-headers index) 0) match))) |
166 |
|
|
167 |
(defun gnus-advanced-date (index match type) |
(defun gnus-advanced-date (index match type) |
168 |
(let ((date (apply 'encode-time (parse-time-string |
(let ((date (apply 'encode-time (parse-time-string |
189 |
'gnus-request-body) |
'gnus-request-body) |
190 |
(t 'gnus-request-article))) |
(t 'gnus-request-article))) |
191 |
ofunc article) |
ofunc article) |
192 |
;; Not all backends support partial fetching. In that case, |
;; Not all backends support partial fetching. In that case, we |
193 |
;; we just fetch the entire article. |
;; just fetch the entire article. |
194 |
(unless (gnus-check-backend-function |
(unless (gnus-check-backend-function |
195 |
(intern (concat "request-" header)) |
(intern (concat "request-" header)) |
196 |
gnus-newsgroup-name) |
gnus-newsgroup-name) |
201 |
(when (funcall request-func article gnus-newsgroup-name) |
(when (funcall request-func article gnus-newsgroup-name) |
202 |
(goto-char (point-min)) |
(goto-char (point-min)) |
203 |
;; If just parts of the article is to be searched and the |
;; If just parts of the article is to be searched and the |
204 |
;; backend didn't support partial fetching, we just narrow |
;; backend didn't support partial fetching, we just narrow to |
205 |
;; to the relevant parts. |
;; the relevant parts. |
206 |
(when ofunc |
(when ofunc |
207 |
(if (eq ofunc 'gnus-request-head) |
(if (eq ofunc 'gnus-request-head) |
208 |
(narrow-to-region |
(narrow-to-region |