diff options
Diffstat (limited to 'lisp/net/shr.el')
| -rw-r--r-- | lisp/net/shr.el | 214 |
1 files changed, 177 insertions, 37 deletions
diff --git a/lisp/net/shr.el b/lisp/net/shr.el index e9431325333..e463c7edaf2 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)) @@ -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 @@ -942,10 +964,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. @@ -968,21 +994,37 @@ 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." +(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 (not (and (fboundp 'imagemagick-types) (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)))))) + (when (or (and width + (> width max-width)) + (and height + (> height max-height))) + (setq width nil + height nil)) + (if (and width 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)) @@ -1061,8 +1103,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." @@ -1094,7 +1143,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 @@ -1127,7 +1178,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) @@ -1213,9 +1266,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)) @@ -1235,6 +1285,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 @@ -1382,6 +1450,8 @@ The preference is a float determined from `shr-prefer-media-type'." (when (> (current-column) 0) (insert "\n")) (let ((alt (dom-attr dom 'alt)) + (width (shr-string-number (dom-attr dom 'width))) + (height (shr-string-number (dom-attr dom 'height))) (url (shr-expand-url (or url (dom-attr dom 'src))))) (let ((start (point-marker))) (when (zerop (length alt)) @@ -1395,7 +1465,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)) @@ -1404,7 +1475,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))) @@ -1412,20 +1484,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 @@ -1434,6 +1512,50 @@ The preference is a float determined from `shr-prefer-media-type'." (shr-fill-text (or (dom-attr dom 'title) alt)))))))) +(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)) @@ -1559,6 +1681,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") + #x202d) ; LRO + ((equal direction "rtl") + #x202e)))) ; RLO + (when char + (insert char)) + (shr-generic dom) + (when char + (insert #x202c)))) ; PDF + +(defun shr-tag-bdi (dom) + (insert #x2068) ; FSI + (shr-generic dom) + (insert #x2069)) ; PDI + ;;; Table rendering algorithm. ;; Table rendering is the only complicated thing here. We do this by |