From: Jim Porter <jporterbugs@gmail.com>
Date: Sun, 23 Jun 2024 19:25:25 +0000 (-0700)
Subject: In SHR, keep track of image sizes as specified by the HTML
X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=d81d96592a624206bd830d26ccc099192de0cb4c;p=emacs.git

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".

(cherry picked from commit 6d082f3c79269f00308d6e8b7d31d6a119376fe2)
---

diff --git a/lisp/net/shr.el b/lisp/net/shr.el
index fe061adae29..7e9a8c6d1c0 100644
--- a/lisp/net/shr.el
+++ b/lisp/net/shr.el
@@ -633,13 +633,14 @@ full-buffer size."
                       (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 @@ full-buffer size."
         (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 @@ the mouse click event."
 		  (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 @@ the mouse click event."
 (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 @@ element is the data blob and the second element is the content-type."
 				(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 @@ element is the data blob and the second element is the content-type."
                       ;; 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 @@ The preference is a float determined from `shr-prefer-media-type'."
 	  (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 cc258552819..1980a437b9b 100644
--- a/test/lisp/net/shr-tests.el
+++ b/test/lisp/net/shr-tests.el
@@ -173,14 +173,14 @@ settings, then once more for each (OPTION . VALUE) pair.")
             (shr-test-wait-for (lambda () (= put-image-calls 2))
                                "Timed out waiting to zoom image")
             ;; 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)