From 09e25981700a34001e3edcab6f8cc3eb0a715d12 Mon Sep 17 00:00:00 2001 From: Jim Porter Date: Wed, 19 Jun 2024 20:59:59 -0700 Subject: [PATCH] Fix zooming images in SHR Previously, for images with no alt-text, the zoomed image wouldn't get properly inserted. For images with alt-text, both the zoomed and unzoomed image would be displayed at once. * lisp/net/shr.el (shr-zoom-image): Reimplement using 'next/previous-single-property-change', and don't bother deleting any of the text. (shr-image-fetched): Don't give sliced images a face. (shr-put-image): Ensure we always have a non-empty string to put the image on. For sliced images, just use "*", since we'll repeat it, so we can't preserve the original buffer text exactly anyway. (shr-tag-img): Move the placeholder space insertion where it should be and explain what it's doing. * test/lisp/net/shr-tests.el (shr-test--max-wait-time) (shr-test-wait-for): New helper functions. (shr-test/zoom-image): New test. --- lisp/net/shr.el | 98 ++++++++++++++++++++------------------ test/lisp/net/shr-tests.el | 58 ++++++++++++++++++++++ 2 files changed, 109 insertions(+), 47 deletions(-) diff --git a/lisp/net/shr.el b/lisp/net/shr.el index 14b3f7aa163..a92526a9e4e 100644 --- a/lisp/net/shr.el +++ b/lisp/net/shr.el @@ -600,38 +600,34 @@ shr-insert-image t)))) (defun shr-zoom-image () - "Toggle the image size. -The size will be rotated between the default size, the original -size, and full-buffer size." + "Cycle the image size. +The size will cycle through the default size, the original size, and +full-buffer size." (interactive) - (let ((url (get-text-property (point) 'image-url)) - (size (get-text-property (point) 'image-size)) - (buffer-read-only nil)) + (let ((url (get-text-property (point) 'image-url))) (if (not url) (message "No image under point") - ;; Delete the old picture. - (while (get-text-property (point) 'image-url) - (forward-char -1)) - (forward-char 1) - (let ((start (point))) - (while (get-text-property (point) 'image-url) - (forward-char 1)) - (forward-char -1) - (put-text-property start (point) 'display nil) - (when (> (- (point) start) 2) - (delete-region start (1- (point))))) - (message "Inserting %s..." url) - (url-retrieve url #'shr-image-fetched - (list (current-buffer) (1- (point)) (point-marker) - (list (cons 'size - (cond ((or (eq size 'default) - (null size)) - 'original) - ((eq size 'original) - 'full) - ((eq size 'full) - 'default))))) - t)))) + (let* ((end (or (next-single-property-change (point) 'image-url) + (point-max))) + (start (or (previous-single-property-change end 'image-url) + (point-min))) + (size (get-text-property (point) 'image-size)) + (next-size (cond ((or (eq size 'default) + (null size)) + 'original) + ((eq size 'original) + 'full) + ((eq size 'full) + 'default))) + (buffer-read-only nil)) + ;; Delete the old picture. + (put-text-property start end 'display nil) + (message "Inserting %s..." url) + (url-retrieve url #'shr-image-fetched + `(,(current-buffer) ,start + ,(set-marker (make-marker) end) + ((size . ,next-size))) + t))))) ;;; Utility functions. @@ -1073,11 +1069,19 @@ shr-image-fetched (delete-region start end) (goto-char start) (funcall shr-put-image-function data alt flags) - (while properties - (let ((type (pop properties)) - (value (pop properties))) - (unless (memq type '(display image-size)) - (put-text-property start (point) type value))))))))))) + (let ((sliced-image (assq 'slice (get-text-property + start 'display)))) + (while properties + (let ((type (pop properties)) + (value (pop properties))) + (unless (or (memq type '(display image-size)) + ;; Sliced images shouldn't have a + ;; face; if the images is a link, + ;; we'd get underlines on every + ;; slice! + (and sliced-image (eq type 'face))) + (put-text-property + start (point) type value)))))))))))) (kill-buffer image-buffer))) (defun shr-image-from-data (data) @@ -1144,7 +1148,8 @@ shr-put-image ;; putting any space after inline images. ;; ALT may be nil when visiting image URLs in eww ;; (bug#67764). - (setq alt (if alt (string-trim alt) "*")) + (setq alt (string-trim (or alt ""))) + (when (length= alt 0) (setq alt "*")) ;; When inserting big-ish pictures, put them at the ;; beginning of the line. (let ((inline (shr--inline-image-p image))) @@ -1153,7 +1158,11 @@ shr-put-image (insert "\n")) (let ((image-pos (point))) (if (eq size 'original) - (insert-sliced-image image alt nil 20 1) + ;; Normally, we try to keep the buffer text the same + ;; by preserving ALT. With a sliced image, we have to + ;; repeat the text for each line, so we can't do that. + ;; Just use "*" for the string to insert instead. + (insert-sliced-image image "*" nil 20 1) (insert-image image alt)) (put-text-property start (point) 'image-size size) (when (and (not inline) shr-max-inline-image-size) @@ -1854,17 +1863,12 @@ shr-tag-img (let ((file (url-cache-create-filename url))) (when (file-exists-p file) (delete-file file)))) - (when (image-type-available-p 'svg) - (insert-image - (shr-make-placeholder-image dom) - (or (string-trim alt) ""))) - ;; Paradoxically this space causes shr not to insert spaces after - ;; inline images. Since the image is temporary it seem like there - ;; should be no downside to not inserting it but since I don't - ;; understand the code well and for the sake of backward compatibility - ;; we preserve it unless user has set `shr-max-inline-image-size'. - (unless shr-max-inline-image-size - (insert " ")) + (if (image-type-available-p 'svg) + (insert-image + (shr-make-placeholder-image dom) + (or (string-trim alt) "")) + ;; No SVG support. Just use a space as our placeholder. + (insert " ")) (url-queue-retrieve url #'shr-image-fetched (list (current-buffer) start (set-marker (make-marker) (point)) diff --git a/test/lisp/net/shr-tests.el b/test/lisp/net/shr-tests.el index 17138053450..84d03058dc8 100644 --- a/test/lisp/net/shr-tests.el +++ b/test/lisp/net/shr-tests.el @@ -29,6 +29,22 @@ (declare-function libxml-parse-html-region "xml.c") +(defvar shr-test--max-wait-time 5 + "The maximum amount of time to wait for a condition to resolve, in seconds. +See `shr-test-wait-for'.") + +(defun shr-test-wait-for (predicate &optional message) + "Wait until PREDICATE returns non-nil. +If this takes longer than `shr-test--max-wait-time', raise an error. +MESSAGE is an optional message to use if this times out." + (let ((start (current-time)) + (message (or message "timed out waiting for condition"))) + (while (not (funcall predicate)) + (when (> (float-time (time-since start)) + shr-test--max-wait-time) + (error message)) + (sit-for 0.1)))) + (defun shr-test--rendering-check (name &optional context) "Render NAME.html and compare it to NAME.txt. Raise a test failure if the rendered buffer does not match NAME.txt. @@ -68,6 +84,8 @@ shr-test--rendering-extra-configs The `rendering' testcase will test NAME once without altering any settings, then once more for each (OPTION . VALUE) pair.") +;;; Tests: + (ert-deftest rendering () (skip-unless (fboundp 'libxml-parse-html-region)) (dolist (file (directory-files (ert-resource-directory) nil "\\.html\\'")) @@ -114,6 +132,46 @@ shr-srcset (should (equal (shr--parse-srcset "https://example.org/1,2\n\n 10w , https://example.org/2 20w ") '(("https://example.org/2" 20) ("https://example.org/1,2" 10))))) +(ert-deftest shr-test/zoom-image () + "Test that `shr-zoom-image' properly replaces the original image." + (let ((image (expand-file-name "data/image/blank-100x200.png" + (getenv "EMACS_TEST_DIRECTORY")))) + (dolist (alt '(nil "" "nothing to see here")) + (with-temp-buffer + (ert-info ((format "image with alt=%S" alt)) + (let ((attrs (if alt (format " alt=\"%s\"" alt) ""))) + (insert (format " slice-count 1))))))))) + (require 'shr) ;;; shr-tests.el ends here -- 2.25.1