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 (bug#71666).

* lisp/net/shr.el (shr-sliced-image): New face.
(shr-zoom-image): Reimplement using
'next/previous-single-property-change', and don't bother deleting any of
the text.
(shr-image-fetched): Clean up any overlays when deleting the old region.
(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.  Apply an
overlay to sliced images to prevent unsightly text decorations.
(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.

1 files changed, 64 insertions, 0 deletions

diff --git a/test/lisp/net/shr-tests.el b/test/lisp/net/shr-tests.el
index 17138053450..b6552674b27 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 @@ validate for the NAME testcase.
 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,52 @@ settings, then once more for each (OPTION . VALUE) pair.")
   (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 "<img src=\"file://%s\" %s" image attrs)))
+          (cl-letf* (;; Pretend we're a graphical display.
+                     ((symbol-function 'display-graphic-p) #'always)
+                     ((symbol-function 'url-queue-retrieve)
+                      (lambda (&rest args)
+                        (apply #'run-at-time 0 nil #'url-retrieve args)))
+                     (put-image-calls 0)
+                     (shr-put-image-function
+                      (lambda (&rest args)
+                        (cl-incf put-image-calls)
+                        (apply #'shr-put-image args)))
+                     (shr-width 80)
+                     (shr-use-fonts nil)
+                     (shr-image-animate nil)
+                     (inhibit-message t)
+                     (dom (libxml-parse-html-region (point-min) (point-max))))
+            ;; Render the document.
+            (erase-buffer)
+            (shr-insert-document dom)
+            (shr-test-wait-for (lambda () (= put-image-calls 1)))
+            ;; Now zoom the image.
+            (goto-char (point-min))
+            (shr-zoom-image)
+            (shr-test-wait-for (lambda () (= put-image-calls 2)))
+            ;; Check that we got a sliced image.
+            (let ((slice-count 0))
+              (goto-char (point-min))
+              (while (< (point) (point-max))
+                (when-let ((display (get-text-property (point) 'display)))
+                  ;; If this is nil, we found a non-sliced image, but we
+                  ;; should have replaced that!
+                  (should (assq 'slice display))
+                  (cl-incf slice-count))
+                (goto-char (or (next-single-property-change (point) 'display)
+                               (point-max))))
+              ;; Make sure we actually saw a slice.
+              (should (> slice-count 1)))))))))
+
 (require 'shr)
 
 ;;; shr-tests.el ends here