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