From: Jan Tatarik <jan.tatarik@gmail.com>
To: ding@gnus.org
Cc: Lars Magne Ingebrigtsen <larsi@gnus.org>
Subject: Re: Scoring on basee64 encoded message body
Date: Thu, 28 Jun 2012 11:45:23 +0200 [thread overview]
Message-ID: <5n5x2rhatvvkgc.fsf@nb-jtatarik2.xing.hh> (raw)
In-Reply-To: <m362aylvsn.fsf@stories.gnus.org> (Lars Magne Ingebrigtsen's message of "Sun, 10 Jun 2012 23:08:24 +0200")
[-- Attachment #1: Type: text/plain, Size: 329 bytes --]
On Sun, Jun 10 2012, Lars Magne Ingebrigtsen Lars Magne Ingebrigtsen wrote:
> Jan Tatarik <jan.tatarik@gmail.com> writes:
>> And here is the new patch.
> Sorry for the extreme delays here.
> The patch looks good.
> I don't remember whether I asked you whether you had FSF copyright
> assignments on file or not?
I do now.
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: score by body --]
[-- Type: text/x-diff, Size: 14559 bytes --]
diff --git a/lisp/gnus-logic.el b/lisp/gnus-logic.el
index 954295438c953c2500b9c1959a49e52312cc9653..a440b7799303ddf46674c35c20f5bba51388b50c 100644
--- a/lisp/gnus-logic.el
+++ b/lisp/gnus-logic.el
@@ -180,46 +180,51 @@
(setq header "article"))
(with-current-buffer nntp-server-buffer
(let* ((request-func (cond ((string= "head" header)
- 'gnus-request-head)
- ((string= "body" header)
- 'gnus-request-body)
- (t 'gnus-request-article)))
- ofunc article)
+ 'gnus-request-head)
+ ;; We need to peek at the headers to detect the
+ ;; content encoding
+ ((string= "body" header)
+ 'gnus-request-article)
+ (t 'gnus-request-article)))
+ ofunc article handles)
;; 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))
+ (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)))
- (narrow-to-region
- (or (search-forward "\n\n" nil t) (point))
- (point-max))))
- (let* ((case-fold-search (not (eq (downcase (symbol-name type))
- (symbol-name type))))
- (search-func
- (cond ((memq type '(r R regexp Regexp))
- 're-search-forward)
- ((memq type '(s S string String))
- 'search-forward)
- (t
- (error "Invalid match type: %s" type)))))
- (goto-char (point-min))
- (prog1
- (funcall search-func match nil t)
- (widen)))))))
+ (when (string= "body" header)
+ (setq handles (gnus-score-decode-text-parts)))
+ (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)))
+ (narrow-to-region
+ (or (search-forward "\n\n" nil t) (point))
+ (point-max))))
+ (let* ((case-fold-search (not (eq (downcase (symbol-name type))
+ (symbol-name type))))
+ (search-func
+ (cond ((memq type '(r R regexp Regexp))
+ 're-search-forward)
+ ((memq type '(s S string String))
+ 'search-forward)
+ (t
+ (error "Invalid match type: %s" type)))))
+ (goto-char (point-min))
+ (prog1
+ (funcall search-func match nil t)
+ (widen)))
+ (when handles (mm-destroy-parts handles))))))
(provide 'gnus-logic)
diff --git a/lisp/gnus-score.el b/lisp/gnus-score.el
index f86b6f837a70ce54b06668187821fe57c3f80f4c..d50b3cc0cf02812ef32f53beaf85cd27171680d4 100644
--- a/lisp/gnus-score.el
+++ b/lisp/gnus-score.el
@@ -1736,105 +1736,140 @@ score in `gnus-newsgroup-scored' by SCORE."
(setq entries rest)))))
nil)
+(defun gnus-score-decode-text-parts ()
+ (labels ((mm-text-parts (handle)
+ (cond ((stringp (car handle))
+ (let ((parts (mapcan 'mm-text-parts (cdr handle))))
+ (if (equal "multipart/alternative" (car handle))
+ ;; pick the first supported alternative
+ (list (car parts))
+ parts)))
+
+ ((bufferp (car handle))
+ (when (string-match "^text/" (mm-handle-media-type handle))
+ (list handle)))
+
+ (t (mapcan 'mm-text-parts handle))))
+ (my-mm-display-part (handle)
+ (when handle
+ (save-restriction
+ (narrow-to-region (point) (point))
+ (mm-display-inline handle)
+ (goto-char (point-max))))))
+
+ (let (;(mm-text-html-renderer 'w3m-standalone)
+ (handles (mm-dissect-buffer t)))
+ (save-excursion
+ (article-goto-body)
+ (delete-region (point) (point-max))
+ (mapc 'my-mm-display-part (mm-text-parts handles))
+ handles))))
+
(defun gnus-score-body (scores header now expire &optional trace)
- (if gnus-agent-fetching
- nil
- (save-excursion
- (setq gnus-scores-articles
- (sort gnus-scores-articles
- (lambda (a1 a2)
- (< (mail-header-number (car a1))
- (mail-header-number (car a2))))))
- (set-buffer nntp-server-buffer)
- (save-restriction
- (let* ((buffer-read-only nil)
- (articles gnus-scores-articles)
- (all-scores scores)
- (request-func (cond ((string= "head" header)
- 'gnus-request-head)
- ((string= "body" header)
- 'gnus-request-body)
- (t 'gnus-request-article)))
- entries alist ofunc article last)
- (when articles
- (setq last (mail-header-number (caar (last articles))))
- ;; Not all backends support partial fetching. In that case,
- ;; we just fetch the entire article.
- (unless (gnus-check-backend-function
- (and (string-match "^gnus-" (symbol-name request-func))
- (intern (substring (symbol-name request-func)
- (match-end 0))))
- gnus-newsgroup-name)
- (setq ofunc request-func)
- (setq request-func 'gnus-request-article))
- (while articles
- (setq article (mail-header-number (caar articles)))
- (gnus-message 7 "Scoring article %s of %s..." article last)
- (widen)
- (when (funcall request-func article gnus-newsgroup-name)
- (goto-char (point-min))
- ;; If just parts of the article is to be searched, but 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)))
- (narrow-to-region
- (or (search-forward "\n\n" nil t) (point))
- (point-max))))
- (setq scores all-scores)
- ;; Find matches.
- (while scores
- (setq alist (pop scores)
- entries (assoc header alist))
- (while (cdr entries) ;First entry is the header index.
- (let* ((rest (cdr entries))
- (kill (car rest))
- (match (nth 0 kill))
- (type (or (nth 3 kill) 's))
- (score (or (nth 1 kill)
- gnus-score-interactive-default-score))
- (date (nth 2 kill))
- (found nil)
- (case-fold-search
- (not (or (eq type 'R) (eq type 'S)
- (eq type 'Regexp) (eq type 'String))))
- (search-func
- (cond ((or (eq type 'r) (eq type 'R)
- (eq type 'regexp) (eq type 'Regexp))
- 're-search-forward)
- ((or (eq type 's) (eq type 'S)
- (eq type 'string) (eq type 'String))
- 'search-forward)
- (t
- (error "Invalid match type: %s" type)))))
- (goto-char (point-min))
- (when (funcall search-func match nil t)
- ;; Found a match, update scores.
- (setcdr (car articles) (+ score (cdar articles)))
- (setq found t)
- (when trace
- (push
- (cons (car-safe (rassq alist gnus-score-cache))
- kill)
- gnus-score-trace)))
- ;; Update expire date
- (unless trace
- (cond
- ((null date)) ;Permanent entry.
- ((and found gnus-update-score-entry-dates)
- ;; Match, update date.
- (gnus-score-set 'touched '(t) alist)
- (setcar (nthcdr 2 kill) now))
- ((and expire (< date expire)) ;Old entry, remove.
- (gnus-score-set 'touched '(t) alist)
- (setcdr entries (cdr rest))
- (setq rest entries))))
- (setq entries rest)))))
- (setq articles (cdr articles)))))))
- nil))
+ (if gnus-agent-fetching
+ nil
+ (save-excursion
+ (setq gnus-scores-articles
+ (sort gnus-scores-articles
+ (lambda (a1 a2)
+ (< (mail-header-number (car a1))
+ (mail-header-number (car a2))))))
+ (set-buffer nntp-server-buffer)
+ (save-restriction
+ (let* ((buffer-read-only nil)
+ (articles gnus-scores-articles)
+ (all-scores scores)
+ (request-func (cond ((string= "head" header)
+ 'gnus-request-head)
+ ;; We need to peek at the headers to detect
+ ;; the content encoding
+ ((string= "body" header)
+ 'gnus-request-article)
+ (t 'gnus-request-article)))
+ entries alist ofunc article last)
+ (when articles
+ (setq last (mail-header-number (caar (last articles))))
+ ;; Not all backends support partial fetching. In that case,
+ ;; we just fetch the entire article.
+ (unless (gnus-check-backend-function
+ (and (string-match "^gnus-" (symbol-name request-func))
+ (intern (substring (symbol-name request-func)
+ (match-end 0))))
+ gnus-newsgroup-name)
+ (setq ofunc request-func)
+ (setq request-func 'gnus-request-article))
+ (while articles
+ (setq article (mail-header-number (caar articles)))
+ (gnus-message 7 "Scoring article %s of %s..." article last)
+ (widen)
+ (let (handles)
+ (when (funcall request-func article gnus-newsgroup-name)
+ (when (string= "body" header)
+ (setq handles (gnus-score-decode-text-parts)))
+ (goto-char (point-min))
+ ;; If just parts of the article is to be searched, but 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)))
+ (narrow-to-region
+ (or (search-forward "\n\n" nil t) (point))
+ (point-max))))
+ (setq scores all-scores)
+ ;; Find matches.
+ (while scores
+ (setq alist (pop scores)
+ entries (assoc header alist))
+ (while (cdr entries) ;First entry is the header index.
+ (let* ((rest (cdr entries))
+ (kill (car rest))
+ (match (nth 0 kill))
+ (type (or (nth 3 kill) 's))
+ (score (or (nth 1 kill)
+ gnus-score-interactive-default-score))
+ (date (nth 2 kill))
+ (found nil)
+ (case-fold-search
+ (not (or (eq type 'R) (eq type 'S)
+ (eq type 'Regexp) (eq type 'String))))
+ (search-func
+ (cond ((or (eq type 'r) (eq type 'R)
+ (eq type 'regexp) (eq type 'Regexp))
+ 're-search-forward)
+ ((or (eq type 's) (eq type 'S)
+ (eq type 'string) (eq type 'String))
+ 'search-forward)
+ (t
+ (error "Invalid match type: %s" type)))))
+ (goto-char (point-min))
+ (when (funcall search-func match nil t)
+ ;; Found a match, update scores.
+ (setcdr (car articles) (+ score (cdar articles)))
+ (setq found t)
+ (when trace
+ (push
+ (cons (car-safe (rassq alist gnus-score-cache))
+ kill)
+ gnus-score-trace)))
+ ;; Update expire date
+ (unless trace
+ (cond
+ ((null date)) ;Permanent entry.
+ ((and found gnus-update-score-entry-dates)
+ ;; Match, update date.
+ (gnus-score-set 'touched '(t) alist)
+ (setcar (nthcdr 2 kill) now))
+ ((and expire (< date expire)) ;Old entry, remove.
+ (gnus-score-set 'touched '(t) alist)
+ (setcdr entries (cdr rest))
+ (setq rest entries))))
+ (setq entries rest))))
+ (when handles (mm-destroy-parts handles))))
+ (setq articles (cdr articles)))))))
+ nil))
(defun gnus-score-thread (scores header now expire &optional trace)
(gnus-score-followup scores header now expire trace t))
next prev parent reply other threads:[~2012-06-28 9:45 UTC|newest]
Thread overview: 20+ messages / expand[flat|nested] mbox.gz Atom feed top
2012-03-13 10:39 Jan Tatarik
2012-03-14 14:38 ` Lars Magne Ingebrigtsen
2012-03-14 20:21 ` Reiner Steib
2012-03-15 1:29 ` Lars Magne Ingebrigtsen
2012-03-15 21:05 ` Jan Tatarik
2012-03-22 20:38 ` Lars Magne Ingebrigtsen
2012-03-23 12:11 ` Jan Tatarik
2012-04-10 19:32 ` Lars Magne Ingebrigtsen
2012-04-11 7:30 ` Jan Tatarik
2012-04-11 19:34 ` Jan Tatarik
2012-04-12 18:45 ` Lars Magne Ingebrigtsen
2012-04-12 22:58 ` Jan Tatarik
2012-06-10 21:08 ` Lars Magne Ingebrigtsen
2012-06-28 9:45 ` Jan Tatarik [this message]
2012-09-05 13:40 ` Lars Ingebrigtsen
2012-09-05 14:39 ` Jan Tatarik
2012-09-05 14:43 ` Lars Ingebrigtsen
2012-09-05 15:07 ` Jan Tatarik
2012-09-05 15:35 ` Lars Ingebrigtsen
2012-09-05 15:42 ` Andreas Schwab
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=5n5x2rhatvvkgc.fsf@nb-jtatarik2.xing.hh \
--to=jan.tatarik@gmail.com \
--cc=ding@gnus.org \
--cc=larsi@gnus.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for NNTP newsgroup(s).