procyberian/emacs
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Fix zooming images in SHR

Browse source 
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.
This commit is contained in:
Jim Porter 2024-06-19 20:59:59 -07:00
parent 6f2036243f
commit 5f9b5803be
2 changed files with 116 additions and 42 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

94
lisp/net/shr.el
View file

@ -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))

64
test/lisp/net/shr-tests.el
View file

@ -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