master 208207c1c07 3/4: Fix the different image zoom levels in SHR to work as expected

[Jim Porter]

branch: master
commit 208207c1c07fb4669c6b7d64c27236074f996ae4
Author: Jim Porter <jporterbugs@gmail.com>
Commit: Jim Porter <jporterbugs@gmail.com>

    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 3e74d724f48..1af252e8a8f 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -54,6 +54,11 @@ matter how large or small that was).  Now, SHR slices any 
images taller
 than 'shr-sliced-image-height'.  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'.
+
 
 * New Modes and Packages in Emacs 31.1
 
diff --git a/lisp/net/shr.el b/lisp/net/shr.el
index 7e9a8c6d1c0..8b62691bfb6 100644
--- a/lisp/net/shr.el
+++ b/lisp/net/shr.el
@@ -219,6 +219,25 @@ interpreted as a multiple of the height of default font."
   :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 @@ the URL of the image to the kill buffer instead."
                    (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 @@ You can specify the following optional properties:
 * `: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 @@ You can specify the following optional properties:
                                (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 @@ width/height instead."
                                     (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))