* bug#71666: 30.0.50; [PATCH] Fix zooming images with SHR
@ 2024-06-20 4:47 Jim Porter
2024-06-22 9:11 ` Eli Zaretskii
0 siblings, 1 reply; 12+ messages in thread
From: Jim Porter @ 2024-06-20 4:47 UTC (permalink / raw)
To: 71666
[-- Attachment #1: Type: text/plain, Size: 367 bytes --]
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.
[-- Attachment #2: 0001-Fix-zooming-images-in-SHR.patch --]
[-- Type: text/plain, Size: 10838 bytes --]
From 09e25981700a34001e3edcab6f8cc3eb0a715d12 Mon Sep 17 00:00:00 2001
From: Jim Porter <jporterbugs@gmail.com>
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
^ permalink raw reply related [flat|nested] 12+ messages in thread
* bug#71666: 30.0.50; [PATCH] Fix zooming images with SHR
2024-06-20 4:47 bug#71666: 30.0.50; [PATCH] Fix zooming images with SHR Jim Porter
@ 2024-06-22 9:11 ` Eli Zaretskii
2024-06-22 20:21 ` Jim Porter
0 siblings, 1 reply; 12+ messages in thread
From: Eli Zaretskii @ 2024-06-22 9:11 UTC (permalink / raw)
To: Jim Porter; +Cc: 71666
> Date: Wed, 19 Jun 2024 21:47:26 -0700
> From: Jim Porter <jporterbugs@gmail.com>
>
> 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.
I tried the recipe and the patch. While the patches shr behaves
better than the unpatched, I don't see the image being zoomed, it
stays at its original size. Do I need some optional library or
external program for the zoom to happen?
Thanks.
^ permalink raw reply [flat|nested] 12+ messages in thread
* bug#71666: 30.0.50; [PATCH] Fix zooming images with SHR
2024-06-22 9:11 ` Eli Zaretskii
@ 2024-06-22 20:21 ` Jim Porter
2024-06-22 23:04 ` Jim Porter
2024-06-23 4:44 ` Eli Zaretskii
0 siblings, 2 replies; 12+ messages in thread
From: Jim Porter @ 2024-06-22 20:21 UTC (permalink / raw)
To: Eli Zaretskii; +Cc: 71666
On 6/22/2024 2:11 AM, Eli Zaretskii wrote:
> I tried the recipe and the patch. While the patches shr behaves
> better than the unpatched, I don't see the image being zoomed, it
> stays at its original size. Do I need some optional library or
> external program for the zoom to happen?
Ah right, that would have been helpful for me to mention in the original
message: by default, SHR scales down images that are more than 70% of
the width (or height) of the window. So if you narrow your window to 40
columns or so and reload the page in EWW, the larger images should be
scaled down. Then putting point on one and pressing "z" should scale it
up to the original size. Pressing "z" again should scale the image back
down.
As an aside, there are actually *three* states for image scaling in SHR:
default, original, and full, and 'shr-zoom-image' cycles through them in
that order. As far as I can tell from the code, "default" and "full" are
the same though. I haven't figured out whether that's a bug (and if so,
what the bug is), or whether I'm just misunderstanding something. I'll
try to fix that later (if only by adding documentation), once I know
what's going on.
^ permalink raw reply [flat|nested] 12+ messages in thread
* bug#71666: 30.0.50; [PATCH] Fix zooming images with SHR
2024-06-22 20:21 ` Jim Porter
@ 2024-06-22 23:04 ` Jim Porter
2024-06-23 4:44 ` Eli Zaretskii
1 sibling, 0 replies; 12+ messages in thread
From: Jim Porter @ 2024-06-22 23:04 UTC (permalink / raw)
To: Eli Zaretskii; +Cc: 71666
[-- Attachment #1: Type: text/plain, Size: 55 bytes --]
Here's an improved patch with a better regression test.
[-- Attachment #2: 0001-Fix-zooming-images-in-SHR.patch --]
[-- Type: text/plain, Size: 11077 bytes --]
From 3c7d28b594883f5d939f5ac251c73750c80db927 Mon Sep 17 00:00:00 2001
From: Jim Porter <jporterbugs@gmail.com>
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 (bug#71666).
* 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 | 62 ++++++++++++++++++++++++
2 files changed, 113 insertions(+), 47 deletions(-)
diff --git a/lisp/net/shr.el b/lisp/net/shr.el
index 14b3f7aa163..e0e19a5f058 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 image 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..b2ece3049a1 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,50 @@ 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)))
+ ;; 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 pos))
+ ;; Make sure we actually saw a slice.
+ (should (> slice-count 1)))))))))
+
(require 'shr)
;;; shr-tests.el ends here
--
2.25.1
^ permalink raw reply related [flat|nested] 12+ messages in thread
* bug#71666: 30.0.50; [PATCH] Fix zooming images with SHR
2024-06-22 20:21 ` Jim Porter
2024-06-22 23:04 ` Jim Porter
@ 2024-06-23 4:44 ` Eli Zaretskii
2024-06-23 6:14 ` Jim Porter
1 sibling, 1 reply; 12+ messages in thread
From: Eli Zaretskii @ 2024-06-23 4:44 UTC (permalink / raw)
To: Jim Porter; +Cc: 71666
> Date: Sat, 22 Jun 2024 13:21:53 -0700
> Cc: 71666@debbugs.gnu.org
> From: Jim Porter <jporterbugs@gmail.com>
>
> On 6/22/2024 2:11 AM, Eli Zaretskii wrote:
> > I tried the recipe and the patch. While the patches shr behaves
> > better than the unpatched, I don't see the image being zoomed, it
> > stays at its original size. Do I need some optional library or
> > external program for the zoom to happen?
>
> Ah right, that would have been helpful for me to mention in the original
> message: by default, SHR scales down images that are more than 70% of
> the width (or height) of the window. So if you narrow your window to 40
> columns or so and reload the page in EWW, the larger images should be
> scaled down. Then putting point on one and pressing "z" should scale it
> up to the original size. Pressing "z" again should scale the image back
> down.
OK, then feel free to install, and thanks.
> As an aside, there are actually *three* states for image scaling in SHR:
> default, original, and full, and 'shr-zoom-image' cycles through them in
> that order. As far as I can tell from the code, "default" and "full" are
> the same though. I haven't figured out whether that's a bug (and if so,
> what the bug is), or whether I'm just misunderstanding something. I'll
> try to fix that later (if only by adding documentation), once I know
> what's going on.
I must say this kind of dwim-ish operation that looks like no-op in
too many "normal" cases looks very strange to me. How does it make
sense to have features that only appear to do something in rare cases?
Doesn't that cause user bewilderment (like I was surprised above), and
cause users to think we have a bug? Should we perhaps adjust the
heuristics and its parameters to make this not no-op in more cases?
Or at least show a message in echo area explaining why the image was
not zoomed-in when we decide not to? For example, in the case above,
why would it not make sense to enlarge the image when the user presses
'z' even if it was not scaled down initially? Doesn't principle of
least surprise count anymore?
^ permalink raw reply [flat|nested] 12+ messages in thread
* bug#71666: 30.0.50; [PATCH] Fix zooming images with SHR
2024-06-23 4:44 ` Eli Zaretskii
@ 2024-06-23 6:14 ` Jim Porter
2024-06-23 22:24 ` Jim Porter
0 siblings, 1 reply; 12+ messages in thread
From: Jim Porter @ 2024-06-23 6:14 UTC (permalink / raw)
To: Eli Zaretskii; +Cc: 71666
On 6/22/2024 9:44 PM, Eli Zaretskii wrote:
> OK, then feel free to install, and thanks.
Thanks. Merged to the master branch as 5f9b5803bea.
I made one small improvement to the code to use overlays for preventing
image slices from being underlined. That makes the code a bit cleaner,
and should make future improvements in this area easier.
> I must say this kind of dwim-ish operation that looks like no-op in
> too many "normal" cases looks very strange to me. How does it make
> sense to have features that only appear to do something in rare cases?
> Doesn't that cause user bewilderment (like I was surprised above), and
> cause users to think we have a bug? Should we perhaps adjust the
> heuristics and its parameters to make this not no-op in more cases?
> Or at least show a message in echo area explaining why the image was
> not zoomed-in when we decide not to? For example, in the case above,
> why would it not make sense to enlarge the image when the user presses
> 'z' even if it was not scaled down initially? Doesn't principle of
> least surprise count anymore?
I agree completely, and I'm working on a patch to that effect. :)
I think the problem you mention is a combination of some bugs I'm
working on fixing now, and like you say, 'shr-zoom-image' not providing
enough feedback about what's happening. It just says it's fetching the
image (this is also probably a bug; why fetch the image from the web
when we're just resizing it?).
Since I'm most of the way done with this additional patch, I'll leave
this bug open for now.
^ permalink raw reply [flat|nested] 12+ messages in thread
* bug#71666: 30.0.50; [PATCH] Fix zooming images with SHR
2024-06-23 6:14 ` Jim Porter
@ 2024-06-23 22:24 ` Jim Porter
2024-06-29 1:41 ` Jim Porter
0 siblings, 1 reply; 12+ messages in thread
From: Jim Porter @ 2024-06-23 22:24 UTC (permalink / raw)
To: Eli Zaretskii; +Cc: 71666
[-- Attachment #1: Type: text/plain, Size: 2136 bytes --]
On 6/22/2024 11:14 PM, Jim Porter wrote:
> I agree completely, and I'm working on a patch to that effect. :)
>
> I think the problem you mention is a combination of some bugs I'm
> working on fixing now, and like you say, 'shr-zoom-image' not providing
> enough feedback about what's happening. It just says it's fetching the
> image (this is also probably a bug; why fetch the image from the web
> when we're just resizing it?).
>
> Since I'm most of the way done with this additional patch, I'll leave
> this bug open for now.
This ended up fairly complex, so I've split the patch into sub-parts to
(I hope) make the changes easier to follow. There are four distinct, but
related, improvements here:
1. Previously, SHR sliced images whenever you requested "original" zoom.
But it would really be useful to slice images based on the size they'll
be displayed at: a tiny image at "original" zoom doesn't need sliced,
but a tall image at default zoom would benefit from slicing. So now SHR
checks the height of the image to determine when to slice (you can also
turn off slicing entirely, since you don't need it if you use
'pixel-scroll-precision-mode').
2. When zooming, SHR lost track of the width and height of the image
specified in the HTML like <img src="..." width="M" height="N">. I fixed
that, and also cleaned up a bit of the code where we had a list that was
simultaneously an alist and a plist (I converted it to a plist since
more code used that form).
3. After much archaeology through old Gnus commits, I think I understand
what each zoom level does, so I've fixed them. I've also added a new
zoom level that zooms to the image's default size, ignoring HTML
attributes. That's how the default and "full" zoom levels worked before
my fix, so if someone wants the old behavior (I'd probably use it),
there it is. I also made 'shr-zoom-image' display a message telling
users the new zoom level.
4. Finally, every time you called 'shr-zoom-image', it would reload the
image from the web. That shouldn't be necessary since there's a local
cache. Now we use the cache when possible; easy enough.
[-- Attachment #2: 0001-Slice-images-based-on-their-height-in-SHR-not-their-.patch --]
[-- Type: text/plain, Size: 6709 bytes --]
From 9ccc5c3f5767cc4939869d1116d8fc650a817756 Mon Sep 17 00:00:00 2001
From: Jim Porter <jporterbugs@gmail.com>
Date: Sun, 23 Jun 2024 12:18:57 -0700
Subject: [PATCH 1/4] Slice images based on their height in SHR, not their zoom
level
* lisp/net/shr.el (shr-sliced-image-proportion): New option...
(shr-put-image): ... use it. Compute the number of slices in relation
to the image height; this way, each slice is roughly the height of a
line of ordinary text.
* test/lisp/net/shr-tests.el (shr-test/zoom-image): Update test, since
zooming no longer necessarily triggers slicing.
* doc/misc/eww.texi (Advanced): Document 'shr-sliced-image-proportion'.
* etc/NEWS: Announce this change.
---
doc/misc/eww.texi | 9 +++++++++
etc/NEWS | 11 +++++++++++
lisp/net/shr.el | 28 +++++++++++++++++++++++++---
test/lisp/net/shr-tests.el | 15 ++++++---------
4 files changed, 51 insertions(+), 12 deletions(-)
diff --git a/doc/misc/eww.texi b/doc/misc/eww.texi
index eec6b3c3299..5ae10b3f7b7 100644
--- a/doc/misc/eww.texi
+++ b/doc/misc/eww.texi
@@ -373,6 +373,15 @@ Advanced
@code{shr-inhibit-images}. If this variable is @code{nil}, display
the ``ALT'' text of images instead.
+@vindex shr-sliced-image-proportion
+ To make scrolling up/down past images more intuititve, EWW splits
+large images into several rows. This way, you can scroll individually
+past each slice, instead of jumping past the entire image. EWW slices
+images that take up more than @code{shr-sliced-image-proportion} of the
+height of the window they are displayed in. For example, a value of 0.7
+means that images are allowed to take up 70% of the height of the window
+before being sliced.
+
@vindex shr-color-visible-distance-min
@vindex shr-color-visible-luminance-min
@cindex Contrast
diff --git a/etc/NEWS b/etc/NEWS
index af32a93d9c4..3f4969da873 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -36,6 +36,17 @@ applies, and please also update docstrings as needed.
\f
* Changes in Specialized Modes and Packages in Emacs 31.1
+** SHR
+
++++
+*** SHR now slices large images into rows by default.
+Sliced images allow for more intuitive scrolling up/down by letting you
+scroll past each slice, instead of jumping past the entire image.
+Previously, SHR only sliced images when zoomed to their original size.
+You can set the maximum size for unsliced images with the option
+'shr-sliced-image-proportion'. For more information, see the "(eww)
+Advanced" node in the EWW manual.
+
\f
* New Modes and Packages in Emacs 31.1
diff --git a/lisp/net/shr.el b/lisp/net/shr.el
index 3dadcb9a09b..515768e035f 100644
--- a/lisp/net/shr.el
+++ b/lisp/net/shr.el
@@ -58,6 +58,20 @@ shr-max-image-proportion
:version "24.1"
:type 'float)
+(defcustom shr-sliced-image-proportion 0.3
+ "How tall images can be before slicing in relation to the window they're in.
+A value of 0.7 means that images are allowed to take up 70% of the
+height of the window before being sliced by `insert-sliced-image'. If
+nil, never slice images.
+
+Sliced images allow for more intuitive scrolling up/down by letting you
+scroll past each slice, instead of jumping past the entire image.
+Alternately, you can use `pixel-scroll-precision-mode' to scroll
+pixel-wise past images, in which case you can set this option to nil."
+ :version "31.1"
+ :type '(choice (const :tag "Never slice images")
+ float))
+
(defcustom shr-allowed-images nil
"If non-nil, only images that match this regexp are displayed.
If nil, all URLs are allowed. Also see `shr-blocked-images'."
@@ -1157,14 +1171,22 @@ shr-put-image
(when (and (> (current-column) 0)
(not inline))
(insert "\n"))
- (let ((image-pos (point)))
- (if (eq size 'original)
+ (let ((image-pos (point))
+ image-height body-height)
+ (if (and shr-sliced-image-proportion
+ (setq image-height (cdr (image-size image t))
+ body-height (window-body-height
+ (get-buffer-window (current-buffer))
+ t))
+ (> (/ image-height body-height 1.0)
+ shr-sliced-image-proportion))
;; 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)
+ (insert-sliced-image
+ image "*" nil (/ image-height (default-line-height)) 1)
(let ((overlay (make-overlay start (point))))
;; Avoid displaying unsightly decorations on the
;; image slices.
diff --git a/test/lisp/net/shr-tests.el b/test/lisp/net/shr-tests.el
index b6552674b27..701e73dc4fe 100644
--- a/test/lisp/net/shr-tests.el
+++ b/test/lisp/net/shr-tests.el
@@ -154,6 +154,7 @@ shr-test/zoom-image
(shr-width 80)
(shr-use-fonts nil)
(shr-image-animate nil)
+ (shr-sliced-image-proportion nil)
(inhibit-message t)
(dom (libxml-parse-html-region (point-min) (point-max))))
;; Render the document.
@@ -164,19 +165,15 @@ shr-test/zoom-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))
+ ;; Check that we have a single image at original size.
+ (let (image-sizes)
(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))
+ (when (get-text-property (point) 'display)
+ (push (get-text-property (point) 'image-size) image-sizes))
(goto-char (or (next-single-property-change (point) 'display)
(point-max))))
- ;; Make sure we actually saw a slice.
- (should (> slice-count 1)))))))))
+ (should (equal image-sizes '(original))))))))))
(require 'shr)
--
2.25.1
[-- Attachment #3: 0002-In-SHR-keep-track-of-image-sizes-as-specified-by-the.patch --]
[-- Type: text/plain, Size: 6100 bytes --]
From f14c591efdedf312c0e1ed6527ba0fdd4593d26d Mon Sep 17 00:00:00 2001
From: Jim Porter <jporterbugs@gmail.com>
Date: Sun, 23 Jun 2024 12:25:25 -0700
Subject: [PATCH 2/4] In SHR, keep track of image sizes as specified by the
HTML
Previously, these values got lost when zooming the image.
* lisp/net/shr.el (shr-tag-img): Set 'image-dom-size'...
(shr-zoom-image): ... use it. Rename 'size' to 'zoom'.
(shr-image-fetched): Rename 'image-size' to 'image-zoom'.
(shr-put-image): Accept the zoom level as ':zoom' and document it.
Previously, FLAGS was a mix of alist and plist(!).
* test/lisp/net/shr-tests.el (shr-test/zoom-image): Rename "size" to
"zoom".
---
lisp/net/shr.el | 38 ++++++++++++++++++++++++++------------
test/lisp/net/shr-tests.el | 6 +++---
2 files changed, 29 insertions(+), 15 deletions(-)
diff --git a/lisp/net/shr.el b/lisp/net/shr.el
index 515768e035f..af871d7096e 100644
--- a/lisp/net/shr.el
+++ b/lisp/net/shr.el
@@ -633,13 +633,14 @@ shr-zoom-image
(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))
+ (dom-size (get-text-property (point) 'image-dom-size))
+ (zoom (get-text-property (point) 'image-zoom))
+ (next-zoom (cond ((or (eq zoom 'default)
+ (null zoom))
'original)
- ((eq size 'original)
+ ((eq zoom 'original)
'full)
- ((eq size 'full)
+ ((eq zoom 'full)
'default)))
(buffer-read-only nil))
;; Delete the old picture.
@@ -648,7 +649,9 @@ shr-zoom-image
(url-retrieve url #'shr-image-fetched
`(,(current-buffer) ,start
,(set-marker (make-marker) end)
- ((size . ,next-size)))
+ (:zoom ,next-zoom
+ :width ,(car dom-size)
+ :height ,(cdr dom-size)))
t)))))
;;; Utility functions.
@@ -1095,7 +1098,7 @@ shr-image-fetched
(while properties
(let ((type (pop properties))
(value (pop properties)))
- (unless (memq type '(display image-size))
+ (unless (memq type '(display image-zoom))
(put-text-property start (point) type value)))))))))))
(kill-buffer image-buffer)))
@@ -1132,9 +1135,19 @@ shr--inline-image-p
(defun shr-put-image (spec alt &optional flags)
"Insert image SPEC with a string ALT. Return image.
SPEC is either an image data blob, or a list where the first
-element is the data blob and the second element is the content-type."
+element is the data blob and the second element is the content-type.
+
+FLAGS is a property list specifying optional parameters for the image.
+You can specify the following optional properties:
+
+* `:zoom': The zoom level for the image. One of `default', `original',
+ or `full'.
+* `:width': The width of the image as specified by the HTML \"width\"
+ attribute.
+* `:height': The height of the image as specified by the HTML
+ \"height\" attribute."
(if (display-graphic-p)
- (let* ((size (cdr (assq 'size flags)))
+ (let* ((zoom (plist-get flags :zoom))
(data (if (consp spec)
(car spec)
spec))
@@ -1142,13 +1155,13 @@ shr-put-image
(cadr spec)))
(start (point))
(image (cond
- ((eq size 'original)
+ ((eq zoom 'original)
(create-image data nil t :ascent shr-image-ascent
:format content-type))
((eq content-type 'image/svg+xml)
(when (image-type-available-p 'svg)
(create-image data 'svg t :ascent shr-image-ascent)))
- ((eq size 'full)
+ ((eq zoom 'full)
(ignore-errors
(shr-rescale-image data content-type
(plist-get flags :width)
@@ -1192,7 +1205,7 @@ shr-put-image
;; image slices.
(overlay-put overlay 'face 'shr-sliced-image)))
(insert-image image alt))
- (put-text-property start (point) 'image-size size)
+ (put-text-property start (point) 'image-zoom zoom)
(when (and (not inline) shr-max-inline-image-size)
(insert "\n"))
(when (and shr-image-animate
@@ -1907,6 +1920,7 @@ shr-tag-img
(put-text-property start (point) 'keymap shr-image-map)
(put-text-property start (point) 'shr-alt alt)
(put-text-property start (point) 'image-url url)
+ (put-text-property start (point) 'image-dom-size (cons width height))
(put-text-property start (point) 'image-displayer
(shr-image-displayer shr-content-function))
(put-text-property start (point) 'help-echo
diff --git a/test/lisp/net/shr-tests.el b/test/lisp/net/shr-tests.el
index 701e73dc4fe..542e940a4b9 100644
--- a/test/lisp/net/shr-tests.el
+++ b/test/lisp/net/shr-tests.el
@@ -166,14 +166,14 @@ shr-test/zoom-image
(shr-zoom-image)
(shr-test-wait-for (lambda () (= put-image-calls 2)))
;; Check that we have a single image at original size.
- (let (image-sizes)
+ (let (image-zooms)
(goto-char (point-min))
(while (< (point) (point-max))
(when (get-text-property (point) 'display)
- (push (get-text-property (point) 'image-size) image-sizes))
+ (push (get-text-property (point) 'image-zoom) image-zooms))
(goto-char (or (next-single-property-change (point) 'display)
(point-max))))
- (should (equal image-sizes '(original))))))))))
+ (should (equal image-zooms '(original))))))))))
(require 'shr)
--
2.25.1
[-- Attachment #4: 0003-Fix-the-different-image-zoom-levels-in-SHR-to-work-a.patch --]
[-- Type: text/plain, Size: 9958 bytes --]
From 0767dce5b931f653e1d742c1b1b7c2575c8d9e42 Mon Sep 17 00:00:00 2001
From: Jim Porter <jporterbugs@gmail.com>
Date: Sun, 23 Jun 2024 14:48:32 -0700
Subject: [PATCH 3/4] Fix the different image zoom levels in SHR to work as
expected
* lisp/net/shr.el (shr-image-zoom-levels): New option.
(shr-image-zoom-level-alist): New variable.
(shr-zoom-image): Take POSITION and ZOOM-LEVEL arguments. Consult
'shr-image-zoom-levels'.
(shr-put-image): Use 'shr-image-zoom-level-alist'.
(shr-rescale-image): Only reset width *or* height when either is too
large.
(shr--image-zoom-original-size, shr--image-zoom-image-size)
(shr--image-zoom-fill-height): New functions.
* etc/NEWS: Announce this change.
---
etc/NEWS | 5 ++
lisp/net/shr.el | 139 ++++++++++++++++++++++++++++++------------------
2 files changed, 93 insertions(+), 51 deletions(-)
diff --git a/etc/NEWS b/etc/NEWS
index 3f4969da873..7bfb1379574 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -47,6 +47,11 @@ You can set the maximum size for unsliced images with the option
'shr-sliced-image-proportion'. For more information, see the "(eww)
Advanced" node in the EWW manual.
+---
+*** You can now customize the image zoom levels to cycle through.
+By customizing 'shr-image-zoom-levels', you can change the list of zoom
+levels that SHR cycles through when calling 'shr-zoom-image'.
+
\f
* New Modes and Packages in Emacs 31.1
diff --git a/lisp/net/shr.el b/lisp/net/shr.el
index af871d7096e..59dd2c032ed 100644
--- a/lisp/net/shr.el
+++ b/lisp/net/shr.el
@@ -219,6 +219,25 @@ shr-max-inline-image-size
:version "30.1"
:type '(choice (const nil) (cons number number)))
+(defcustom shr-image-zoom-levels '(fit original fill-height)
+ "A list of image zoom levels to cycle through with `shr-zoom-image'.
+The first element in the list is the initial zoom level. Each element
+can be one of the following symbols:
+
+* `fit': Display the image at its original size as requested by the
+ page, shrinking it to fit in the current window if necessary.
+* `original': Display the image at its original size as requested by the
+ page.
+* `image': Display the image at its full size (ignoring the width/height
+ specified by the HTML).
+* `fill-height': Display the image zoomed to fill the height of the
+current window."
+ :version "31.1"
+ :type '(set (choice (const :tag "Fit to window size" fit)
+ (const :tag "Original size" original)
+ (const :tag "Full image size" image)
+ (const :tag "Fill window height" fill-height))))
+
(defvar shr-content-function nil
"If bound, this should be a function that will return the content.
This is used for cid: URLs, and the function is called with the
@@ -621,35 +640,52 @@ shr-insert-image
(list (current-buffer) (1- (point)) (point-marker))
t))))
-(defun shr-zoom-image ()
- "Cycle the image size.
+(defvar shr-image-zoom-level-alist
+ `((fit "Zoom to fit" shr-rescale-image)
+ (original "Zoom to original size" shr--image-zoom-original-size)
+ (image "Zoom to full image size" shr--image-zoom-image-size)
+ (fill-height "Zoom to fill window height" shr--image-zoom-fill-height))
+ "An alist of possible image zoom levels.
+Each element is of the form (SYMBOL DESC FUNCTION). SYMBOL is the
+symbol identifying this level, as used by `shr-image-zoom-levels' (which
+see). DESC is a string describing the level.
+
+FUNCTION is a function that returns a properly-zoomed image; it takes
+the following arguments:
+
+* DATA: The image data in string form.
+* CONTENT-TYPE: The content-type of the image, if any.
+* WIDTH: The width as specified by the HTML \"width\" attribute, if any.
+* HEIGHT: The height as specified by the HTML \"height\" attribute, if
+ any.")
+
+(defun shr-zoom-image (&optional position zoom-level)
+ "Change the zoom level of the image at POSITION.
+
The size will cycle through the default size, the original size, and
full-buffer size."
- (interactive)
- (let ((url (get-text-property (point) 'image-url)))
+ (interactive "d")
+ (unless position (setq position (point)))
+ (let ((url (get-text-property position 'image-url)))
(if (not url)
(message "No image under point")
- (let* ((end (or (next-single-property-change (point) 'image-url)
+ (unless zoom-level
+ (let ((last-zoom (get-text-property position 'image-zoom)))
+ (setq zoom-level (or (cadr (memq last-zoom shr-image-zoom-levels))
+ (car shr-image-zoom-levels)))))
+ (let* ((end (or (next-single-property-change position 'image-url)
(point-max)))
(start (or (previous-single-property-change end 'image-url)
(point-min)))
- (dom-size (get-text-property (point) 'image-dom-size))
- (zoom (get-text-property (point) 'image-zoom))
- (next-zoom (cond ((or (eq zoom 'default)
- (null zoom))
- 'original)
- ((eq zoom 'original)
- 'full)
- ((eq zoom 'full)
- 'default)))
+ (dom-size (get-text-property position 'image-dom-size))
(buffer-read-only nil))
;; Delete the old picture.
(put-text-property start end 'display nil)
- (message "Inserting %s..." url)
+ (message "%s" (cadr (assq zoom-level shr-image-zoom-level-alist)))
(url-retrieve url #'shr-image-fetched
`(,(current-buffer) ,start
,(set-marker (make-marker) end)
- (:zoom ,next-zoom
+ (:zoom ,zoom-level
:width ,(car dom-size)
:height ,(cdr dom-size)))
t)))))
@@ -1147,7 +1183,9 @@ shr-put-image
* `:height': The height of the image as specified by the HTML
\"height\" attribute."
(if (display-graphic-p)
- (let* ((zoom (plist-get flags :zoom))
+ (let* ((zoom (or (plist-get flags :zoom)
+ (car shr-image-zoom-levels)))
+ (zoom-function (nth 2 (assq zoom shr-image-zoom-level-alist)))
(data (if (consp spec)
(car spec)
spec))
@@ -1155,22 +1193,15 @@ shr-put-image
(cadr spec)))
(start (point))
(image (cond
- ((eq zoom 'original)
- (create-image data nil t :ascent shr-image-ascent
- :format content-type))
((eq content-type 'image/svg+xml)
(when (image-type-available-p 'svg)
(create-image data 'svg t :ascent shr-image-ascent)))
- ((eq zoom 'full)
- (ignore-errors
- (shr-rescale-image data content-type
- (plist-get flags :width)
- (plist-get flags :height))))
- (t
- (ignore-errors
- (shr-rescale-image data content-type
- (plist-get flags :width)
- (plist-get flags :height)))))))
+ (zoom-function
+ (ignore-errors
+ (funcall zoom-function data content-type
+ (plist-get flags :width)
+ (plist-get flags :height))))
+ (t (error "Unrecognized zoom level %s" zoom)))))
(when image
;; The trailing space can confuse shr-insert into not
;; putting any space after inline images.
@@ -1243,27 +1274,33 @@ shr-rescale-image
(or max-height
(- (nth 3 edges) (nth 1 edges))))))
(scaling (image-compute-scaling-factor image-scaling-factor)))
- (when (or (and width
- (> width max-width))
- (and height
- (> height max-height)))
- (setq width nil
- height nil))
- (if (and width height
- (< (* width scaling) max-width)
- (< (* height scaling) max-height))
- (create-image
- data (shr--image-type) t
- :ascent shr-image-ascent
- :width width
- :height height
- :format content-type)
- (create-image
- data (shr--image-type) t
- :ascent shr-image-ascent
- :max-width max-width
- :max-height max-height
- :format content-type)))))
+ (when (and width (> (* width scaling) max-width))
+ (setq width nil))
+ (when (and height (> (* height scaling) max-height))
+ (setq height nil))
+ (create-image
+ data (shr--image-type) t
+ :ascent shr-image-ascent
+ :width width
+ :height height
+ :max-width max-width
+ :max-height max-height
+ :format content-type))))
+
+(defun shr--image-zoom-original-size (data content-type width height)
+ (create-image data (shr--image-type) t :ascent shr-image-ascent
+ :width width :height height :format content-type))
+
+(defun shr--image-zoom-image-size (data content-type _width _height)
+ (create-image data nil t :ascent shr-image-ascent :format content-type))
+
+(defun shr--image-zoom-fill-height (data content-type _width _height)
+ (let* ((edges (window-inside-pixel-edges
+ (get-buffer-window (current-buffer))))
+ (height (truncate (* shr-max-image-proportion
+ (- (nth 3 edges) (nth 1 edges))))))
+ (create-image data (shr--image-type) t :ascent shr-image-ascent
+ :height height :format content-type)))
;; url-cache-extract autoloads url-cache.
(declare-function url-cache-create-filename "url-cache" (url))
--
2.25.1
[-- Attachment #5: 0004-In-SHR-load-from-URL-cache-if-possible-when-zooming-.patch --]
[-- Type: text/plain, Size: 3890 bytes --]
From d35dd4ac07b46068fd306691c25544c4af7a34d0 Mon Sep 17 00:00:00 2001
From: Jim Porter <jporterbugs@gmail.com>
Date: Sun, 23 Jun 2024 14:53:49 -0700
Subject: [PATCH 4/4] In SHR, load from URL cache if possible when zooming
images
* lisp/net/shr.el (shr-replace-image): New function extracted from...
(shr-image-fetched): ... here.
(shr-zoom-image): Check URL cache and call 'shr-replace-image' if we
can.
---
lisp/net/shr.el | 56 ++++++++++++++++++++++++++++---------------------
1 file changed, 32 insertions(+), 24 deletions(-)
diff --git a/lisp/net/shr.el b/lisp/net/shr.el
index 59dd2c032ed..f01761874bf 100644
--- a/lisp/net/shr.el
+++ b/lisp/net/shr.el
@@ -678,17 +678,22 @@ shr-zoom-image
(start (or (previous-single-property-change end 'image-url)
(point-min)))
(dom-size (get-text-property position 'image-dom-size))
+ (flags `( :zoom ,zoom-level
+ :width ,(car dom-size)
+ :height ,(cdr dom-size)))
(buffer-read-only nil))
;; Delete the old picture.
(put-text-property start end 'display nil)
(message "%s" (cadr (assq zoom-level shr-image-zoom-level-alist)))
- (url-retrieve url #'shr-image-fetched
- `(,(current-buffer) ,start
- ,(set-marker (make-marker) end)
- (:zoom ,zoom-level
- :width ,(car dom-size)
- :height ,(cdr dom-size)))
- t)))))
+ (if (and (not shr-ignore-cache)
+ (url-is-cached url))
+ (shr-replace-image (shr-get-image-data url) start
+ (set-marker (make-marker) end) flags)
+ (url-retrieve url #'shr-image-fetched
+ `(,(current-buffer) ,start
+ ,(set-marker (make-marker) end)
+ ,flags)
+ t))))))
;;; Utility functions.
@@ -1109,6 +1114,25 @@ shr-store-contents
(expand-file-name (file-name-nondirectory url)
directory)))))
+(defun shr-replace-image (data start end &optional flags)
+ (save-excursion
+ (save-restriction
+ (widen)
+ (let ((alt (buffer-substring start end))
+ (properties (text-properties-at start))
+ ;; 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)
+ (while properties
+ (let ((type (pop properties))
+ (value (pop properties)))
+ (unless (memq type '(display image-zoom))
+ (put-text-property start (point) type value))))))))
+
(defun shr-image-fetched (status buffer start end &optional flags)
(let ((image-buffer (current-buffer)))
(when (and (buffer-name buffer)
@@ -1119,23 +1143,7 @@ shr-image-fetched
(search-forward "\r\n\r\n" nil t))
(let ((data (shr-parse-image-data)))
(with-current-buffer buffer
- (save-excursion
- (save-restriction
- (widen)
- (let ((alt (buffer-substring start end))
- (properties (text-properties-at start))
- ;; 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)
- (while properties
- (let ((type (pop properties))
- (value (pop properties)))
- (unless (memq type '(display image-zoom))
- (put-text-property start (point) type value)))))))))))
+ (shr-replace-image data start end flags)))))
(kill-buffer image-buffer)))
(defun shr-image-from-data (data)
--
2.25.1
^ permalink raw reply related [flat|nested] 12+ messages in thread
* bug#71666: 30.0.50; [PATCH] Fix zooming images with SHR
2024-06-23 22:24 ` Jim Porter
@ 2024-06-29 1:41 ` Jim Porter
2024-06-29 3:08 ` Stefan Kangas
0 siblings, 1 reply; 12+ messages in thread
From: Jim Porter @ 2024-06-29 1:41 UTC (permalink / raw)
To: Eli Zaretskii; +Cc: 71666
On 6/23/2024 3:24 PM, Jim Porter wrote:
> This ended up fairly complex, so I've split the patch into sub-parts to
> (I hope) make the changes easier to follow. There are four distinct, but
> related, improvements here:
Assuming there are no comments/concerns, I'll merge this to the master
branch in the next few days.
^ permalink raw reply [flat|nested] 12+ messages in thread
* bug#71666: 30.0.50; [PATCH] Fix zooming images with SHR
2024-06-29 1:41 ` Jim Porter
@ 2024-06-29 3:08 ` Stefan Kangas
2024-06-29 3:31 ` Jim Porter
0 siblings, 1 reply; 12+ messages in thread
From: Stefan Kangas @ 2024-06-29 3:08 UTC (permalink / raw)
To: Jim Porter, Eli Zaretskii; +Cc: 71666
Jim Porter <jporterbugs@gmail.com> writes:
> On 6/23/2024 3:24 PM, Jim Porter wrote:
>> This ended up fairly complex, so I've split the patch into sub-parts to
>> (I hope) make the changes easier to follow. There are four distinct, but
>> related, improvements here:
>
> Assuming there are no comments/concerns, I'll merge this to the master
> branch in the next few days.
This is a regression, right? So should it not go to emacs-30?
^ permalink raw reply [flat|nested] 12+ messages in thread
* bug#71666: 30.0.50; [PATCH] Fix zooming images with SHR
2024-06-29 3:08 ` Stefan Kangas
@ 2024-06-29 3:31 ` Jim Porter
2024-06-29 3:39 ` Stefan Kangas
0 siblings, 1 reply; 12+ messages in thread
From: Jim Porter @ 2024-06-29 3:31 UTC (permalink / raw)
To: Stefan Kangas, Eli Zaretskii; +Cc: 71666
On 6/28/2024 8:08 PM, Stefan Kangas wrote:
> Jim Porter <jporterbugs@gmail.com> writes:
>
>> Assuming there are no comments/concerns, I'll merge this to the master
>> branch in the next few days.
>
> This is a regression, right? So should it not go to emacs-30?
The initial bug report is fixed on emacs-30, but then based on Eli's
message (and some further examination of the code on my part), I found
some more closely-related issues.
One of these issues (#3 - the "full" zoom level didn't zoom to the full
window height) is a regression, but it regressed over a decade ago as
far as I can tell, so I'd lean towards keeping the current behavior on
emacs-30. That way, if I misunderstood what the regression was, we have
plenty of time in the 31 release cycle to address that. (After
searching, I now see that this particular regression was filed
previously as bug#63344.)
The other changes aren't so much regressions as they are long-standing
bugs or limitations of the image-zooming code.
Of course, if you and Eli prefer that I merge some or all of these
patches to the release branch, I don't mind. But they seemed a bit risky
to me.
^ permalink raw reply [flat|nested] 12+ messages in thread
* bug#71666: 30.0.50; [PATCH] Fix zooming images with SHR
2024-06-29 3:31 ` Jim Porter
@ 2024-06-29 3:39 ` Stefan Kangas
2024-07-04 19:18 ` Jim Porter
0 siblings, 1 reply; 12+ messages in thread
From: Stefan Kangas @ 2024-06-29 3:39 UTC (permalink / raw)
To: Jim Porter, Eli Zaretskii; +Cc: 71666
Jim Porter <jporterbugs@gmail.com> writes:
> On 6/28/2024 8:08 PM, Stefan Kangas wrote:
>
>> This is a regression, right? So should it not go to emacs-30?
>
> The initial bug report is fixed on emacs-30, but then based on Eli's
> message (and some further examination of the code on my part), I found
> some more closely-related issues.
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.
^ permalink raw reply [flat|nested] 12+ messages in thread
* bug#71666: 30.0.50; [PATCH] Fix zooming images with SHR
2024-06-29 3:39 ` Stefan Kangas
@ 2024-07-04 19:18 ` Jim Porter
0 siblings, 0 replies; 12+ messages in thread
From: Jim Porter @ 2024-07-04 19:18 UTC (permalink / raw)
To: Stefan Kangas, Eli Zaretskii; +Cc: 71666-done
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.
^ permalink raw reply [flat|nested] 12+ messages in thread
end of thread, other threads:[~2024-07-04 19:18 UTC | newest]
Thread overview: 12+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2024-06-20 4:47 bug#71666: 30.0.50; [PATCH] Fix zooming images with SHR Jim Porter
2024-06-22 9:11 ` Eli Zaretskii
2024-06-22 20:21 ` Jim Porter
2024-06-22 23:04 ` Jim Porter
2024-06-23 4:44 ` Eli Zaretskii
2024-06-23 6:14 ` Jim Porter
2024-06-23 22:24 ` Jim Porter
2024-06-29 1:41 ` Jim Porter
2024-06-29 3:08 ` Stefan Kangas
2024-06-29 3:31 ` Jim Porter
2024-06-29 3:39 ` Stefan Kangas
2024-07-04 19:18 ` Jim Porter
Code repositories for project(s) associated with this external index
https://git.savannah.gnu.org/cgit/emacs.git
https://git.savannah.gnu.org/cgit/emacs/org-mode.git
This is an external index of several public inboxes,
see mirroring instructions on how to clone and mirror
all data and code used by this external index.