comparison lisp/gnus/gnus-logic.el @ 88155:d7ddb3e565de

sync with trunk

88154:8ce476d3ba36

;;; gnus-logic.el --- advanced scoring code for Gnus
;; Copyright (C) 1996, 1997, 1998, 1999, 2000
;;        Free Software Foundation, Inc.

;; Author: Lars Magne Ingebrigtsen <[e-mail]>
;; Keywords: news

;; This file is part of GNU Emacs.

;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;; Commentary:

;;; Code:

(eval-and-compile
  (autoload 'parse-time-string "parse-time"))

(defun gnus-score-advanced (rule &optional trace)
  "Apply advanced scoring RULE to all the articles in the current group."
  (let ((headers gnus-newsgroup-headers)
	gnus-advanced-headers score)
    (while (setq gnus-advanced-headers (pop headers))
      (when (gnus-advanced-score-rule (car rule))
	;; This rule was successful, so we add the score to
	;; this article.
	(if (setq score (assq (mail-header-number gnus-advanced-headers)
			      gnus-newsgroup-scored))
	    (setcdr score
		    (+ (cdr score)
		       (or (nth 1 rule)
			   gnus-score-interactive-default-score)))
	  (push (cons (mail-header-number gnus-advanced-headers)
		      (or (nth 1 rule)
			  gnus-score-interactive-default-score))
		gnus-newsgroup-scored)
	  (when trace
	    (push (cons "A file" rule)
		  gnus-score-trace)))))))

(defun gnus-advanced-score-rule (rule)
  "Apply RULE to `gnus-advanced-headers'."
  (let ((type (car rule)))

	      gnus-advanced-headers
	      (if (string-match "^\\([0-9]+\\)-$" (symbol-name type))
		  ;; 1- type redirection.
		  (string-to-number
		   (substring (symbol-name type)
			      (match-beginning 0) (match-end 0)))
		;; ^^^ type redirection.
		(length (symbol-name type))))))
	(when gnus-advanced-headers
	  (gnus-advanced-score-rule (nth 1 rule)))))
     ;; Plain scoring rule.

     ;; Bug-out time!
     (t
      (error "Unknown advanced score type: %s" rule)))))

(defun gnus-advanced-score-article (rule)
  ;; `rule' is a semi-normal score rule, so we find out
  ;; what function that's supposed to do the actual
  ;; processing.
  (let* ((header (car rule))
	 (func (assoc (downcase header) gnus-advanced-index)))
    (if (not func)
	(error "No such header: %s" rule)
      ;; Call the score function.

      (error "No such string match type: %s" type)))))

(defun gnus-advanced-integer (index match type)
  (if (not (memq type '(< > <= >= =)))
      (error "No such integer score type: %s" type)
    (funcall type match (or (aref gnus-advanced-headers index) 0))))

(defun gnus-advanced-date (index match type)
  (let ((date (apply 'encode-time (parse-time-string
				   (aref gnus-advanced-headers index))))
	(match (apply 'encode-time (parse-time-string match))))

				'gnus-request-head)
			       ((string= "body" header)
				'gnus-request-body)
			       (t 'gnus-request-article)))
	   ofunc article)
      ;; Not all backends support partial fetching.  In that case,
      ;; we just fetch the entire article.
      (unless (gnus-check-backend-function
	       (intern (concat "request-" header))
	       gnus-newsgroup-name)
	(setq ofunc request-func)
	(setq request-func 'gnus-request-article))
      (setq article (mail-header-number gnus-advanced-headers))
      (gnus-message 7 "Scoring article %s..." article)
      (when (funcall request-func article gnus-newsgroup-name)
	(goto-char (point-min))
	;; If just parts of the article is to be searched and the
	;; backend didn't support partial fetching, we just narrow
	;; to the relevant parts.
	(when ofunc
	  (if (eq ofunc 'gnus-request-head)
	      (narrow-to-region
	       (point)
	       (or (search-forward "\n\n" nil t) (point-max)))

	      (funcall search-func match nil t)
	    (widen)))))))

(provide 'gnus-logic)

;;; gnus-logic.el ends here

88155:d7ddb3e565de

;;; gnus-logic.el --- advanced scoring code for Gnus

;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
;;   2005 Free Software Foundation, Inc.

;; Author: Lars Magne Ingebrigtsen <[e-mail]>
;; Keywords: news

;; This file is part of GNU Emacs.

;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.

;;; Commentary:

;;; Code:

(eval-and-compile
  (autoload 'parse-time-string "parse-time"))

(defun gnus-score-advanced (rule &optional trace)
  "Apply advanced scoring RULE to all the articles in the current group."
  (let (new-score score multiple)
    (dolist (gnus-advanced-headers gnus-newsgroup-headers)
      (when (setq multiple (gnus-advanced-score-rule (car rule)))
	(setq new-score (or (nth 1 rule)
			    gnus-score-interactive-default-score))
	(when (numberp multiple)
	  (setq new-score (* multiple new-score)))
	;; This rule was successful, so we add the score to this
	;; article.
	(if (setq score (assq (mail-header-number gnus-advanced-headers)
			      gnus-newsgroup-scored))
	    (setcdr score
		    (+ (cdr score) new-score))
	  (push (cons (mail-header-number gnus-advanced-headers)
		      new-score)
		gnus-newsgroup-scored)
	  (when trace
	    (push (cons "A file" rule)
		  ;; Must be synced with `gnus-score-edit-file-at-point'.
		  gnus-score-trace)))))))

(defun gnus-advanced-score-rule (rule)
  "Apply RULE to `gnus-advanced-headers'."
  (let ((type (car rule)))

	      gnus-advanced-headers
	      (if (string-match "^\\([0-9]+\\)-$" (symbol-name type))
		  ;; 1- type redirection.
		  (string-to-number
		   (substring (symbol-name type)
			      (match-beginning 1) (match-end 1)))
		;; ^^^ type redirection.
		(length (symbol-name type))))))
	(when gnus-advanced-headers
	  (gnus-advanced-score-rule (nth 1 rule)))))
     ;; Plain scoring rule.

     ;; Bug-out time!
     (t
      (error "Unknown advanced score type: %s" rule)))))

(defun gnus-advanced-score-article (rule)
  ;; `rule' is a semi-normal score rule, so we find out what function
  ;; that's supposed to do the actual processing.
  (let* ((header (car rule))
	 (func (assoc (downcase header) gnus-advanced-index)))
    (if (not func)
	(error "No such header: %s" rule)
      ;; Call the score function.

      (error "No such string match type: %s" type)))))

(defun gnus-advanced-integer (index match type)
  (if (not (memq type '(< > <= >= =)))
      (error "No such integer score type: %s" type)
    (funcall type (or (aref gnus-advanced-headers index) 0) match)))

(defun gnus-advanced-date (index match type)
  (let ((date (apply 'encode-time (parse-time-string
				   (aref gnus-advanced-headers index))))
	(match (apply 'encode-time (parse-time-string match))))

				'gnus-request-head)
			       ((string= "body" header)
				'gnus-request-body)
			       (t 'gnus-request-article)))
	   ofunc article)
      ;; Not all backends support partial fetching.  In that case, we
      ;; just fetch the entire article.
      (unless (gnus-check-backend-function
	       (intern (concat "request-" header))
	       gnus-newsgroup-name)
	(setq ofunc request-func)
	(setq request-func 'gnus-request-article))
      (setq article (mail-header-number gnus-advanced-headers))
      (gnus-message 7 "Scoring article %s..." article)
      (when (funcall request-func article gnus-newsgroup-name)
	(goto-char (point-min))
	;; If just parts of the article is to be searched and the
	;; backend didn't support partial fetching, we just narrow to
	;; the relevant parts.
	(when ofunc
	  (if (eq ofunc 'gnus-request-head)
	      (narrow-to-region
	       (point)
	       (or (search-forward "\n\n" nil t) (point-max)))

	      (funcall search-func match nil t)
	    (widen)))))))

(provide 'gnus-logic)

;;; arch-tag: 9651a100-4a59-4b69-a55b-e511e67c0f8d
;;; gnus-logic.el ends here