(require 'browse-url)
(require 'subr-x)
(require 'dom)
+(require 'seq)
+(require 'svg)
+(require 'image)
(defgroup shr nil
"Simple HTML Renderer"
(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))
(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.
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"))
(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))
(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 " "))
(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.
(url-expand-file-name url (concat (car base) (cadr base))))))
(defun shr-ensure-newline ()
- (unless (zerop (current-column))
- (insert "\n")))
+ (unless (bobp)
+ (let ((prefix (get-text-property (line-beginning-position)
+ 'shr-prefix-length)))
+ (unless (or (zerop (current-column))
+ (and prefix
+ (= prefix (- (point) (line-beginning-position)))))
+ (insert "\n")))))
(defun shr-ensure-paragraph ()
(unless (bobp)
(line-end-position))
(line-end-position)))))
(delete-region (match-beginning 0) (match-end 0)))
+ ;; We have a single blank line.
+ ((and (eolp) (bolp))
+ (insert "\n"))
+ ;; Insert new paragraph.
(t
(insert "\n\n"))))))
(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.
(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.
(image-animated-p image))))
(image-animate image nil 60)))
image)
- (insert alt)))
+ (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))
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."
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)
((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)
(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))
(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
(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 "*"))
(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))
(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)))
(setq shr-start (point))
- (if (> (string-width alt) 8)
- (shr-insert (truncate-string-to-width alt 8))
- (shr-insert alt)))
+ (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
(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))
(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)
(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.
(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
align)))
(dolist (line lines)
(end-of-line)
- (let ((start (point)))
- (insert
- line
- (propertize " "
- 'display `(space :align-to (,pixel-align))
- 'face (and (> (length line) 0)
- (shr-face-background
- (get-text-property
- (1- (length line)) 'face line)))
- 'shr-table-indent shr-table-id)
- shr-table-vertical-line)
+ (let ((start (point))
+ (background (and (> (length line) 0)
+ (shr-face-background
+ (get-text-property
+ (1- (length line)) 'face line))))
+ (space (propertize
+ " "
+ 'display `(space :align-to (,pixel-align))
+ 'shr-table-indent shr-table-id)))
+ (when background
+ (setq space (propertize space 'face background)))
+ (insert line space shr-table-vertical-line)
(shr-colorize-region
start (1- (point)) (nth 5 column) (nth 6 column)))
(forward-line 1))
(defun shr-face-background (face)
(and (consp face)
- (let ((background nil))
- (dolist (elem face)
- (when (and (consp elem)
- (eq (car elem) :background))
- (setq background (cadr elem))))
- (and background
- (list :background background)))))
+ (or (and (plist-get face :background)
+ (list :background (plist-get face :background)))
+ (let ((background nil))
+ (dolist (elem face)
+ (when (and (consp elem)
+ (eq (car elem) :background)
+ (not background))
+ (setq background (cadr elem))))
+ (and background
+ (list :background background))))))
(defun shr-expand-alignments (start end)
(while (< (setq start (next-single-property-change