cgit.sxemacs.org Git - gnus/blob - lisp/gnus-logic.el

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