bug#71666: 30.0.50; [PATCH] Fix zooming images with SHR

[Jim Porter <jporterbugs@gmail.com>]

[-- Attachment #1: Type: text/plain, Size: 55 bytes --]

Here's an improved patch with a better regression test.

[-- Attachment #2: 0001-Fix-zooming-images-in-SHR.patch --]
[-- Type: text/plain, Size: 11077 bytes --]

From 3c7d28b594883f5d939f5ac251c73750c80db927 Mon Sep 17 00:00:00 2001
From: Jim Porter <jporterbugs@gmail.com>
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 (bug#71666).

* 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 | 62 ++++++++++++++++++++++++
 2 files changed, 113 insertions(+), 47 deletions(-)

diff --git a/lisp/net/shr.el b/lisp/net/shr.el
index 14b3f7aa163..e0e19a5f058 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 image 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..b2ece3049a1 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,50 @@ 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 "<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)
+                     (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-let ((pos (next-single-property-change (point) 'display)))
+                (when-let ((display (get-text-property pos '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 pos))
+              ;; Make sure we actually saw a slice.
+              (should (> slice-count 1)))))))))
+
 (require 'shr)
 
 ;;; shr-tests.el ends here
-- 
2.25.1