Subject: bug#71666: closed (Re: bug#71666: 30.0.50; [PATCH] Fix zooming images with SHR)

From: [email-masked] (GNU bug Tracking System)
Date: Thu, 04 Jul 2024 19:20:02 +0000

Your bug report

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

which was filed against the emacs package, has been closed.

The explanation is attached below, along with your original report.
If you require more details, please reply to [email-masked].

-- 
71666: https://debbugs.gnu.org/cgi/bugreport.cgi?bug=71666
GNU Bug Tracking System
Contact [email-masked] with problems

Subject: Re: bug#71666: 30.0.50; [PATCH] Fix zooming images with SHR
From: Jim Porter <[email-masked]>
To: Stefan Kangas <[email-masked]>, Eli Zaretskii <[email-masked]>
Cc: [email-masked]
Date: Thu, 4 Jul 2024 12:18:08 -0700
List-Id: <debbugs-submit.debbugs.gnu.org>

On 6/28/2024 8:39 PM, Stefan Kangas wrote:
> OK, thanks.  I had missed some necessary context here.  If they're not
> regressions from Emacs 29, you're right that they belong on master.

Pushed to the master branch as f91387cce8f, and closing this bug now.

Subject: 30.0.50; [PATCH] Fix zooming images with SHR
From: Jim Porter <[email-masked]>
To: [email-masked]
Date: Wed, 19 Jun 2024 21:47:26 -0700
List-Id: <debbugs-submit.debbugs.gnu.org>

To reproduce this, start from "emacs -Q -f eww" and then go to fsf.org. 
Move point over one of the larger images on the page, like the ones that 
say "Featured" above them, and press Z ('shr-zoom-image'). The result is 
that the image is duplicated, and the first slice gets pushed up onto 
the previous line.

Attached is a patch to fix this, with regression tests.

From 09e25981700a34001e3edcab6f8cc3eb0a715d12 Mon Sep 17 00:00:00 2001
From: Jim Porter <[email-masked]>
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 "<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)))
+                  (cl-incf slice-count))
+                (goto-char pos))
+              (should (> slice-count 1)))))))))
+
 (require 'shr)
 
 ;;; shr-tests.el ends here
-- 
2.25.1