diff options
Diffstat (limited to 'lisp/net/shr.el')
| -rw-r--r-- | lisp/net/shr.el | 326 |
1 files changed, 249 insertions, 77 deletions
diff --git a/lisp/net/shr.el b/lisp/net/shr.el index 2c8ff79763f..9d42fde0756 100644 --- a/lisp/net/shr.el +++ b/lisp/net/shr.el @@ -36,6 +36,7 @@ (require 'subr-x) (require 'dom) (require 'seq) +(require 'svg) (defgroup shr nil "Simple HTML Renderer" @@ -64,6 +65,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 +143,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 +166,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 +186,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 +274,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. @@ -435,11 +452,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 +470,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 +554,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 +574,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 +588,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. @@ -952,10 +975,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. @@ -978,21 +1005,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)) @@ -1071,8 +1117,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." @@ -1104,7 +1157,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 @@ -1117,18 +1172,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) @@ -1137,7 +1180,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) @@ -1223,9 +1268,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)) @@ -1245,6 +1287,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 @@ -1388,11 +1448,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 "*")) @@ -1405,7 +1468,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)) @@ -1414,7 +1478,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))) @@ -1422,20 +1487,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 @@ -1444,6 +1515,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)) @@ -1510,7 +1662,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. @@ -1573,6 +1727,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 |