/[emacs]/emacs/lisp/gnus/gnus-logic.el
ViewVC logotype

Diff of /emacs/lisp/gnus/gnus-logic.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.7.14.1 by handa, Fri Mar 12 00:02:57 2004 UTC revision 1.7.14.2 by miles, Thu Sep 9 09:36:25 2004 UTC
# Line 1  Line 1 
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>
# Line 59  Line 59 
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)
# Line 116  Line 117 
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
# Line 129  Line 130 
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)
# Line 162  Line 162 
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
# Line 189  Line 189 
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)
# Line 201  Line 201 
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

Legend:
Removed from v.1.7.14.1  
changed lines
  Added in v.1.7.14.2

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26