;;; shr.el --- Simple HTML Renderer
-;; Copyright (C) 2010-2015 Free Software Foundation, Inc.
+;; Copyright (C) 2010-2016 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: html
(require 'browse-url)
(require 'subr-x)
(require 'dom)
+(require 'seq)
(defgroup shr nil
"Simple HTML Renderer"
(goto-char begin)
(shr-insert-document dom))))
+(defun shr--have-one-fringe-p ()
+ "Return non-nil if we know at least one of the fringes has non-zero width."
+ (and (fboundp 'fringe-columns)
+ (or (not (zerop (fringe-columns 'right)))
+ (not (zerop (fringe-columns 'left))))))
+
;;;###autoload
(defun shr-insert-document (dom)
"Render the parsed document DOM into the current buffer.
(if (not shr-use-fonts)
(- (window-body-width) 1
(if (and (null shr-width)
- (or (zerop
- (fringe-columns 'right))
- (zerop
- (fringe-columns 'left))))
+ (not (shr--have-one-fringe-p)))
0
1))
(- (window-body-width nil t)
(* 2 (frame-char-width))
(if (and (null shr-width)
- (or (zerop
- (fringe-columns 'right))
- (zerop
- (fringe-columns 'left))))
+ (not (shr--have-one-fringe-p)))
(* (frame-char-width) 2)
- 0))))))
+ 0)))))
+ bidi-display-reordering)
+ ;; If the window was hscrolled for some reason, shr-fill-lines
+ ;; below will misbehave, because it silently assumes that it
+ ;; starts with a non-hscrolled window (vertical-motion will move
+ ;; to a wrong place otherwise).
+ (set-window-hscroll nil 0)
(shr-descend dom)
(shr-fill-lines start (point))
(shr-remove-trailing-whitespace start (point))
(defun shr-next-link ()
"Skip to the next link."
(interactive)
- (let ((skip (text-property-any (point) (point-max) 'help-echo nil)))
- (if (or (eobp)
- (not (setq skip (text-property-not-all skip (point-max)
- 'help-echo nil))))
- (message "No next link")
+ (let ((current (get-text-property (point) 'shr-url))
+ (start (point))
+ skip)
+ (while (and (not (eobp))
+ (equal (get-text-property (point) 'shr-url) current))
+ (forward-char 1))
+ (cond
+ ((and (not (eobp))
+ (get-text-property (point) 'shr-url))
+ ;; The next link is adjacent.
+ (message "%s" (get-text-property (point) 'help-echo)))
+ ((or (eobp)
+ (not (setq skip (text-property-not-all (point) (point-max)
+ 'shr-url nil))))
+ (goto-char start)
+ (message "No next link"))
+ (t
(goto-char skip)
- (message "%s" (get-text-property (point) 'help-echo)))))
+ (message "%s" (get-text-property (point) 'help-echo))))))
(defun shr-previous-link ()
"Skip to the previous link."
(shr-stylesheet shr-stylesheet)
(shr-depth (1+ shr-depth))
(start (point)))
- ;; shr uses about 12 frames per nested node.
- (if (> shr-depth (/ max-specpdl-size 12))
+ ;; shr uses many frames per nested node.
+ (if (> shr-depth (/ max-specpdl-size 15))
(setq shr-warning "Too deeply nested to render properly; consider increasing `max-specpdl-size'")
(when style
(if (string-match "color\\|display\\|border-collapse" style)
;; Adjust the window width for when
;; the user disables the fringes,
;; which causes the display engine
- ;; usurp one coplumn for the
+ ;; to usurp one column for the
;; continuation glyph.
(if (and (null shr-width)
- (or (zerop (fringe-columns 'right))
- (zerop (fringe-columns 'left))))
+ (not (shr--have-one-fringe-p)))
(* (frame-char-width) 2)
0))))
(shr-insert text)
(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.
(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."
;;; Tag-specific rendering rules.
+(defun shr-tag-html (dom)
+ (let ((dir (dom-attr dom 'dir)))
+ (cond
+ ((equal dir "ltr")
+ (setq bidi-paragraph-direction 'left-to-right))
+ ((equal dir "rtl")
+ (setq bidi-paragraph-direction 'right-to-left))))
+ (shr-generic dom))
+
(defun shr-tag-body (dom)
(let* ((start (point))
(fgcolor (or (dom-attr dom 'fgcolor) (dom-attr dom 'text)))
(defun shr-tag-svg (dom)
(when (and (image-type-available-p 'svg)
- (not shr-inhibit-images))
+ (not shr-inhibit-images)
+ (dom-attr dom 'width)
+ (dom-attr dom 'height))
(funcall shr-put-image-function (list (shr-dom-to-xml dom) 'image/svg+xml)
"SVG Image")))
(start (point)))
(unless url
(setq url (car (shr--extract-best-source dom))))
- (if image
+ (if (> (length image) 0)
(shr-tag-img nil image)
(shr-insert " [video] "))
(shr-urlify start (shr-expand-url url))))
(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))
(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)
;; Then render the table again with these new "hard" widths.
(shr-insert-table (shr-make-table dom sketch-widths t) sketch-widths)))
+(defun shr-table-body (dom)
+ (let ((tbodies (seq-filter (lambda (child)
+ (eq (dom-tag child) 'tbody))
+ (dom-non-text-children dom))))
+ (cond
+ ((null tbodies)
+ dom)
+ ((= (length tbodies) 1)
+ (car tbodies))
+ (t
+ ;; Table with multiple tbodies. Convert into a single tbody.
+ `(tbody nil ,@(cl-reduce 'append
+ (mapcar 'dom-non-text-children tbodies)))))))
+
(defun shr-tag-table (dom)
(shr-ensure-paragraph)
(let* ((caption (dom-children (dom-child-by-tag dom 'caption)))
(header (dom-non-text-children (dom-child-by-tag dom 'thead)))
- (body (dom-non-text-children (or (dom-child-by-tag dom 'tbody)
- dom)))
+ (body (dom-non-text-children (shr-table-body dom)))
(footer (dom-non-text-children (dom-child-by-tag dom 'tfoot)))
(bgcolor (dom-attr dom 'bgcolor))
(start (point))
(shr-stylesheet (nconc (list (cons 'background-color bgcolor))
shr-stylesheet))
(nheader (if header (shr-max-columns header)))
- (nbody (if body (shr-max-columns body)))
+ (nbody (if body (shr-max-columns body) 0))
(nfooter (if footer (shr-max-columns footer))))
(if (and (not caption)
(not header)
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