X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/52ba24bdd913f6be8318c34b281c7ad727dee6ad..90fb0b2d13d0f44ecb9606587681cb4d8a6f0225:/lisp/net/shr.el

diff --git a/lisp/net/shr.el b/lisp/net/shr.el
index 900b8ec3f5..68972020db 100644
--- a/lisp/net/shr.el
+++ b/lisp/net/shr.el
@@ -36,6 +36,8 @@
 (require 'subr-x)
 (require 'dom)
 (require 'seq)
+(require 'svg)
+(require 'image)
 
 (defgroup shr nil
   "Simple HTML Renderer"
@@ -64,6 +66,12 @@ fit these criteria."
   :group 'shr
   :type 'boolean)
 
+(defcustom shr-use-colors t
+  "If non-nil, respect color specifications in the HTML."
+  :version "25.2"
+  :group 'shr
+  :type 'boolean)
+
 (defcustom shr-table-horizontal-line nil
   "Character used to draw horizontal table lines.
 If nil, don't draw horizontal table lines."
@@ -136,6 +144,14 @@ cid: URL as the argument.")
 (defvar shr-inhibit-images nil
   "If non-nil, inhibit loading images.")
 
+(defvar shr-external-rendering-functions nil
+  "Alist of tag/function pairs used to alter how shr renders certain tags.
+For instance, eww uses this to alter rendering of title, forms
+and other things:
+((title . eww-tag-title)
+ (form . eww-tag-form)
+ ...)")
+
 ;;; Internal variables.
 
 (defvar shr-folding-mode nil)
@@ -151,7 +167,6 @@ cid: URL as the argument.")
 (defvar shr-depth 0)
 (defvar shr-warning nil)
 (defvar shr-ignore-cache nil)
-(defvar shr-external-rendering-functions nil)
 (defvar shr-target-id nil)
 (defvar shr-table-separator-length 1)
 (defvar shr-table-separator-pixel-width 0)
@@ -172,10 +187,16 @@ cid: URL as the argument.")
     (define-key map "w" 'shr-copy-url)
     (define-key map "u" 'shr-copy-url)
     (define-key map "v" 'shr-browse-url)
-    (define-key map "o" 'shr-save-contents)
+    (define-key map "O" 'shr-save-contents)
     (define-key map "\r" 'shr-browse-url)
     map))
 
+(defvar shr-image-map
+  (let ((map (copy-keymap shr-map)))
+    (when (boundp 'image-map)
+      (set-keymap-parent map image-map))
+    map))
+
 ;; Public functions and commands.
 (declare-function libxml-parse-html-region "xml.c"
 		  (start end &optional base-url discard-comments))
@@ -254,22 +275,19 @@ DOM should be a parse tree as generated by
     (set-window-hscroll nil 0)
     (shr-descend dom)
     (shr-fill-lines start (point))
-    (shr-remove-trailing-whitespace start (point))
+    (shr--remove-blank-lines-at-the-end start (point))
     (when shr-warning
       (message "%s" shr-warning))))
 
-(defun shr-remove-trailing-whitespace (start end)
-  (let ((width (window-width)))
-    (save-restriction
+(defun shr--remove-blank-lines-at-the-end (start end)
+  (save-restriction
+    (save-excursion
       (narrow-to-region start end)
-      (goto-char start)
-      (while (not (eobp))
-	(end-of-line)
-	(when (> (shr-previous-newline-padding-width (current-column)) width)
-	  (dolist (overlay (overlays-at (point)))
-	    (when (overlay-get overlay 'before-string)
-	      (overlay-put overlay 'before-string nil))))
-	(forward-line 1)))))
+      (goto-char end)
+      (when (and (re-search-backward "[^ \n]" nil t)
+                 (not (eobp)))
+        (forward-line 1)
+        (delete-region (point) (point-max))))))
 
 (defun shr-copy-url (&optional image-url)
   "Copy the URL under point to the kill ring.
@@ -279,8 +297,10 @@ image under point instead.
 If called twice, then try to fetch the URL and see whether it
 redirects somewhere else."
   (interactive "P")
-  (let ((url (or (get-text-property (point) 'shr-url)
-		 (get-text-property (point) 'image-url))))
+  (let ((url (if image-url
+                 (get-text-property (point) 'image-url)
+               (or (get-text-property (point) 'shr-url)
+                   (get-text-property (point) 'image-url)))))
     (cond
      ((not url)
       (message "No URL under point"))
@@ -435,11 +455,10 @@ size, and full-buffer size."
 
 (defun shr-descend (dom)
   (let ((function
-	 (or
-	  ;; Allow other packages to override (or provide) rendering
-	  ;; of elements.
-	  (cdr (assq (dom-tag dom) shr-external-rendering-functions))
-	  (intern (concat "shr-tag-" (symbol-name (dom-tag dom))) obarray)))
+         (intern (concat "shr-tag-" (symbol-name (dom-tag dom))) obarray))
+        ;; Allow other packages to override (or provide) rendering
+        ;; of elements.
+        (external (cdr (assq (dom-tag dom) shr-external-rendering-functions)))
 	(style (dom-attr dom 'style))
 	(shr-stylesheet shr-stylesheet)
 	(shr-depth (1+ shr-depth))
@@ -454,9 +473,12 @@ size, and full-buffer size."
 	  (setq style nil)))
       ;; If we have a display:none, then just ignore this part of the DOM.
       (unless (equal (cdr (assq 'display shr-stylesheet)) "none")
-	(if (fboundp function)
-	    (funcall function dom)
-	  (shr-generic dom))
+        (cond (external
+               (funcall external dom))
+              ((fboundp function)
+               (funcall function dom))
+              (t
+               (shr-generic dom)))
 	(when (and shr-target-id
 		   (equal (dom-attr dom 'id) shr-target-id))
 	  ;; If the element was empty, we don't have anything to put the
@@ -535,6 +557,16 @@ size, and full-buffer size."
       (insert string)
       (shr-pixel-column))))
 
+(defsubst shr--translate-insertion-chars ()
+  ;; Remove soft hyphens.
+  (goto-char (point-min))
+  (while (search-forward "­" nil t)
+    (replace-match "" t t))
+  ;; Translate non-breaking spaces into real spaces.
+  (goto-char (point-min))
+  (while (search-forward " " nil t)
+    (replace-match " " t t)))
+
 (defun shr-insert (text)
   (when (and (not (bolp))
 	     (get-text-property (1- (point)) 'image-url))
@@ -545,14 +577,11 @@ size, and full-buffer size."
       (insert text)
       (save-restriction
 	(narrow-to-region start (point))
-	;; Remove soft hyphens.
-	(goto-char (point-min))
-	(while (search-forward "­" nil t)
-	  (replace-match "" t t))
+        (shr--translate-insertion-chars)
 	(goto-char (point-max)))))
    (t
     (let ((font-start (point)))
-      (when (and (string-match "\\`[ \t\n\r ]" text)
+      (when (and (string-match "\\`[ \t\n\r]" text)
 		 (not (bolp))
 		 (not (eq (char-after (1- (point))) ? )))
 	(insert " "))
@@ -562,14 +591,11 @@ size, and full-buffer size."
 	(save-restriction
 	  (narrow-to-region start (point))
 	  (goto-char start)
-	  (when (looking-at "[ \t\n\r ]+")
+	  (when (looking-at "[ \t\n\r]+")
 	    (replace-match "" t t))
-	  (while (re-search-forward "[ \t\n\r ]+" nil t)
+	  (while (re-search-forward "[ \t\n\r]+" nil t)
 	    (replace-match " " t t))
-	  ;; Remove soft hyphens.
-	  (goto-char (point-min))
-	  (while (search-forward "­" nil t)
-	    (replace-match "" t t))
+          (shr--translate-insertion-chars)
 	  (goto-char (point-max)))
 	;; We may have removed everything we inserted if if was just
 	;; spaces.
@@ -924,7 +950,8 @@ If EXTERNAL, browse the URL using `shr-external-browser'."
     (let ((param (match-string 4 data))
 	  (payload (url-unhex-string (match-string 5 data))))
       (when (string-match "^.*\\(;[ \t]*base64\\)$" param)
-	(setq payload (base64-decode-string payload)))
+	(setq payload (ignore-errors
+                        (base64-decode-string payload))))
       payload)))
 
 ;; Behind display-graphic-p test.
@@ -951,10 +978,14 @@ element is the data blob and the second element is the content-type."
 		      (create-image data 'svg t :ascent 100))
 		     ((eq size 'full)
 		      (ignore-errors
-			(shr-rescale-image data content-type)))
+			(shr-rescale-image data content-type
+                                           (plist-get flags :width)
+                                           (plist-get flags :height))))
 		     (t
 		      (ignore-errors
-			(shr-rescale-image data content-type))))))
+			(shr-rescale-image data content-type
+                                           (plist-get flags :width)
+                                           (plist-get flags :height)))))))
         (when image
 	  ;; When inserting big-ish pictures, put them at the
 	  ;; beginning of the line.
@@ -977,21 +1008,40 @@ element is the data blob and the second element is the content-type."
 	image)
     (insert (or alt ""))))
 
-(defun shr-rescale-image (data &optional content-type)
-  "Rescale DATA, if too big, to fit the current buffer."
-  (if (not (and (fboundp 'imagemagick-types)
-                (get-buffer-window (current-buffer))))
+(defun shr-rescale-image (data content-type width height)
+  "Rescale DATA, if too big, to fit the current buffer.
+WIDTH and HEIGHT are the sizes given in the HTML data, if any."
+  (if (or (not (fboundp 'imagemagick-types))
+          (not (get-buffer-window (current-buffer))))
       (create-image data nil t :ascent 100)
-    (let ((edges (window-inside-pixel-edges
-		  (get-buffer-window (current-buffer)))))
-      (create-image
-       data 'imagemagick t
-       :ascent 100
-       :max-width (truncate (* shr-max-image-proportion
-			       (- (nth 2 edges) (nth 0 edges))))
-       :max-height (truncate (* shr-max-image-proportion
-				(- (nth 3 edges) (nth 1 edges))))
-       :format content-type))))
+    (let* ((edges (window-inside-pixel-edges
+                   (get-buffer-window (current-buffer))))
+           (max-width (truncate (* shr-max-image-proportion
+                                   (- (nth 2 edges) (nth 0 edges)))))
+           (max-height (truncate (* shr-max-image-proportion
+                                    (- (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 'imagemagick t
+           :ascent 100
+           :width width
+           :height height
+           :format content-type)
+        (create-image
+         data 'imagemagick t
+         :ascent 100
+         :max-width max-width
+         :max-height max-height
+         :format content-type)))))
 
 ;; url-cache-extract autoloads url-cache.
 (declare-function url-cache-create-filename "url-cache" (url))
@@ -1070,8 +1120,15 @@ START, and END.  Note that START and END should be markers."
 				   url)))
 		      (if title (format "%s (%s)" iri title) iri))
 	 'follow-link t
-	 'mouse-face 'highlight
-	 'keymap shr-map)))
+	 'mouse-face 'highlight))
+  ;; Don't overwrite any keymaps that are already in the buffer (i.e.,
+  ;; image keymaps).
+  (while (and start
+              (< start (point)))
+    (let ((next (next-single-property-change start 'keymap nil (point))))
+      (if (get-text-property start 'keymap)
+          (setq start next)
+        (put-text-property start (or next (point)) 'keymap shr-map)))))
 
 (defun shr-encode-url (url)
   "Encode URL."
@@ -1103,7 +1160,9 @@ ones, in case fg and bg are nil."
                (shr-color-visible bg fg)))))))
 
 (defun shr-colorize-region (start end fg &optional bg)
-  (when (and (or fg bg) (>= (display-color-cells) 88))
+  (when (and shr-use-colors
+             (or fg bg)
+             (>= (display-color-cells) 88))
     (let ((new-colors (shr-color-check fg bg)))
       (when new-colors
 	(when fg
@@ -1116,18 +1175,6 @@ ones, in case fg and bg are nil."
 				  t)))
       new-colors)))
 
-(defun shr-previous-newline-padding-width (width)
-  (let ((overlays (overlays-at (point)))
-	(previous-width 0))
-    (if (null overlays)
-	width
-      (dolist (overlay overlays)
-	(setq previous-width
-	      (+ previous-width
-		 (length (plist-get (overlay-properties overlay)
-				    'before-string)))))
-      (+ width previous-width))))
-
 ;;; Tag-specific rendering rules.
 
 (defun shr-tag-html (dom)
@@ -1136,7 +1183,9 @@ ones, in case fg and bg are nil."
      ((equal dir "ltr")
       (setq bidi-paragraph-direction 'left-to-right))
      ((equal dir "rtl")
-      (setq bidi-paragraph-direction 'right-to-left))))
+      (setq bidi-paragraph-direction 'right-to-left))
+     ((equal dir "auto")
+      (setq bidi-paragraph-direction nil))))
   (shr-generic dom))
 
 (defun shr-tag-body (dom)
@@ -1222,9 +1271,6 @@ ones, in case fg and bg are nil."
 (defun shr-tag-s (dom)
   (shr-fontize-dom dom 'shr-strike-through))
 
-(defun shr-tag-del (dom)
-  (shr-fontize-dom dom 'shr-strike-through))
-
 (defun shr-tag-b (dom)
   (shr-fontize-dom dom 'bold))
 
@@ -1244,6 +1290,24 @@ ones, in case fg and bg are nil."
   (let ((shr-current-font 'default))
     (shr-generic dom)))
 
+(defun shr-tag-ins (cont)
+  (let* ((start (point))
+         (color "green")
+         (shr-stylesheet (nconc (list (cons 'color color))
+				shr-stylesheet)))
+    (shr-generic cont)
+    (shr-colorize-region start (point) color
+                         (cdr (assq 'background-color shr-stylesheet)))))
+
+(defun shr-tag-del (cont)
+  (let* ((start (point))
+         (color "red")
+         (shr-stylesheet (nconc (list (cons 'color color))
+				shr-stylesheet)))
+    (shr-fontize-dom cont 'shr-strike-through)
+    (shr-colorize-region start (point) color
+                         (cdr (assq 'background-color shr-stylesheet)))))
+
 (defun shr-parse-style (style)
   (when style
     (save-match-data
@@ -1387,11 +1451,14 @@ The preference is a float determined from `shr-prefer-media-type'."
 (defun shr-tag-img (dom &optional url)
   (when (or url
 	    (and dom
-		 (> (length (dom-attr dom 'src)) 0)))
+		 (or (> (length (dom-attr dom 'src)) 0)
+                     (> (length (dom-attr dom 'srcset)) 0))))
     (when (> (current-column) 0)
       (insert "\n"))
     (let ((alt (dom-attr dom 'alt))
-	  (url (shr-expand-url (or url (dom-attr dom 'src)))))
+          (width (shr-string-number (dom-attr dom 'width)))
+          (height (shr-string-number (dom-attr dom 'height)))
+	  (url (shr-expand-url (or url (shr--preferred-image dom)))))
       (let ((start (point-marker)))
 	(when (zerop (length alt))
 	  (setq alt "*"))
@@ -1404,7 +1471,8 @@ The preference is a float determined from `shr-prefer-media-type'."
 	       (string-match "\\`data:" url))
 	  (let ((image (shr-image-from-data (substring url (match-end 0)))))
 	    (if image
-		(funcall shr-put-image-function image alt)
+		(funcall shr-put-image-function image alt
+                         (list :width width :height height))
 	      (insert alt))))
 	 ((and (not shr-inhibit-images)
 	       (string-match "\\`cid:" url))
@@ -1413,7 +1481,8 @@ The preference is a float determined from `shr-prefer-media-type'."
 	    (if (or (not shr-content-function)
 		    (not (setq image (funcall shr-content-function url))))
 		(insert alt)
-	      (funcall shr-put-image-function image alt))))
+	      (funcall shr-put-image-function image alt
+                       (list :width width :height height)))))
 	 ((or shr-inhibit-images
 	      (and shr-blocked-images
 		   (string-match shr-blocked-images url)))
@@ -1421,20 +1490,26 @@ The preference is a float determined from `shr-prefer-media-type'."
           (shr-insert alt))
 	 ((and (not shr-ignore-cache)
 	       (url-is-cached (shr-encode-url url)))
-	  (funcall shr-put-image-function (shr-get-image-data url) alt))
+	  (funcall shr-put-image-function (shr-get-image-data url) alt
+                   (list :width width :height height)))
 	 (t
-	  (insert alt " ")
 	  (when (and shr-ignore-cache
 		     (url-is-cached (shr-encode-url url)))
 	    (let ((file (url-cache-create-filename (shr-encode-url url))))
 	      (when (file-exists-p file)
 		(delete-file file))))
+          (when (image-type-available-p 'svg)
+            (insert-image
+             (shr-make-placeholder-image dom)
+             (or alt "")))
+          (insert " ")
 	  (url-queue-retrieve
 	   (shr-encode-url url) 'shr-image-fetched
-	   (list (current-buffer) start (set-marker (make-marker) (1- (point))))
+	   (list (current-buffer) start (set-marker (make-marker) (point))
+                 (list :width width :height height))
 	   t t)))
 	(when (zerop shr-table-depth) ;; We are not in a table.
-	  (put-text-property start (point) 'keymap shr-map)
+	  (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-displayer
@@ -1443,6 +1518,87 @@ The preference is a float determined from `shr-prefer-media-type'."
 			     (shr-fill-text
 			      (or (dom-attr dom 'title) alt))))))))
 
+(defun shr--preferred-image (dom)
+  (let ((srcset (dom-attr dom 'srcset))
+        (frame-width (frame-pixel-width))
+        (width (string-to-number (or (dom-attr dom 'width) "100")))
+        candidate)
+    (when (> (length srcset) 0)
+      ;; srcset consist of a series of URL/size specifications
+      ;; separated by the ", " string.
+      (setq srcset
+            (sort (mapcar
+                   (lambda (elem)
+                     (let ((spec (split-string elem " ")))
+                       (cond
+                        ((= (length spec) 1)
+                         ;; Make sure it's well formed.
+                         (list (car spec) 0))
+                        ((string-match "\\([0-9]+\\)x\\'" (cadr spec))
+                         ;; If we have an "x" form, then use the width
+                         ;; spec to compute the real width.
+                         (list (car spec)
+                               (* width (string-to-number
+                                         (match-string 1 (cadr spec))))))
+                        (t
+                         (list (car spec)
+                               (string-to-number (cadr spec)))))))
+                   (split-string srcset ", "))
+                  (lambda (e1 e2)
+                    (> (cadr e1) (cadr e2)))))
+      ;; Choose the smallest picture that's bigger than the current
+      ;; frame.
+      (setq candidate (caar srcset))
+      (while (and srcset
+                  (> (cadr (car srcset)) frame-width))
+        (setq candidate (caar srcset))
+        (pop srcset)))
+    (or candidate (dom-attr dom 'src))))
+
+(defun shr-string-number (string)
+  (if (null string)
+      nil
+    (setq string (replace-regexp-in-string "[^0-9]" "" string))
+    (if (zerop (length string))
+        nil
+      (string-to-number string))))
+
+(defun shr-make-placeholder-image (dom)
+  (let* ((edges (and
+                 (get-buffer-window (current-buffer))
+                 (window-inside-pixel-edges
+                  (get-buffer-window (current-buffer)))))
+         (scaling (image-compute-scaling-factor image-scaling-factor))
+         (width (truncate
+                 (* (or (shr-string-number (dom-attr dom 'width)) 100)
+                    scaling)))
+         (height (truncate
+                  (* (or (shr-string-number (dom-attr dom 'height)) 100)
+                     scaling)))
+         (max-width
+          (and edges
+               (truncate (* shr-max-image-proportion
+                            (- (nth 2 edges) (nth 0 edges))))))
+         (max-height (and edges
+                          (truncate (* shr-max-image-proportion
+                                       (- (nth 3 edges) (nth 1 edges))))))
+         svg image)
+    (when (and max-width
+               (> width max-width))
+      (setq height (truncate (* (/ (float max-width) width) height))
+            width max-width))
+    (when (and max-height
+               (> height max-height))
+      (setq width (truncate (* (/ (float max-height) height) width))
+            height max-height))
+    (setq svg (svg-create width height))
+    (svg-gradient svg "background" 'linear '((0 . "#b0b0b0") (100 . "#808080")))
+    (svg-rectangle svg 0 0 width height :gradient "background"
+                   :stroke-width 2 :stroke-color "black")
+    (let ((image (svg-image svg)))
+      (setf (image-property image :ascent) 100)
+      image)))
+
 (defun shr-tag-pre (dom)
   (let ((shr-folding-mode 'none)
 	(shr-current-font 'default))
@@ -1479,6 +1635,10 @@ The preference is a float determined from `shr-prefer-media-type'."
   (shr-ensure-paragraph)
   (let ((shr-list-mode 'ul))
     (shr-generic dom))
+  ;; If we end on an empty <li>, then make sure we really end on a new
+  ;; paragraph.
+  (unless (bolp)
+    (insert "\n"))
   (shr-ensure-paragraph))
 
 (defun shr-tag-ol (dom)
@@ -1505,7 +1665,9 @@ The preference is a float determined from `shr-prefer-media-type'."
 	(put-text-property start (1+ start)
 			   'shr-continuation-indentation shr-indentation)
 	(put-text-property start (1+ start) 'shr-prefix-length (length bullet))
-	(shr-generic dom)))))
+	(shr-generic dom))))
+  (unless (bolp)
+    (insert "\n")))
 
 (defun shr-mark-fill (start)
   ;; We may not have inserted any text to fill.
@@ -1568,6 +1730,24 @@ The preference is a float determined from `shr-prefer-media-type'."
       (shr-colorize-region start (point) color
 			   (cdr (assq 'background-color shr-stylesheet))))))
 
+(defun shr-tag-bdo (dom)
+  (let* ((direction (dom-attr dom 'dir))
+         (char (cond
+                ((equal direction "ltr")
+                 ?\N{LEFT-TO-RIGHT OVERRIDE})
+                ((equal direction "rtl")
+                 ?\N{RIGHT-TO-LEFT OVERRIDE}))))
+    (when char
+      (insert ?\N{FIRST STRONG ISOLATE} char))
+    (shr-generic dom)
+    (when char
+      (insert ?\N{POP DIRECTIONAL FORMATTING} ?\N{POP DIRECTIONAL ISOLATE}))))
+
+(defun shr-tag-bdi (dom)
+  (insert ?\N{FIRST STRONG ISOLATE})
+  (shr-generic dom)
+  (insert ?\N{POP DIRECTIONAL ISOLATE}))
+
 ;;; Table rendering algorithm.
 
 ;; Table rendering is the only complicated thing here.  We do this by