Re: master 5f9b5803bea: Fix zooming images in SHR

[john muhl]

The zoom-image test added here fails on --without-x builds.

Running 4 tests (2024-06-23 08:17:31+0200, selector `(not (or (tag 
:expensive-test) (tag :unstable) (tag :nativecomp)))')
   passed  1/4  rendering (0.009750 sec)
   passed  2/4  shr-srcset (0.000130 sec)
Test shr-test/zoom-image backtrace:
  signal(error ("timed out waiting for condition"))
  error("timed out waiting for condition")
  shr-test-wait-for(#f(compiled-function () #<bytecode 0x69f1ca74762a>
  #f(compiled-function () #<bytecode 0x80079e00685ce6d>)()
  #f(compiled-function () #<bytecode -0x1d8127e732d55024>)()
  handler-bind-1(#f(compiled-function () #<bytecode -0x1d8127e732d5502
  ert--run-test-internal(#s(ert--test-execution-info :test #s(ert-test
  ert-run-test(#s(ert-test :name shr-test/zoom-image :documentation "T
  ert-run-or-rerun-test(#s(ert--stats :selector (not (or ... ... ...))
  ert-run-tests((not (or (tag :expensive-test) (tag :unstable) (tag :n
  ert-run-tests-batch((not (or (tag :expensive-test) (tag :unstable) (
  ert-run-tests-batch-and-exit((not (or (tag :expensive-test) (tag :un
  eval((ert-run-tests-batch-and-exit '(not (or (tag :expensive-test) (
  command-line-1(("-L" ":." "-l" "ert" "--eval" "(setq treesit-extra-l
  command-line()
  normal-top-level()
Test shr-test/zoom-image condition:
    Info: image with alt=nil
    (error "timed out waiting for condition")
   FAILED  3/4  shr-test/zoom-image (5.130112 sec) at lisp/net/shr-tests.el:135
   passed  4/4  use-cookies (0.020002 sec)

Ran 4 tests, 3 results as expected, 1 unexpected (2024-06-23 08:17:37+0200, 
5.232000 sec)

1 unexpected results:
   FAILED  shr-test/zoom-image

On Sun, Jun 23, 2024, at 6:14 AM, Jim Porter wrote:
> branch: master
> commit 5f9b5803bea0f360a91e00cd85d72ea7f56d6095
> Author: Jim Porter <jporterbugs@gmail.com>
> Commit: Jim Porter <jporterbugs@gmail.com>
>
>     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.
> ---
>  lisp/net/shr.el            | 94 
> +++++++++++++++++++++++++---------------------
>  test/lisp/net/shr-tests.el | 64 +++++++++++++++++++++++++++++++
>  2 files changed, 116 insertions(+), 42 deletions(-)
>
> diff --git a/lisp/net/shr.el b/lisp/net/shr.el
> index 14b3f7aa163..3dadcb9a09b 100644
> --- 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 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