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.

(cherry picked from commit 5f9b5803bea0f360a91e00cd85d72ea7f56d6095)

diff --git a/lisp/net/shr.el b/lisp/net/shr.el
index 14b3f7aa1634fd154be68713f97aa99f8c0f2e7a..3dadcb9a09ba14e16057766c7c684f79c6edb1f2 100644 (file)
--- a/lisp/net/shr.el
+++ b/lisp/net/shr.el
@@ -282,6 +282,14 @@ temporarily blinks with this face."
   "Face used for <mark> elements."
   :version "29.1")
 
+(defface shr-sliced-image
+  '((t :underline nil :overline nil))
+  "Face used for sliced images.
+This face should remove any unsightly decorations from sliced images.
+Otherwise, decorations like underlines from links would normally show on
+every slice."
+  :version "30.1")
+
 (defcustom shr-inhibit-images nil
   "If non-nil, inhibit loading images."
   :version "28.1"
@@ -600,38 +608,34 @@ the URL of the image to the kill buffer instead."
                    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.
 
@@ -1070,6 +1074,7 @@ the mouse click event."
                       ;; We don't want to record these changes.
                       (buffer-undo-list t)
                      (inhibit-read-only t))
+                  (remove-overlays start end)
                  (delete-region start end)
                  (goto-char start)
                  (funcall shr-put-image-function data alt flags)
@@ -1144,7 +1149,8 @@ element is the data blob and the second element is the content-type."
           ;; 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 +1159,16 @@ element is the data blob and the second element is the content-type."
                (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.
+                  (progn
+                    (insert-sliced-image image "*" nil 20 1)
+                    (let ((overlay (make-overlay start (point))))
+                      ;; Avoid displaying unsightly decorations on the
+                      ;; image slices.
+                      (overlay-put overlay 'face 'shr-sliced-image)))
                (insert-image image alt))
              (put-text-property start (point) 'image-size size)
              (when (and (not inline) shr-max-inline-image-size)
@@ -1854,17 +1869,12 @@ The preference is a float determined from `shr-prefer-media-type'."
            (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 171380534504e972b9664e05b7ec8364583c39c3..b6552674b27e6552b074fab31f1208b6ab300fa5 100644 (file)
--- 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