From 387b3ba7d4c42771d541085cddfc02ebf276521d Mon Sep 17 00:00:00 2001 From: Katsumi Yamaoka Date: Tue, 10 May 2011 03:10:49 +0000 Subject: [PATCH] shr.el (shr-put-image-function): New variable. (shr-image-fetched, shr-image-displayer, shr-tag-img): Funcall it. (shr-put-image): Return scaled image. gnus-art.el (gnus-shr-put-image): New function. (gnus-article-prepare-display): Bind shr-put-image-function to it. gnus-html.el (gnus-html-wash-images): Register scaled images, not original ones, as deletable. --- lisp/ChangeLog | 12 ++++++++++++ lisp/gnus-art.el | 12 ++++++++++++ lisp/gnus-html.el | 20 ++++++++++---------- lisp/shr.el | 17 +++++++++++------ 4 files changed, 45 insertions(+), 16 deletions(-) diff --git a/lisp/ChangeLog b/lisp/ChangeLog index eba501529..49a477612 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,15 @@ +2011-05-10 Katsumi Yamaoka + + * shr.el (shr-put-image-function): New variable. + (shr-image-fetched, shr-image-displayer, shr-tag-img): Funcall it. + (shr-put-image): Return scaled image. + + * gnus-art.el (gnus-shr-put-image): New function. + (gnus-article-prepare-display): Bind shr-put-image-function to it. + + * gnus-html.el (gnus-html-wash-images): Register scaled images, not + original ones, as deletable. + 2011-05-09 Stefan Monnier * nntp.el (nntp-open-connection): Set TCP keepalive option. diff --git a/lisp/gnus-art.el b/lisp/gnus-art.el index 690e29cb6..13531bf43 100644 --- a/lisp/gnus-art.el +++ b/lisp/gnus-art.el @@ -4656,6 +4656,8 @@ If ALL-HEADERS is non-nil, no headers are hidden." (gnus-run-hooks 'gnus-article-prepare-hook) t)))))) +(defvar shr-put-image-function) + ;;;###autoload (defun gnus-article-prepare-display () "Make the current buffer look like a nice article." @@ -4669,6 +4671,7 @@ If ALL-HEADERS is non-nil, no headers are hidden." (setq buffer-read-only nil gnus-article-wash-types nil gnus-article-image-alist nil) + (set (make-local-variable 'shr-put-image-function) 'gnus-shr-put-image) (gnus-run-hooks 'gnus-tmp-internal-hook) (when gnus-display-mime-function (funcall gnus-display-mime-function)))) @@ -6139,6 +6142,15 @@ Provided for backwards compatibility." (not gnus-inhibit-hiding)) (gnus-article-hide-headers))) +(declare-function shr-put-image "shr" (data alt)) + +(defun gnus-shr-put-image (data alt) + "Put image DATA with a string ALT. Enable image to be deleted." + (let ((image (shr-put-image data (propertize (or alt "*") + 'gnus-image-category 'shr)))) + (when image + (gnus-add-image 'shr image)))) + ;;; Article savers. (defun gnus-output-to-file (file-name) diff --git a/lisp/gnus-html.el b/lisp/gnus-html.el index f380d079d..b7f0c0922 100644 --- a/lisp/gnus-html.el +++ b/lisp/gnus-html.el @@ -215,16 +215,16 @@ CHARS is a regexp-like character alternative (e.g., \"[)$]\")." (mm-with-part handle (buffer-string)) nil t)))) (if image - (progn - (gnus-put-image - (gnus-rescale-image - image (gnus-html-maximum-image-size)) - (gnus-string-or (prog1 - (buffer-substring start end) - (delete-region start end)) - "*") - 'cid) - (gnus-add-image 'cid image)) + (gnus-add-image + 'cid + (gnus-put-image + (gnus-rescale-image + image (gnus-html-maximum-image-size)) + (gnus-string-or (prog1 + (buffer-substring start end) + (delete-region start end)) + "*") + 'cid)) (widget-convert-button 'link start end :action 'gnus-html-insert-image diff --git a/lisp/shr.el b/lisp/shr.el index 2e7968e8d..da27edca6 100644 --- a/lisp/shr.el +++ b/lisp/shr.el @@ -87,6 +87,9 @@ used." This is used for cid: URLs, and the function is called with the cid: URL as the argument.") +(defvar shr-put-image-function 'shr-put-image + "Function called to put image and alt string.") + (defface shr-strike-through '((t (:strike-through t))) "Font for elements." :group 'shr) @@ -500,10 +503,11 @@ redirects somewhere else." (inhibit-read-only t)) (delete-region start end) (goto-char start) - (shr-put-image data alt))))))) + (funcall shr-put-image-function data alt))))))) (kill-buffer (current-buffer))) (defun shr-put-image (data alt) + "Put image DATA with a string ALT. Return image." (if (display-graphic-p) (let ((image (ignore-errors (shr-rescale-image data)))) @@ -513,7 +517,8 @@ redirects somewhere else." (when (and (> (current-column) 0) (> (car (image-size image t)) 400)) (insert "\n")) - (insert-image image (or alt "*")))) + (insert-image image (or alt "*"))) + image) (insert alt))) (defun shr-rescale-image (data) @@ -576,8 +581,8 @@ START, and END. Note that START and END should be merkers." (substring url (match-end 0))))) (when image (goto-char start) - (shr-put-image image - (buffer-substring-no-properties start end)) + (funcall shr-put-image-function + image (buffer-substring-no-properties start end)) (delete-region (point) end)))) (url-retrieve url 'shr-image-fetched (list (current-buffer) start end) @@ -864,7 +869,7 @@ ones, in case fg and bg are nil." (if (or (not shr-content-function) (not (setq image (funcall shr-content-function url)))) (insert alt) - (shr-put-image image alt)))) + (funcall shr-put-image-function image alt)))) ((or shr-inhibit-images (and shr-blocked-images (string-match shr-blocked-images url))) @@ -874,7 +879,7 @@ ones, in case fg and bg are nil." (shr-insert (truncate-string-to-width alt 8)) (shr-insert alt)))) ((url-is-cached (shr-encode-url url)) - (shr-put-image (shr-get-image-data url) alt)) + (funcall shr-put-image-function (shr-get-image-data url) alt)) (t (insert alt) (funcall -- 2.34.1