[gnus git] branch master updated: m0-5-112-gb0e097a =1= Allow scoring on decoded (base64, etc) bodies.
Lars Ingebrigtsen <[email protected]>
| Newsgroups | gmane.emacs.gnus.cvs |
|---|---|
| Message-ID | <[email protected]> |
via b0e097a051ce5e58042ab6e1b5fa6519b1ed87c4 (commit)
from 62fd37db11864a175f94b73bf7fe433ab6d6d24f (commit)
- Log -----------------------------------------------------------------
commit b0e097a051ce5e58042ab6e1b5fa6519b1ed87c4
Author: Jan Tatarik <[email protected]>
Date: Wed Sep 5 15:40:34 2012 +0200
Allow scoring on decoded (base64, etc) bodies.
* gnus-score.el (gnus-score-decode-text-parts): Ditto.
* gnus-logic.el (gnus-advanced-body): Allow scoring on decoded bodies.
diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index c9ce150..ff0090a 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,3 +1,9 @@
+2012-09-05 Jan Tatarik <[email protected]>
+
+ * gnus-logic.el (gnus-advanced-body): Allow scoring on decoded bodies.
+
+ * gnus-score.el (gnus-score-decode-text-parts): Ditto.
+
2012-09-05 Magnus Henoch <[email protected]>
* nnmaildir.el: Make nnmaildir understand and write maildir flags.
diff --git a/lisp/gnus-logic.el b/lisp/gnus-logic.el
index 9542954..a440b77 100644
--- a/lisp/gnus-logic.el
+++ b/lisp/gnus-logic.el
@@ -181,10 +181,12 @@
(with-current-buffer nntp-server-buffer
(let* ((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-body)
+ 'gnus-request-article)
(t 'gnus-request-article)))
- ofunc article)
+ ofunc article handles)
;; Not all backends support partial fetching. In that case, we
;; just fetch the entire article.
(unless (gnus-check-backend-function
@@ -195,6 +197,8 @@
(setq article (mail-header-number gnus-advanced-headers))
(gnus-message 7 "Scoring article %s..." article)
(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 and the
;; backend didn't support partial fetching, we just narrow to
@@ -219,7 +223,8 @@
(goto-char (point-min))
(prog1
(funcall search-func match nil t)
- (widen)))))))
+ (widen)))
+ (when handles (mm-destroy-parts handles))))))
(provide 'gnus-logic)
diff --git a/lisp/gnus-score.el b/lisp/gnus-score.el
index f24d889..948c1c3 100644
--- a/lisp/gnus-score.el
+++ b/lisp/gnus-score.el
@@ -1717,6 +1717,35 @@ 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
@@ -1733,8 +1762,10 @@ score in `gnus-newsgroup-scored' by SCORE."
(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-body)
+ 'gnus-request-article)
(t 'gnus-request-article)))
entries alist ofunc article last)
(when articles
@@ -1752,7 +1783,10 @@ score in `gnus-newsgroup-scored' by SCORE."
(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
@@ -1813,7 +1847,8 @@ score in `gnus-newsgroup-scored' by SCORE."
(gnus-score-set 'touched '(t) alist)
(setcdr entries (cdr rest))
(setq rest entries))))
- (setq entries rest)))))
+ (setq entries rest))))
+ (when handles (mm-destroy-parts handles))))
(setq articles (cdr articles)))))))
nil))
-----------------------------------------------------------------------
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we listed those
revisions in full, above.
Summary of changes:
lisp/ChangeLog | 6 ++
lisp/gnus-logic.el | 73 +++++++++--------
lisp/gnus-score.el | 231 ++++++++++++++++++++++++++++++----------------------
3 files changed, 178 insertions(+), 132 deletions(-)
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "Gnus Project".
The branch, master has been updated
hooks/post-receive
--
Gnus Project