;;; 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 t
+ "If non-nil, use proportional fonts for text."
+ :version "25.1"
+ :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."
(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)
-(defvar shr-state nil)
(defvar shr-start nil)
(defvar shr-indentation 0)
-(defvar shr-internal-width (or shr-width (1- (window-width))))
+(defvar shr-internal-width nil)
(defvar shr-list-mode nil)
(defvar shr-content-cache nil)
(defvar shr-kinsoku-shorten nil)
(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-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.
`libxml-parse-html-region' or similar."
(setq shr-content-cache nil)
(let ((start (point))
- (shr-state nil)
(shr-start nil)
(shr-base nil)
(shr-depth 0)
+ (shr-table-id 0)
(shr-warning nil)
- (shr-internal-width (or shr-width (1- (window-width)))))
+ (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-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))
(when shr-warning
(message "%s" shr-warning))))
(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."
(let ((text (get-text-property (point) 'shr-alt)))
(if (not text)
(message "No image under point")
- (message "%s" (shr-fold-text text)))))
+ (message "%s" (shr-fill-text text)))))
(defun shr-browse-image (&optional copy-url)
"Browse the image under point.
(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))
(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)
(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
(cdr (assq 'color shr-stylesheet))
(cdr (assq 'background-color shr-stylesheet))))))))
-(defun shr-fold-text (text)
+(defun shr-fill-text (text)
(if (zerop (length text))
text
(with-temp-buffer
(let ((shr-indentation 0)
- (shr-state nil)
(shr-start nil)
- (shr-internal-width (window-width)))
+ (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)))))
(unless (shr-char-kinsoku-bol-p (make-char 'japanese-jisx0208 33 35))
(load "kinsoku" nil t))
+(defun shr-pixel-column ()
+ (if (not shr-use-fonts)
+ (current-column)
+ (if (not (get-buffer-window (current-buffer)))
+ (save-window-excursion
+ (set-window-buffer nil (current-buffer))
+ (car (window-text-pixel-size nil (line-beginning-position) (point))))
+ (car (window-text-pixel-size nil (line-beginning-position) (point))))))
+
+(defun shr-pixel-region ()
+ (- (shr-pixel-column)
+ (save-excursion
+ (goto-char (mark))
+ (shr-pixel-column))))
+
+(defun shr-string-pixel-width (string)
+ (if (not shr-use-fonts)
+ (length string)
+ (with-temp-buffer
+ (insert string)
+ (shr-pixel-column))))
+
(defun shr-insert (text)
- (when (and (eq shr-state 'image)
- (not (bolp))
- (not (string-match "\\`[ \t\n]+\\'" text)))
- (insert "\n")
- (setq shr-state nil))
+ (when (and (not (bolp))
+ (get-text-property (1- (point)) 'image-url))
+ (insert "\n"))
(cond
((eq shr-folding-mode 'none)
- (insert text))
+ (let ((start (point)))
+ (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))
+ (goto-char (point-max)))))
(t
- (when (and (string-match "\\`[ \t\n ]" text)
- (not (bolp))
- (not (eq (char-after (1- (point))) ? )))
- (insert " "))
- (dolist (elem (split-string text "[ \f\t\n\r\v ]+" t))
- (when (and (bolp)
- (> shr-indentation 0))
- (shr-indent))
- ;; No space is needed behind a wide character categorized as
- ;; kinsoku-bol, between characters both categorized as nospace,
- ;; or at the beginning of a line.
- (let (prev)
- (when (and (> (current-column) shr-indentation)
- (eq (preceding-char) ? )
- (or (= (line-beginning-position) (1- (point)))
- (and (shr-char-breakable-p
- (setq prev (char-after (- (point) 2))))
- (shr-char-kinsoku-bol-p prev))
- (and (shr-char-nospace-p prev)
- (shr-char-nospace-p (aref elem 0)))))
- (delete-char -1)))
- ;; The shr-start is a special variable that is used to pass
- ;; upwards the first point in the buffer where the text really
- ;; starts.
- (unless shr-start
- (setq shr-start (point)))
- (insert elem)
- (setq shr-state nil)
- (let (found)
- (while (and (> (current-column) shr-internal-width)
- (> shr-internal-width 0)
- (progn
- (setq found (shr-find-fill-point))
- (not (eolp))))
- (when (eq (preceding-char) ? )
- (delete-char -1))
- (insert "\n")
- (unless found
- ;; No space is needed at the beginning of a line.
- (when (eq (following-char) ? )
- (delete-char 1)))
- (when (> shr-indentation 0)
- (shr-indent))
- (end-of-line))
- (if (<= (current-column) shr-internal-width)
- (insert " ")
- ;; In case we couldn't get a valid break point (because of a
- ;; word that's longer than `shr-internal-width'), just break anyway.
- (insert "\n")
- (when (> shr-indentation 0)
- (shr-indent)))))
- (unless (string-match "[ \t\r\n ]\\'" text)
- (delete-char -1)))))
-
-(defun shr-find-fill-point ()
- (when (> (move-to-column shr-internal-width) shr-internal-width)
- (backward-char 1))
+ (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)
+ nil
+ (save-restriction
+ (narrow-to-region start end)
+ (goto-char start)
+ (when (get-text-property (point) 'shr-indentation)
+ (shr-fill-line))
+ (while (setq start (next-single-property-change start 'shr-indentation))
+ (goto-char start)
+ (when (bolp)
+ (shr-fill-line)))
+ (goto-char (point-max)))))
+
+(defun shr-vertical-motion (column)
+ (if (not shr-use-fonts)
+ (move-to-column column)
+ (unless (eolp)
+ (forward-char 1))
+ (vertical-motion (cons (/ column (frame-char-width)) 0))
+ (unless (eolp)
+ (forward-char 1))))
+
+(defun shr-fill-line ()
+ (let ((shr-indentation (get-text-property (point) 'shr-indentation))
+ (continuation (get-text-property
+ (point) 'shr-continuation-indentation))
+ start)
+ (put-text-property (point) (1+ (point)) 'shr-indentation nil)
+ (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)
+ (when (looking-at " $")
+ (delete-region (point) (line-end-position)))
+ (while (not (eolp))
+ ;; We have to do some folding. First find the first
+ ;; previous point suitable for folding.
+ (if (or (not (shr-find-fill-point (line-beginning-position)))
+ (= (point) start))
+ ;; We had unbreakable text (for this width), so just go to
+ ;; the first space and carry on.
+ (progn
+ (beginning-of-line)
+ (skip-chars-forward " ")
+ (search-forward " " (line-end-position) 'move)))
+ ;; Success; continue.
+ (when (= (preceding-char) ?\s)
+ (delete-char -1))
+ (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 " $")
+ (delete-region (point) (line-end-position))))))
+
+(defun shr-find-fill-point (start)
(let ((bp (point))
+ (end (point))
failed)
- (while (not (or (setq failed (<= (current-column) shr-indentation))
+ (while (not (or (setq failed (<= (point) start))
(eq (preceding-char) ? )
(eq (following-char) ? )
(shr-char-breakable-p (preceding-char))
;; 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 (<= (current-column) shr-indentation))
+ (when (setq failed (<= (point) start))
;; There's no breakable point that doesn't violate kinsoku,
;; so we look for the second best position.
(while (and (progn
(forward-char 1)
- (<= (current-column) shr-internal-width))
+ (<= (point) end))
(progn
(setq bp (point))
(shr-char-kinsoku-eol-p (following-char)))))
(not (memq (preceding-char) (list ?\C-@ ?\n ? )))
(or (shr-char-kinsoku-eol-p (preceding-char))
(shr-char-kinsoku-bol-p (following-char)))))))
- (when (setq failed (<= (current-column) shr-indentation))
+ (when (setq failed (<= (point) start))
;; There's no breakable point that doesn't violate kinsoku,
;; so we go to the second best position.
(if (looking-at "\\(\\c<+\\)\\c<")
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)
- (insert (make-string shr-indentation ? ))))
+ (insert
+ (if (not shr-use-fonts)
+ (make-string shr-indentation ?\s)
+ (propertize " "
+ 'display
+ `(space :width (,shr-indentation)))))))
(defun shr-fontize-dom (dom &rest types)
- (let (shr-start)
+ (let ((start (point)))
(shr-generic dom)
(dolist (type types)
- (shr-add-font (or shr-start (point)) (point) type))))
+ (shr-add-font start (point) type))))
;; Add face to the region, but avoid putting the font properties on
;; 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 shr-use-colors
+ (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")))
(defun shr-tag-p (dom)
(shr-ensure-paragraph)
- (shr-indent)
(shr-generic dom)
(shr-ensure-paragraph))
(defun shr-tag-div (dom)
(shr-ensure-newline)
- (shr-indent)
(shr-generic dom)
(shr-ensure-newline))
(defun shr-tag-u (dom)
(shr-fontize-dom dom 'underline))
+(defun shr-tag-tt (dom)
+ (let ((shr-current-font 'default))
+ (shr-generic dom)))
+
(defun shr-parse-style (style)
(when style
(save-match-data
(value (replace-regexp-in-string "^ +\\| +$" "" (cadr elem))))
(when (string-match " *!important\\'" value)
(setq value (substring value 0 (match-beginning 0))))
- (push (cons (intern name obarray)
- value)
- plist)))))
+ (unless (equal value "inherit")
+ (push (cons (intern name obarray)
+ value)
+ plist))))))
plist)))
(defun shr-tag-base (dom)
(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)
(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))))
(when (or url
(and dom
(> (length (dom-attr dom 'src)) 0)))
- (when (and (> (current-column) 0)
- (not (eq shr-state 'image)))
+ (when (> (current-column) 0)
(insert "\n"))
(let ((alt (dom-attr dom 'alt))
(url (shr-expand-url (or url (dom-attr dom 'src)))))
(and shr-blocked-images
(string-match shr-blocked-images url)))
(setq shr-start (point))
- (let ((shr-state 'space))
- (if (> (string-width alt) 8)
- (shr-insert (truncate-string-to-width alt 8))
- (shr-insert alt))))
+ (if (> (string-width alt) 8)
+ (shr-insert (truncate-string-to-width alt 8))
+ (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))
(put-text-property start (point) 'image-displayer
(shr-image-displayer shr-content-function))
(put-text-property start (point) 'help-echo
- (shr-fold-text (or (dom-attr dom 'title) alt))))
- (setq shr-state 'image)))))
+ (shr-fill-text
+ (or (dom-attr dom 'title) alt))))))))
(defun shr-tag-pre (dom)
- (let ((shr-folding-mode 'none))
+ (let ((shr-folding-mode 'none)
+ (shr-current-font 'default))
(shr-ensure-newline)
- (shr-indent)
(shr-generic dom)
(shr-ensure-newline)))
(defun shr-tag-blockquote (dom)
(shr-ensure-paragraph)
- (shr-indent)
- (let ((shr-indentation (+ shr-indentation 4)))
- (shr-generic dom))
- (shr-ensure-paragraph))
+ (let ((start (point))
+ (shr-indentation (+ shr-indentation
+ (* 4 shr-table-separator-pixel-width))))
+ (shr-generic dom)
+ (shr-ensure-paragraph)
+ (shr-mark-fill start)))
(defun shr-tag-dl (dom)
(shr-ensure-paragraph)
(defun shr-tag-dd (dom)
(shr-ensure-newline)
- (let ((shr-indentation (+ shr-indentation 4)))
+ (let ((shr-indentation (+ shr-indentation
+ (* 4 shr-table-separator-pixel-width))))
(shr-generic dom)))
(defun shr-tag-ul (dom)
(defun shr-tag-li (dom)
(shr-ensure-newline)
- (shr-indent)
- (let* ((bullet
- (if (numberp shr-list-mode)
- (prog1
- (format "%d " shr-list-mode)
- (setq shr-list-mode (1+ shr-list-mode)))
- shr-bullet))
- (shr-indentation (+ shr-indentation (length bullet))))
- (insert bullet)
- (shr-generic dom)))
+ (let ((start (point)))
+ (let* ((bullet
+ (if (numberp shr-list-mode)
+ (prog1
+ (format "%d " shr-list-mode)
+ (setq shr-list-mode (1+ shr-list-mode)))
+ (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 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)
+ ;; We may not have inserted any text to fill.
+ (unless (= start (point))
+ (put-text-property start (1+ start)
+ 'shr-indentation shr-indentation)))
(defun shr-tag-br (dom)
(when (and (not (bobp))
(or (not (bolp))
(and (> (- (point) 2) (point-min))
(not (= (char-after (- (point) 2)) ?\n)))))
- (insert "\n")
- (shr-indent))
+ (insert "\n"))
(shr-generic dom))
(defun shr-tag-span (dom)
(shr-generic dom))
(defun shr-tag-h1 (dom)
- (shr-heading dom 'bold 'underline))
+ (shr-heading dom (if shr-use-fonts
+ '(variable-pitch (:height 1.3 :weight bold))
+ 'bold)))
(defun shr-tag-h2 (dom)
(shr-heading dom 'bold))
(defun shr-tag-hr (_dom)
(shr-ensure-newline)
- (insert (make-string shr-internal-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))
(shr-kinsoku-shorten t)
;; Find all suggested widths.
(columns (shr-column-specs dom))
- ;; Compute how many characters wide each TD should be.
+ ;; Compute how many pixels wide each TD should be.
(suggested-widths (shr-pro-rate-columns columns))
;; Do a "test rendering" to see how big each TD is (this can
;; be smaller (if there's little text) or bigger (if there's
;; unbreakable text).
- (sketch (shr-make-table dom suggested-widths))
- ;; Compute the "natural" width by setting each column to 500
- ;; characters and see how wide they really render.
- (natural (shr-make-table dom (make-vector (length columns) 500)))
+ (elems (or (dom-attr dom 'shr-suggested-widths)
+ (shr-make-table dom suggested-widths nil
+ 'shr-suggested-widths)))
+ (sketch (loop for line in elems
+ collect (mapcar #'car line)))
+ (natural (loop for line in elems
+ collect (mapcar #'cdr line)))
(sketch-widths (shr-table-widths sketch natural suggested-widths)))
;; This probably won't work very well.
(when (> (+ (loop for width across sketch-widths
summing (1+ width))
- shr-indentation 1)
+ shr-indentation shr-table-separator-pixel-width)
(frame-width))
(setq truncate-lines t))
;; 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-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)
;; Try to output it anyway.
(shr-generic dom)
;; It's a real table, so render it.
- (shr-tag-table-1
- (nconc
- (list 'table nil)
- (if caption `((tr nil (td nil ,@caption))))
- (cond (header
- (if footer
- ;; header + body + footer
- (if (= nheader nbody)
- (if (= nbody nfooter)
- `((tr nil (td nil (table nil
- (tbody nil ,@header
- ,@body ,@footer)))))
- (nconc `((tr nil (td nil (table nil
- (tbody nil ,@header
- ,@body)))))
- (if (= nfooter 1)
- footer
- `((tr nil (td nil (table
- nil (tbody
- nil ,@footer))))))))
- (nconc `((tr nil (td nil (table nil (tbody
- nil ,@header)))))
- (if (= nbody nfooter)
- `((tr nil (td nil (table
- nil (tbody nil ,@body
- ,@footer)))))
- (nconc `((tr nil (td nil (table
- nil (tbody nil
+ (if (dom-attr dom 'shr-fixed-table)
+ (shr-tag-table-1 dom)
+ ;; Only fix up the table once.
+ (let ((table
+ (nconc
+ (list 'table nil)
+ (if caption `((tr nil (td nil ,@caption))))
+ (cond
+ (header
+ (if footer
+ ;; header + body + footer
+ (if (= nheader nbody)
+ (if (= nbody nfooter)
+ `((tr nil (td nil (table nil
+ (tbody nil ,@header
+ ,@body ,@footer)))))
+ (nconc `((tr nil (td nil (table nil
+ (tbody nil ,@header
,@body)))))
- (if (= nfooter 1)
- footer
- `((tr nil (td nil (table
- nil
- (tbody
- nil
- ,@footer))))))))))
- ;; header + body
- (if (= nheader nbody)
- `((tr nil (td nil (table nil (tbody nil ,@header
- ,@body)))))
- (if (= nheader 1)
- `(,@header (tr nil (td nil (table
- nil (tbody nil ,@body)))))
- `((tr nil (td nil (table nil (tbody nil ,@header))))
- (tr nil (td nil (table nil (tbody nil ,@body)))))))))
- (footer
- ;; body + footer
- (if (= nbody nfooter)
- `((tr nil (td nil (table
- nil (tbody nil ,@body ,@footer)))))
- (nconc `((tr nil (td nil (table nil (tbody nil ,@body)))))
- (if (= nfooter 1)
- footer
- `((tr nil (td nil (table
- nil (tbody nil ,@footer)))))))))
- (caption
- `((tr nil (td nil (table nil (tbody nil ,@body))))))
- (body)))))
+ (if (= nfooter 1)
+ footer
+ `((tr nil (td nil (table
+ nil (tbody
+ nil ,@footer))))))))
+ (nconc `((tr nil (td nil (table nil (tbody
+ nil ,@header)))))
+ (if (= nbody nfooter)
+ `((tr nil (td nil (table
+ nil (tbody nil ,@body
+ ,@footer)))))
+ (nconc `((tr nil (td nil (table
+ nil (tbody nil
+ ,@body)))))
+ (if (= nfooter 1)
+ footer
+ `((tr nil (td nil (table
+ nil
+ (tbody
+ nil
+ ,@footer))))))))))
+ ;; header + body
+ (if (= nheader nbody)
+ `((tr nil (td nil (table nil (tbody nil ,@header
+ ,@body)))))
+ (if (= nheader 1)
+ `(,@header (tr nil (td nil (table
+ nil (tbody nil ,@body)))))
+ `((tr nil (td nil (table nil (tbody nil ,@header))))
+ (tr nil (td nil (table nil (tbody nil ,@body)))))))))
+ (footer
+ ;; body + footer
+ (if (= nbody nfooter)
+ `((tr nil (td nil (table
+ nil (tbody nil ,@body ,@footer)))))
+ (nconc `((tr nil (td nil (table nil (tbody nil ,@body)))))
+ (if (= nfooter 1)
+ footer
+ `((tr nil (td nil (table
+ nil (tbody nil ,@footer)))))))))
+ (caption
+ `((tr nil (td nil (table nil (tbody nil ,@body))))))
+ (body)))))
+ (dom-set-attribute table 'shr-fixed-table t)
+ (setcdr dom (cdr table))
+ (shr-tag-table-1 dom))))
(when bgcolor
(shr-colorize-region start (point) (cdr (assq 'color shr-stylesheet))
bgcolor))
;; model isn't strong enough to allow us to put the images actually
;; into the tables.
(when (zerop shr-table-depth)
+ (save-excursion
+ (shr-expand-alignments start (point)))
(dolist (elem (dom-by-tag dom 'object))
(shr-tag-object elem))
(dolist (elem (dom-by-tag dom 'img))
(let* ((collapse (equal (cdr (assq 'border-collapse shr-stylesheet))
"collapse"))
(shr-table-separator-length (if collapse 0 1))
- (shr-table-vertical-line (if collapse "" shr-table-vertical-line)))
+ (shr-table-vertical-line (if collapse "" shr-table-vertical-line))
+ (start (point)))
+ (setq shr-table-id (1+ shr-table-id))
(unless collapse
(shr-insert-table-ruler widths))
(dolist (row table)
(let ((start (point))
+ (align 0)
+ (column-number 0)
(height (let ((max 0))
(dolist (column row)
- (setq max (max max (cadr column))))
+ (setq max (max max (nth 2 column))))
max)))
- (dotimes (i height)
+ (dotimes (i (max height 1))
(shr-indent)
(insert shr-table-vertical-line "\n"))
(dolist (column row)
- (goto-char start)
- (let ((lines (nth 2 column)))
- (dolist (line lines)
- (end-of-line)
- (insert line shr-table-vertical-line)
- (forward-line 1))
- ;; Add blank lines at padding at the bottom of the TD,
- ;; possibly.
- (dotimes (i (- height (length lines)))
- (end-of-line)
- (let ((start (point)))
- (insert (make-string (string-width (car lines)) ? )
- shr-table-vertical-line)
- (when (nth 4 column)
- (shr-add-font start (1- (point))
- (list :background (nth 4 column)))))
- (forward-line 1)))))
+ (when (> (nth 2 column) -1)
+ (goto-char start)
+ ;; Sum up all the widths from the column. (There may be
+ ;; more than one if this is a "colspan" column.)
+ (dotimes (i (nth 4 column))
+ ;; The colspan directive may be wrong and there may not be
+ ;; that number of columns.
+ (when (<= column-number (1- (length widths)))
+ (setq align (+ align
+ (aref widths column-number)
+ (* 2 shr-table-separator-pixel-width))))
+ (setq column-number (1+ column-number)))
+ (let ((lines (nth 3 column))
+ (pixel-align (if (not shr-use-fonts)
+ (* align (frame-char-width))
+ 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)
+ (shr-colorize-region
+ start (1- (point)) (nth 5 column) (nth 6 column)))
+ (forward-line 1))
+ ;; Add blank lines at padding at the bottom of the TD,
+ ;; possibly.
+ (dotimes (i (- height (length lines)))
+ (end-of-line)
+ (let ((start (point)))
+ (insert (propertize " "
+ 'display `(space :align-to (,pixel-align))
+ '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 collapse
- (shr-insert-table-ruler widths)))))
+ (shr-insert-table-ruler widths)))
+ (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))
+ end)
+ (goto-char start)
+ (let* ((shr-use-fonts t)
+ (id (get-text-property (point) 'shr-table-id))
+ (base (shr-pixel-column))
+ elem)
+ (when id
+ (save-excursion
+ (while (setq elem (text-property-any
+ (point) end 'shr-table-indent id))
+ (goto-char elem)
+ (let ((align (get-text-property (point) 'display)))
+ (put-text-property (point) (1+ (point)) 'display
+ `(space :align-to (,(+ (car (nth 2 align))
+ base)))))
+ (forward-char 1)))))
+ (setq start (1+ start))))
(defun shr-insert-table-ruler (widths)
(when shr-table-horizontal-line
(> shr-indentation 0))
(shr-indent))
(insert shr-table-corner)
- (dotimes (i (length widths))
- (insert (make-string (aref widths i) shr-table-horizontal-line)
- shr-table-corner))
+ (let ((total-width 0))
+ (dotimes (i (length widths))
+ (setq total-width (+ total-width (aref widths i)
+ (* shr-table-separator-pixel-width 2)))
+ (insert (make-string (1+ (/ (aref widths i)
+ shr-table-separator-pixel-width))
+ shr-table-horizontal-line)
+ (propertize " "
+ 'display `(space :align-to (,total-width))
+ 'shr-table-indent shr-table-id)
+ shr-table-corner)))
(insert "\n")))
(defun shr-table-widths (table natural-table suggested-widths)
(aset natural-widths i (max (aref natural-widths i) column))
(setq i (1+ i)))))
(let ((extra (- (apply '+ (append suggested-widths nil))
- (apply '+ (append widths nil))))
+ (apply '+ (append widths nil))
+ (* shr-table-separator-pixel-width (1+ (length widths)))))
(expanded-columns 0))
;; We have extra, unused space, so divide this space amongst the
;; columns.
(aref widths i))))))))
widths))
-(defun shr-make-table (dom widths &optional fill)
+(defun shr-make-table (dom widths &optional fill storage-attribute)
(or (cadr (assoc (list dom widths fill) shr-content-cache))
(let ((data (shr-make-table-1 dom widths fill)))
(push (list (list dom widths fill) data)
shr-content-cache)
+ (when storage-attribute
+ (dom-set-attribute dom storage-attribute data))
data)))
(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
width colspan)
(dolist (row (dom-non-text-children dom))
(when (eq (dom-tag row) 'tr)
(let ((tds nil)
- (columns (dom-children row))
+ (columns (dom-non-text-children row))
(i 0)
(width-column 0)
column)
(setq width
(if column
(aref widths width-column)
- 10))
- (when (and fill
- (setq colspan (dom-attr column 'colspan)))
+ (* 10 shr-table-separator-pixel-width)))
+ (when (setq colspan (dom-attr column 'colspan))
(setq colspan (min (string-to-number colspan)
;; The colspan may be wrong, so
;; truncate it to the length of the
;; remaining columns.
(- (length widths) i)))
(dotimes (j (1- colspan))
- (if (> (+ i 1 j) (1- (length widths)))
- (setq width (aref widths (1- (length widths))))
- (setq width (+ width
- shr-table-separator-length
- (aref widths (+ i 1 j))))))
- (setq width-column (+ width-column (1- colspan))))
- (when (or column
- (not fill))
- (push (shr-render-td column width fill)
- tds))
+ (setq width
+ (if (> (+ i 1 j) (1- (length widths)))
+ ;; If we have a colspan spec that's longer
+ ;; than the table is wide, just use the last
+ ;; width as the width.
+ (aref widths (1- (length widths)))
+ ;; Sum up the widths of the columns we're
+ ;; spanning.
+ (+ width
+ shr-table-separator-length
+ (aref widths (+ i 1 j))))))
+ (setq width-column (+ width-column (1- colspan))
+ colspan-count colspan
+ colspan-remaining colspan))
+ (when column
+ (let ((data (shr-render-td column width fill)))
+ (if (and (not fill)
+ (> colspan-remaining 0))
+ (progn
+ (setq colspan-width (car data))
+ (let ((this-width (/ colspan-width colspan-count)))
+ (push (cons this-width (cadr data)) tds)
+ (setq colspan-remaining (1- colspan-remaining))))
+ (if (not fill)
+ (push (cons (car data) (cadr data)) tds)
+ (push data tds)))))
+ (when (and colspan
+ (> colspan 1))
+ (dotimes (c (1- colspan))
+ (setq i (1+ i))
+ (push
+ (if fill
+ (list 0 0 -1 nil 1 nil nil)
+ '(0 . 0))
+ tds)))
(setq i (1+ i)
width-column (1+ width-column))))
(push (nreverse tds) trs))))
(nreverse trs)))
+(defun shr-pixel-buffer-width ()
+ (if (not shr-use-fonts)
+ (save-excursion
+ (goto-char (point-min))
+ (let ((max 0))
+ (while (not (eobp))
+ (end-of-line)
+ (setq max (max max (current-column)))
+ (forward-line 1))
+ max))
+ (if (get-buffer-window)
+ (car (window-text-pixel-size nil (point-min) (point-max)))
+ (save-window-excursion
+ (set-window-buffer nil (current-buffer))
+ (car (window-text-pixel-size nil (point-min) (point-max)))))))
+
(defun shr-render-td (dom width fill)
+ (let ((cache (intern (format "shr-td-cache-%s-%s" width fill))))
+ (or (dom-attr dom cache)
+ (and fill
+ (let (result)
+ (dolist (attr (dom-attributes dom))
+ (let ((name (symbol-name (car attr))))
+ (when (string-match "shr-td-cache-\\([0-9]+\\)-nil" name)
+ (let ((cache-width (string-to-number
+ (match-string 1 name))))
+ (when (and (>= cache-width width)
+ (<= (car (cdr attr)) width))
+ (setq result (cdr attr)))))))
+ result))
+ (let ((result (shr-render-td-1 dom width fill)))
+ (dom-set-attribute dom cache result)
+ result))))
+
+(defun shr-render-td-1 (dom width fill)
(with-temp-buffer
(let ((bgcolor (dom-attr dom 'bgcolor))
(fgcolor (dom-attr dom 'fgcolor))
(style (dom-attr dom 'style))
(shr-stylesheet shr-stylesheet)
- actual-colors)
+ (max-width 0)
+ natural-width)
(when style
(setq style (and (string-match "color" style)
(shr-parse-style style))))
(when bgcolor
- (setq style (nconc (list (cons 'background-color bgcolor)) style)))
+ (setq style (nconc (list (cons 'background-color bgcolor))
+ style)))
(when fgcolor
(setq style (nconc (list (cons 'color fgcolor)) style)))
(when style
(let ((shr-internal-width width)
(shr-indentation 0))
(shr-descend dom))
+ (save-window-excursion
+ (set-window-buffer nil (current-buffer))
+ (unless fill
+ (setq natural-width
+ (or (dom-attr dom 'shr-td-cache-natural)
+ (let ((natural (max (shr-pixel-buffer-width)
+ (shr-dom-max-natural-width dom 0))))
+ (dom-set-attribute dom 'shr-td-cache-natural natural)
+ natural))))
+ (if (and natural-width
+ (<= natural-width width))
+ (setq max-width natural-width)
+ (let ((shr-internal-width width))
+ (shr-fill-lines (point-min) (point-max))
+ (setq max-width (shr-pixel-buffer-width)))))
+ (goto-char (point-max))
;; Delete padding at the bottom of the TDs.
(delete-region
(point)
(end-of-line)
(point)))
(goto-char (point-min))
- (let ((max 0))
- (while (not (eobp))
- (end-of-line)
- (setq max (max max (current-column)))
- (forward-line 1))
- (when fill
- (goto-char (point-min))
- ;; If the buffer is totally empty, then put a single blank
- ;; line here.
- (if (zerop (buffer-size))
- (insert (make-string width ? ))
- ;; Otherwise, fill the buffer.
- (let ((align (dom-attr dom 'align))
- length)
- (while (not (eobp))
- (end-of-line)
- (setq length (- width (current-column)))
- (when (> length 0)
- (cond
- ((equal align "right")
- (beginning-of-line)
- (insert (make-string length ? )))
- ((equal align "center")
- (insert (make-string (/ length 2) ? ))
- (beginning-of-line)
- (insert (make-string (- length (/ length 2)) ? )))
- (t
- (insert (make-string length ? )))))
- (forward-line 1))))
- (when style
- (setq actual-colors
- (shr-colorize-region
- (point-min) (point-max)
- (cdr (assq 'color shr-stylesheet))
- (cdr (assq 'background-color shr-stylesheet))))))
- (if fill
- (list max
- (count-lines (point-min) (point-max))
- (split-string (buffer-string) "\n")
- nil
- (car actual-colors))
- max)))))
+ (list max-width
+ natural-width
+ (count-lines (point-min) (point-max))
+ (split-string (buffer-string) "\n")
+ (if (dom-attr dom 'colspan)
+ (string-to-number (dom-attr dom 'colspan))
+ 1)
+ (cdr (assq 'color shr-stylesheet))
+ (cdr (assq 'background-color shr-stylesheet))))))
+
+(defun shr-dom-max-natural-width (dom max)
+ (if (eq (dom-tag dom) 'table)
+ (max max (or
+ (loop for line in (dom-attr dom 'shr-suggested-widths)
+ maximize (+
+ shr-table-separator-length
+ (loop for elem in line
+ summing
+ (+ (cdr elem)
+ (* 2 shr-table-separator-length)))))
+ 0))
+ (dolist (child (dom-children dom))
+ (unless (stringp child)
+ (setq max (max (shr-dom-max-natural-width child max)))))
+ max))
(defun shr-buffer-width ()
(goto-char (point-min))
(aset widths i (max (truncate (* (aref columns i)
total-percentage
(- shr-internal-width
- (1+ (length columns)))))
+ (* (1+ (length columns))
+ shr-table-separator-pixel-width))))
10)))
widths))
(dolist (row (dom-non-text-children dom))
(when (eq (dom-tag row) 'tr)
(let ((i 0))
- (dolist (column (dom-children row))
- (when (and (not (stringp column))
- (memq (dom-tag column) '(td th)))
+ (dolist (column (dom-non-text-children row))
+ (when (memq (dom-tag column) '(td th))
(let ((width (dom-attr column 'width)))
(when (and width
(string-match "\\([0-9]+\\)%" width)
(provide 'shr)
-;; Local Variables:
-;; coding: utf-8
-;; End:
-
;;; shr.el ends here