;;; 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
:group 'shr
:type '(choice (const nil) regexp))
-(defcustom shr-use-fonts nil
+(defcustom shr-use-fonts t
"If non-nil, use proportional fonts for text."
:version "25.1"
:group 'shr
(defvar shr-ignore-cache nil)
(defvar shr-external-rendering-functions nil)
(defvar shr-target-id nil)
-(defvar shr-inhibit-decoration nil)
(defvar shr-table-separator-length 1)
(defvar shr-table-separator-pixel-width 0)
(defvar shr-table-id nil)
(defvar shr-current-font nil)
+(defvar shr-internal-bullet nil)
(defvar shr-map
(let ((map (make-sparse-keymap)))
;; Public functions and commands.
(declare-function libxml-parse-html-region "xml.c"
- (start end &optional base-url))
+ (start end &optional base-url discard-comments))
(defun shr-render-buffer (buffer)
"Display the HTML rendering of the current buffer."
(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.
(shr-table-id 0)
(shr-warning nil)
(shr-table-separator-pixel-width (shr-string-pixel-width "-"))
+ (shr-internal-bullet (cons shr-bullet
+ (shr-string-pixel-width shr-bullet)))
(shr-internal-width (or (and shr-width
(if (not shr-use-fonts)
shr-width
(* shr-width (frame-char-width))))
+ ;; We need to adjust the available
+ ;; width for when the user disables
+ ;; the fringes, which will cause the
+ ;; display engine usurp one column for
+ ;; the continuation glyph.
(if (not shr-use-fonts)
- (- (window-width) 2)
- (- (window-pixel-width)
- (* (frame-fringe-width) 2))))))
+ (- (window-body-width) 1
+ (if (and (null shr-width)
+ (not (shr--have-one-fringe-p)))
+ 0
+ 1))
+ (- (window-body-width nil t)
+ (* 2 (frame-char-width))
+ (if (and (null shr-width)
+ (not (shr--have-one-fringe-p)))
+ (* (frame-char-width) 2)
+ 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)
(with-temp-buffer
(let ((shr-indentation 0)
(shr-start nil)
- (shr-internal-width (- (window-pixel-width)
- (* (frame-fringe-width) 2))))
+ (shr-internal-width (- (window-body-width nil t)
+ (* 2 (frame-char-width))
+ ;; Adjust the window width for when
+ ;; the user disables the fringes,
+ ;; which causes the display engine
+ ;; to usurp one column for the
+ ;; continuation glyph.
+ (if (and (null shr-width)
+ (not (shr--have-one-fringe-p)))
+ (* (frame-char-width) 2)
+ 0))))
(shr-insert text)
(buffer-string)))))
(insert "\n"))
(cond
((eq shr-folding-mode 'none)
- (insert text))
- (t
- (when (and (string-match "\\`[ \t\n\r ]" text)
- (not (bolp))
- (not (eq (char-after (1- (point))) ? )))
- (insert " "))
- (let ((start (point))
- (bolp (bolp)))
+ (let ((start (point)))
(insert text)
(save-restriction
(narrow-to-region start (point))
- (goto-char start)
- (when (looking-at "[ \t\n\r ]+")
+ ;; Remove soft hyphens.
+ (goto-char (point-min))
+ (while (search-forward "" nil t)
(replace-match "" t t))
- (while (re-search-forward "[ \t\n\r ]+" nil t)
- (replace-match " " t t))
- (goto-char (point-max)))
- ;; We may have removed everything we inserted if if was just
- ;; spaces.
- (unless (= start (point))
- ;; Mark all lines that should possibly be folded afterwards.
- (when bolp
- (shr-mark-fill start))
- (when shr-use-fonts
- (add-face-text-property start (point)
- (or shr-current-font 'variable-pitch)
- t)))))))
+ (goto-char (point-max)))))
+ (t
+ (let ((font-start (point)))
+ (when (and (string-match "\\`[ \t\n\r ]" text)
+ (not (bolp))
+ (not (eq (char-after (1- (point))) ? )))
+ (insert " "))
+ (let ((start (point))
+ (bolp (bolp)))
+ (insert text)
+ (save-restriction
+ (narrow-to-region start (point))
+ (goto-char start)
+ (when (looking-at "[ \t\n\r ]+")
+ (replace-match "" t 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))
+ (goto-char (point-max)))
+ ;; We may have removed everything we inserted if if was just
+ ;; spaces.
+ (unless (= font-start (point))
+ ;; Mark all lines that should possibly be folded afterwards.
+ (when bolp
+ (shr-mark-fill start))
+ (when shr-use-fonts
+ (put-text-property font-start (point)
+ 'face
+ (or shr-current-font 'variable-pitch)))))))))
(defun shr-fill-lines (start end)
(if (<= shr-internal-width 0)
(point) 'shr-continuation-indentation))
start)
(put-text-property (point) (1+ (point)) 'shr-indentation nil)
- (shr-indent)
+ (let ((face (get-text-property (point) 'face))
+ (background-start (point)))
+ (shr-indent)
+ (when face
+ (put-text-property background-start (point) 'face
+ `,(shr-face-background face))))
(setq start (point))
(setq shr-indentation (or continuation shr-indentation))
(shr-vertical-motion shr-internal-width)
;; Success; continue.
(when (= (preceding-char) ?\s)
(delete-char -1))
- (insert "\n")
- (shr-indent)
+ (let ((face (get-text-property (point) 'face))
+ (background-start (point)))
+ (insert "\n")
+ (shr-indent)
+ (when face
+ (put-text-property background-start (point) 'face
+ `,(shr-face-background face))))
(setq start (point))
(shr-vertical-motion shr-internal-width)
(when (looking-at " $")
;; There's no breakable point, so we give it up.
(let (found)
(goto-char bp)
- (unless shr-kinsoku-shorten
+ ;; Don't overflow the window edge, even if
+ ;; shr-kinsoku-shorten is nil.
+ (unless (or shr-kinsoku-shorten (null shr-width))
(while (setq found (re-search-forward
"\\(\\c>\\)\\| \\|\\c<\\|\\c|"
(line-end-position) 'move)))
;; Don't put kinsoku-bol characters at the beginning of a line,
;; or kinsoku-eol characters at the end of a line.
(cond
- (shr-kinsoku-shorten
+ ;; Don't overflow the window edge, even if shr-kinsoku-shorten
+ ;; is nil.
+ ((or shr-kinsoku-shorten (null shr-width))
(while (and (not (memq (preceding-char) (list ?\C-@ ?\n ? )))
- (shr-char-kinsoku-eol-p (preceding-char)))
+ (or (shr-char-kinsoku-eol-p (preceding-char))
+ (shr-char-kinsoku-bol-p (following-char))))
(backward-char 1))
(when (setq failed (<= (point) start))
;; There's no breakable point that doesn't violate kinsoku,
shr-base))
(when (zerop (length url))
(setq url nil))
+ ;; Strip leading whitespace
+ (and url (string-match "\\`\\s-+" url)
+ (setq url (substring url (match-end 0))))
(cond ((or (not url)
(not base)
(string-match "\\`[a-z]*:" url))
(defun shr-ensure-paragraph ()
(unless (bobp)
- (if (<= (current-column) shr-indentation)
- (unless (save-excursion
- (forward-line -1)
- (looking-at " *$"))
- (insert "\n"))
- (if (save-excursion
- (beginning-of-line)
- ;; If the current line is totally blank, and doesn't even
- ;; have any face properties set, then delete the blank
- ;; space.
- (and (looking-at " *$")
- (not (get-text-property (point) 'face))
- (not (= (next-single-property-change (point) 'face nil
- (line-end-position))
- (line-end-position)))))
- (delete-region (match-beginning 0) (match-end 0))
- (insert "\n\n")))))
+ (let ((prefix (get-text-property (line-beginning-position)
+ 'shr-prefix-length)))
+ (cond
+ ((and (bolp)
+ (save-excursion
+ (forward-line -1)
+ (looking-at " *$")))
+ ;; We're already at a new paragraph; do nothing.
+ )
+ ((and prefix
+ (= prefix (- (point) (line-beginning-position))))
+ ;; Do nothing; we're at the start of a <li>.
+ )
+ ((save-excursion
+ (beginning-of-line)
+ ;; If the current line is totally blank, and doesn't even
+ ;; have any face properties set, then delete the blank
+ ;; space.
+ (and (looking-at " *$")
+ (not (get-text-property (point) 'face))
+ (not (= (next-single-property-change (point) 'face nil
+ (line-end-position))
+ (line-end-position)))))
+ (delete-region (match-beginning 0) (match-end 0)))
+ (t
+ (insert "\n\n"))))))
(defun shr-indent ()
(when (> shr-indentation 0)
;; blank text at the start of the line, and the newline at the end, to
;; avoid ugliness.
(defun shr-add-font (start end type)
- (unless shr-inhibit-decoration
- (save-excursion
- (goto-char start)
- (while (< (point) end)
- (when (bolp)
- (skip-chars-forward " "))
- (add-face-text-property (point) (min (line-end-position) end) type t)
- (if (< (line-end-position) end)
- (forward-line 1)
- (goto-char end))))))
+ (save-excursion
+ (goto-char start)
+ (while (< (point) end)
+ (when (bolp)
+ (skip-chars-forward " "))
+ (add-face-text-property (point) (min (line-end-position) end) type t)
+ (if (< (line-end-position) end)
+ (forward-line 1)
+ (goto-char end)))))
(defun shr-mouse-browse-url (ev)
"Browse the URL under the mouse cursor."
(search-forward "\r\n\r\n" nil t))
(shr-parse-image-data)))))
+(declare-function libxml-parse-xml-region "xml.c"
+ (start end &optional base-url discard-comments))
+
(defun shr-parse-image-data ()
(let ((data (buffer-substring (point) (point-max)))
(content-type
(shr-color-visible bg fg)))))))
(defun shr-colorize-region (start end fg &optional bg)
- (when (and (not shr-inhibit-decoration)
- (or fg bg))
+ (when (and (or fg bg) (>= (display-color-cells) 88))
(let ((new-colors (shr-color-check fg bg)))
(when new-colors
(when fg
t)))
new-colors)))
-(defun shr-expand-newlines (start end color)
- (save-restriction
- ;; Skip past all white space at the start and ends.
- (goto-char start)
- (skip-chars-forward " \t\n")
- (beginning-of-line)
- (setq start (point))
- (goto-char end)
- (skip-chars-backward " \t\n")
- (forward-line 1)
- (setq end (point))
- (narrow-to-region start end)
- (let ((width (shr-buffer-width))
- column)
- (goto-char (point-min))
- (while (not (eobp))
- (end-of-line)
- (when (and (< (setq column (current-column)) width)
- (< (setq column (shr-previous-newline-padding-width column))
- width))
- (let ((overlay (make-overlay (point) (1+ (point)))))
- (overlay-put overlay 'before-string
- (concat
- (mapconcat
- (lambda (overlay)
- (let ((string (plist-get
- (overlay-properties overlay)
- 'before-string)))
- (if (not string)
- ""
- (overlay-put overlay 'before-string "")
- string)))
- (overlays-at (point))
- "")
- (propertize (make-string (- width column) ? )
- 'face (list :background color))))))
- (forward-line 1)))))
-
(defun shr-previous-newline-padding-width (width)
(let ((overlays (overlays-at (point)))
(previous-width 0))
;;; 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")))
(shr-ensure-newline)
(insert " "))
(put-text-property start (1+ start) 'shr-target-id shr-target-id))
- (when (and url
- (not shr-inhibit-decoration))
+ (when url
(shr-urlify (or shr-start start) (shr-expand-url url) title))))
(defun shr-tag-object (dom)
(prog1
(format "%d " shr-list-mode)
(setq shr-list-mode (1+ shr-list-mode)))
- shr-bullet)))
+ (car shr-internal-bullet)))
+ (width (if (numberp shr-list-mode)
+ (shr-string-pixel-width bullet)
+ (cdr shr-internal-bullet))))
(insert bullet)
(shr-mark-fill start)
- (let ((shr-indentation (+ shr-indentation
- (shr-string-pixel-width bullet))))
+ (let ((shr-indentation (+ shr-indentation width)))
(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)))))
(defun shr-mark-fill (start)
(defun shr-tag-hr (_dom)
(shr-ensure-newline)
- ;; FIXME: Should try to make a line of the required pixel size.
- (insert (make-string (window-width) shr-hr-line) "\n"))
+ (insert (make-string (if (not shr-use-fonts)
+ shr-internal-width
+ (1+ (/ shr-internal-width
+ shr-table-separator-pixel-width)))
+ shr-hr-line)
+ "\n"))
(defun shr-tag-title (dom)
(shr-heading dom 'bold 'underline))
;; 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 (dom-by-tag dom 'tbody)))
+ (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)
(dolist (line lines)
(end-of-line)
(let ((start (point)))
- (insert line
- (propertize " "
- 'display `(space :align-to (,pixel-align))
- 'shr-table-indent shr-table-id)
- shr-table-vertical-line)
+ (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)
(shr-colorize-region
start (1- (point)) (nth 5 column) (nth 6 column)))
(forward-line 1))
(unless (= start (point))
(put-text-property start (1+ start) 'shr-table-id shr-table-id))))
+(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)))))
+
(defun shr-expand-alignments (start end)
(while (< (setq start (next-single-property-change
start 'shr-table-id nil end))
(setq i (1+ i)))))
(let ((extra (- (apply '+ (append suggested-widths nil))
(apply '+ (append widths nil))
- (* shr-table-separator-pixel-width (length widths))))
+ (* shr-table-separator-pixel-width (1+ (length widths)))))
(expanded-columns 0))
;; We have extra, unused space, so divide this space amongst the
;; columns.
(defun shr-make-table-1 (dom widths &optional fill)
(let ((trs nil)
- (shr-inhibit-decoration (not fill))
(rowspans (make-vector (length widths) 0))
(colspan-remaining 0)
colspan-width colspan-count
(provide 'shr)
-;; Local Variables:
-;; coding: utf-8
-;; End:
-
;;; shr.el ends here