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 fe061adae295490bfe23c9b9dad3cf30837432e7..7e9a8c6d1c0208b6e186c079a5b63244f289e893 100644 (file)
--- 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 cc258552819663656b6489367be7b90f3bb3d189..1980a437b9b5e69320ba5d2b00dc20f6f8a22f05 100644 (file)
--- 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)