1;;; gnus-logic.el --- advanced scoring code for Gnus
2
3;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
4;;   2005, 2006, 2007 Free Software Foundation, Inc.
5
6;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
7;; Keywords: news
8
9;; This file is part of GNU Emacs.
10
11;; GNU Emacs is free software; you can redistribute it and/or modify
12;; it under the terms of the GNU General Public License as published by
13;; the Free Software Foundation; either version 2, or (at your option)
14;; any later version.
15
16;; GNU Emacs is distributed in the hope that it will be useful,
17;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
19;; GNU General Public License for more details.
20
21;; You should have received a copy of the GNU General Public License
22;; along with GNU Emacs; see the file COPYING.  If not, write to the
23;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
24;; Boston, MA 02110-1301, USA.
25
26;;; Commentary:
27
28;;; Code:
29
30(eval-when-compile (require 'cl))
31
32(require 'gnus)
33(require 'gnus-score)
34(require 'gnus-util)
35
36;;; Internal variables.
37
38(defvar gnus-advanced-headers nil)
39
40;; To avoid having 8-bit characters in the source file.
41(defvar gnus-advanced-not (intern (format "%c" 172)))
42
43(defconst gnus-advanced-index
44  ;; Name to index alist.
45  '(("number" 0 gnus-advanced-integer)
46    ("subject" 1 gnus-advanced-string)
47    ("from" 2 gnus-advanced-string)
48    ("date" 3 gnus-advanced-date)
49    ("message-id" 4 gnus-advanced-string)
50    ("references" 5 gnus-advanced-string)
51    ("chars" 6 gnus-advanced-integer)
52    ("lines" 7 gnus-advanced-integer)
53    ("xref" 8 gnus-advanced-string)
54    ("head" nil gnus-advanced-body)
55    ("body" nil gnus-advanced-body)
56    ("all" nil gnus-advanced-body)))
57
58(eval-and-compile
59  (autoload 'parse-time-string "parse-time"))
60
61(defun gnus-score-advanced (rule &optional trace)
62  "Apply advanced scoring RULE to all the articles in the current group."
63  (let (new-score score multiple)
64    (dolist (gnus-advanced-headers gnus-newsgroup-headers)
65      (when (setq multiple (gnus-advanced-score-rule (car rule)))
66	(setq new-score (or (nth 1 rule)
67			    gnus-score-interactive-default-score))
68	(when (numberp multiple)
69	  (setq new-score (* multiple new-score)))
70	;; This rule was successful, so we add the score to this
71	;; article.
72	(if (setq score (assq (mail-header-number gnus-advanced-headers)
73			      gnus-newsgroup-scored))
74	    (setcdr score
75		    (+ (cdr score) new-score))
76	  (push (cons (mail-header-number gnus-advanced-headers)
77		      new-score)
78		gnus-newsgroup-scored)
79	  (when trace
80	    (push (cons "A file" rule)
81		  ;; Must be synced with `gnus-score-edit-file-at-point'.
82		  gnus-score-trace)))))))
83
84(defun gnus-advanced-score-rule (rule)
85  "Apply RULE to `gnus-advanced-headers'."
86  (let ((type (car rule)))
87    (cond
88     ;; "And" rule.
89     ((or (eq type '&) (eq type 'and))
90      (pop rule)
91      (if (not rule)
92	  t				; Empty rule is true.
93	(while (and rule
94		    (gnus-advanced-score-rule (car rule)))
95	  (pop rule))
96	;; If all the rules were true, then `rule' should be nil.
97	(not rule)))
98     ;; "Or" rule.
99     ((or (eq type '|) (eq type 'or))
100      (pop rule)
101      (if (not rule)
102	  nil
103	(while (and rule
104		    (not (gnus-advanced-score-rule (car rule))))
105	  (pop rule))
106	;; If one of the rules returned true, then `rule' should be non-nil.
107	rule))
108     ;; "Not" rule.
109     ((or (eq type '!) (eq type 'not) (eq type gnus-advanced-not))
110      (not (gnus-advanced-score-rule (nth 1 rule))))
111     ;; This is a `1-'-type redirection rule.
112     ((and (symbolp type)
113	   (string-match "^[0-9]+-$\\|^\\^+$" (symbol-name type)))
114      (let ((gnus-advanced-headers
115	     (gnus-parent-headers
116	      gnus-advanced-headers
117	      (if (string-match "^\\([0-9]+\\)-$" (symbol-name type))
118		  ;; 1- type redirection.
119		  (string-to-number
120		   (substring (symbol-name type)
121			      (match-beginning 1) (match-end 1)))
122		;; ^^^ type redirection.
123		(length (symbol-name type))))))
124	(when gnus-advanced-headers
125	  (gnus-advanced-score-rule (nth 1 rule)))))
126     ;; Plain scoring rule.
127     ((stringp type)
128      (gnus-advanced-score-article rule))
129     ;; Bug-out time!
130     (t
131      (error "Unknown advanced score type: %s" rule)))))
132
133(defun gnus-advanced-score-article (rule)
134  ;; `rule' is a semi-normal score rule, so we find out what function
135  ;; that's supposed to do the actual processing.
136  (let* ((header (car rule))
137	 (func (assoc (downcase header) gnus-advanced-index)))
138    (if (not func)
139	(error "No such header: %s" rule)
140      ;; Call the score function.
141      (funcall (caddr func) (or (cadr func) header)
142	       (cadr rule) (caddr rule)))))
143
144(defun gnus-advanced-string (index match type)
145  "See whether string MATCH of TYPE matches `gnus-advanced-headers' in INDEX."
146  (let* ((type (or type 's))
147	 (case-fold-search (not (eq (downcase (symbol-name type))
148				    (symbol-name type))))
149	 (header (or (aref gnus-advanced-headers index) "")))
150    (cond
151     ((memq type '(r R regexp Regexp))
152      (string-match match header))
153     ((memq type '(s S string String))
154      (string-match (regexp-quote match) header))
155     ((memq type '(e E exact Exact))
156      (string= match header))
157     ((memq type '(f F fuzzy Fuzzy))
158      (string-match (regexp-quote (gnus-simplify-subject-fuzzy match))
159		    header))
160     (t
161      (error "No such string match type: %s" type)))))
162
163(defun gnus-advanced-integer (index match type)
164  (if (not (memq type '(< > <= >= =)))
165      (error "No such integer score type: %s" type)
166    (funcall type (or (aref gnus-advanced-headers index) 0) match)))
167
168(defun gnus-advanced-date (index match type)
169  (let ((date (apply 'encode-time (parse-time-string
170				   (aref gnus-advanced-headers index))))
171	(match (apply 'encode-time (parse-time-string match))))
172    (cond
173     ((eq type 'at)
174      (equal date match))
175     ((eq type 'before)
176      (time-less-p match date))
177     ((eq type 'after)
178      (time-less-p date match))
179     (t
180      (error "No such date score type: %s" type)))))
181
182(defun gnus-advanced-body (header match type)
183  (when (string= header "all")
184    (setq header "article"))
185  (save-excursion
186    (set-buffer nntp-server-buffer)
187    (let* ((request-func (cond ((string= "head" header)
188				'gnus-request-head)
189			       ((string= "body" header)
190				'gnus-request-body)
191			       (t 'gnus-request-article)))
192	   ofunc article)
193      ;; Not all backends support partial fetching.  In that case, we
194      ;; just fetch the entire article.
195      (unless (gnus-check-backend-function
196	       (intern (concat "request-" header))
197	       gnus-newsgroup-name)
198	(setq ofunc request-func)
199	(setq request-func 'gnus-request-article))
200      (setq article (mail-header-number gnus-advanced-headers))
201      (gnus-message 7 "Scoring article %s..." article)
202      (when (funcall request-func article gnus-newsgroup-name)
203	(goto-char (point-min))
204	;; If just parts of the article is to be searched and the
205	;; backend didn't support partial fetching, we just narrow to
206	;; the relevant parts.
207	(when ofunc
208	  (if (eq ofunc 'gnus-request-head)
209	      (narrow-to-region
210	       (point)
211	       (or (search-forward "\n\n" nil t) (point-max)))
212	    (narrow-to-region
213	     (or (search-forward "\n\n" nil t) (point))
214	     (point-max))))
215	(let* ((case-fold-search (not (eq (downcase (symbol-name type))
216					  (symbol-name type))))
217	       (search-func
218		(cond ((memq type '(r R regexp Regexp))
219		       're-search-forward)
220		      ((memq type '(s S string String))
221		       'search-forward)
222		      (t
223		       (error "Invalid match type: %s" type)))))
224	  (goto-char (point-min))
225	  (prog1
226	      (funcall search-func match nil t)
227	    (widen)))))))
228
229(provide 'gnus-logic)
230
231;;; arch-tag: 9651a100-4a59-4b69-a55b-e511e67c0f8d
232;;; gnus-logic.el ends here
233