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." "Face used for <mark> elements."
:version "29.1") :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 (defcustom shr-inhibit-images nil
"If non-nil, inhibit loading images." "If non-nil, inhibit loading images."
:version "28.1" :version "28.1"
@ -600,38 +608,34 @@ the URL of the image to the kill buffer instead."
t)))) t))))
(defun shr-zoom-image () (defun shr-zoom-image ()
"Toggle the image size. "Cycle the image size.
The size will be rotated between the default size, the original The size will cycle through the default size, the original size, and
size, and full-buffer size." full-buffer size."
(interactive) (interactive)
(let ((url (get-text-property (point) 'image-url)) (let ((url (get-text-property (point) 'image-url)))
(size (get-text-property (point) 'image-size))
(buffer-read-only nil))
(if (not url) (if (not url)
(message "No image under point") (message "No image under point")
;; Delete the old picture. (let* ((end (or (next-single-property-change (point) 'image-url)
(while (get-text-property (point) 'image-url) (point-max)))
(forward-char -1)) (start (or (previous-single-property-change end 'image-url)
(forward-char 1) (point-min)))
(let ((start (point))) (size (get-text-property (point) 'image-size))
(while (get-text-property (point) 'image-url) (next-size (cond ((or (eq size 'default)
(forward-char 1)) (null size))
(forward-char -1) 'original)
(put-text-property start (point) 'display nil) ((eq size 'original)
(when (> (- (point) start) 2) 'full)
(delete-region start (1- (point))))) ((eq size 'full)
(message "Inserting %s..." url) 'default)))
(url-retrieve url #'shr-image-fetched (buffer-read-only nil))
(list (current-buffer) (1- (point)) (point-marker) ;; Delete the old picture.
(list (cons 'size (put-text-property start end 'display nil)
(cond ((or (eq size 'default) (message "Inserting %s..." url)
(null size)) (url-retrieve url #'shr-image-fetched
'original) `(,(current-buffer) ,start
((eq size 'original) ,(set-marker (make-marker) end)
'full) ((size . ,next-size)))
((eq size 'full) t)))))
'default)))))
t))))
;;; Utility functions. ;;; Utility functions.
@ -1070,6 +1074,7 @@ the mouse click event."
;; We don't want to record these changes. ;; We don't want to record these changes.
(buffer-undo-list t) (buffer-undo-list t)
(inhibit-read-only t)) (inhibit-read-only t))
(remove-overlays start end)
(delete-region start end) (delete-region start end)
(goto-char start) (goto-char start)
(funcall shr-put-image-function data alt flags) (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. ;; putting any space after inline images.
;; ALT may be nil when visiting image URLs in eww ;; ALT may be nil when visiting image URLs in eww
;; (bug#67764). ;; (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 ;; When inserting big-ish pictures, put them at the
;; beginning of the line. ;; beginning of the line.
(let ((inline (shr--inline-image-p image))) (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")) (insert "\n"))
(let ((image-pos (point))) (let ((image-pos (point)))
(if (eq size 'original) (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)) (insert-image image alt))
(put-text-property start (point) 'image-size size) (put-text-property start (point) 'image-size size)
(when (and (not inline) shr-max-inline-image-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))) (let ((file (url-cache-create-filename url)))
(when (file-exists-p file) (when (file-exists-p file)
(delete-file file)))) (delete-file file))))
(when (image-type-available-p 'svg) (if (image-type-available-p 'svg)
(insert-image (insert-image
(shr-make-placeholder-image dom) (shr-make-placeholder-image dom)
(or (string-trim alt) ""))) (or (string-trim alt) ""))
;; Paradoxically this space causes shr not to insert spaces after ;; No SVG support. Just use a space as our placeholder.
;; inline images. Since the image is temporary it seem like there (insert " "))
;; 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 " "))
(url-queue-retrieve (url-queue-retrieve
url #'shr-image-fetched url #'shr-image-fetched
(list (current-buffer) start (set-marker (make-marker) (point)) (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") (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) (defun shr-test--rendering-check (name &optional context)
"Render NAME.html and compare it to NAME.txt. "Render NAME.html and compare it to NAME.txt.
Raise a test failure if the rendered buffer does not match 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 The `rendering' testcase will test NAME once without altering any
settings, then once more for each (OPTION . VALUE) pair.") settings, then once more for each (OPTION . VALUE) pair.")
;;; Tests:
(ert-deftest rendering () (ert-deftest rendering ()
(skip-unless (fboundp 'libxml-parse-html-region)) (skip-unless (fboundp 'libxml-parse-html-region))
(dolist (file (directory-files (ert-resource-directory) nil "\\.html\\'")) (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 ") (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))))) '(("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) (require 'shr)
;;; shr-tests.el ends here ;;; shr-tests.el ends here