;;; shr.el --- Simple HTML Renderer
-;; Copyright (C) 2010-2014 Free Software Foundation, Inc.
+;; Copyright (C) 2010-2015 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: html
(eval-when-compile (require 'cl))
(eval-when-compile (require 'url)) ;For url-filename's setf handler.
(require 'browse-url)
+(require 'subr-x)
+(require 'dom)
(defgroup shr nil
"Simple HTML Renderer"
- :version "24.1"
- :group 'hypermedia)
+ :version "25.1"
+ :group 'web)
(defcustom shr-max-image-proportion 0.9
"How big pictures displayed are in relation to the window they're in.
:group 'shr
:type 'character)
-(defcustom shr-width fill-column
+(defcustom shr-width nil
"Frame width to use for rendering.
May either be an integer specifying a fixed width in characters,
or nil, meaning that the full width of the window should be
used."
+ :version "25.1"
:type '(choice (integer :tag "Fixed width in characters")
(const :tag "Use the width of the window" nil))
:group 'shr)
"Font for link elements."
:group 'shr)
+(defvar shr-inhibit-images nil
+ "If non-nil, inhibit loading images.")
+
;;; Internal variables.
(defvar shr-folding-mode nil)
(defvar shr-state nil)
(defvar shr-start nil)
(defvar shr-indentation 0)
-(defvar shr-inhibit-images nil)
(defvar shr-internal-width (or shr-width (1- (window-width))))
(defvar shr-list-mode nil)
(defvar shr-content-cache nil)
(defvar shr-table-depth 0)
(defvar shr-stylesheet nil)
(defvar shr-base 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)
(shr-state nil)
(shr-start nil)
(shr-base nil)
+ (shr-depth 0)
+ (shr-warning nil)
(shr-internal-width (or shr-width (1- (window-width)))))
- (shr-descend (shr-transform-dom dom))
- (shr-remove-trailing-whitespace start (point))))
+ (shr-descend dom)
+ (shr-remove-trailing-whitespace start (point))
+ (when shr-warning
+ (message "%s" shr-warning))))
(defun shr-remove-trailing-whitespace (start end)
(let ((width (window-width)))
"Skip to the next link."
(interactive)
(let ((skip (text-property-any (point) (point-max) 'help-echo nil)))
- (if (not (setq skip (text-property-not-all skip (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")
(goto-char skip)
(message "%s" (get-text-property (point) 'help-echo)))))
(let ((text (get-text-property (point) 'shr-alt)))
(if (not text)
(message "No image under point")
- (message "%s" text))))
+ (message "%s" (shr-fold-text text)))))
(defun shr-browse-image (&optional copy-url)
"Browse the image under point.
;;; Utility functions.
-(defun shr-transform-dom (dom)
- (let ((result (list (pop dom))))
- (dolist (arg (pop dom))
- (push (cons (intern (concat ":" (symbol-name (car arg))) obarray)
- (cdr arg))
- result))
- (dolist (sub dom)
- (if (stringp sub)
- (push (cons 'text sub) result)
- (push (shr-transform-dom sub) result)))
- (nreverse result)))
-
-(defsubst shr-generic (cont)
- (dolist (sub cont)
- (cond
- ((eq (car sub) 'text)
- (shr-insert (cdr sub)))
- ((listp (cdr sub))
- (shr-descend sub)))))
+(defsubst shr-generic (dom)
+ (dolist (sub (dom-children dom))
+ (if (stringp sub)
+ (shr-insert sub)
+ (shr-descend sub))))
(defun shr-descend (dom)
(let ((function
(or
;; Allow other packages to override (or provide) rendering
;; of elements.
- (cdr (assq (car dom) shr-external-rendering-functions))
- (intern (concat "shr-tag-" (symbol-name (car dom))) obarray)))
- (style (cdr (assq :style (cdr dom))))
+ (cdr (assq (dom-tag dom) shr-external-rendering-functions))
+ (intern (concat "shr-tag-" (symbol-name (dom-tag dom))) obarray)))
+ (style (dom-attr dom 'style))
(shr-stylesheet shr-stylesheet)
+ (shr-depth (1+ shr-depth))
(start (point)))
- (when style
- (if (string-match "color\\|display\\|border-collapse" style)
- (setq shr-stylesheet (nconc (shr-parse-style style)
- shr-stylesheet))
- (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 (cdr dom))
- (shr-generic (cdr dom)))
- (when (and shr-target-id
- (equal (cdr (assq :id (cdr dom))) shr-target-id))
- ;; If the element was empty, we don't have anything to put the
- ;; anchor on. So just insert a dummy character.
- (when (= start (point))
- (insert "*"))
- (put-text-property start (1+ start) 'shr-target-id shr-target-id))
- ;; If style is set, then this node has set the color.
+ ;; shr uses about 12 frames per nested node.
+ (if (> shr-depth (/ max-specpdl-size 12))
+ (setq shr-warning "Too deeply nested to render properly; consider increasing `max-specpdl-size'")
(when style
- (shr-colorize-region start (point)
- (cdr (assq 'color shr-stylesheet))
- (cdr (assq 'background-color shr-stylesheet)))))))
-
-(defmacro shr-char-breakable-p (char)
+ (if (string-match "color\\|display\\|border-collapse" style)
+ (setq shr-stylesheet (nconc (shr-parse-style style)
+ shr-stylesheet))
+ (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))
+ (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
+ ;; anchor on. So just insert a dummy character.
+ (when (= start (point))
+ (insert "*"))
+ (put-text-property start (1+ start) 'shr-target-id shr-target-id))
+ ;; If style is set, then this node has set the color.
+ (when style
+ (shr-colorize-region
+ start (point)
+ (cdr (assq 'color shr-stylesheet))
+ (cdr (assq 'background-color shr-stylesheet))))))))
+
+(defun shr-fold-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-insert text)
+ (buffer-string)))))
+
+(define-inline shr-char-breakable-p (char)
"Return non-nil if a line can be broken before and after CHAR."
- `(aref fill-find-break-point-function-table ,char))
-(defmacro shr-char-nospace-p (char)
+ (inline-quote (aref fill-find-break-point-function-table ,char)))
+(define-inline shr-char-nospace-p (char)
"Return non-nil if no space is required before and after CHAR."
- `(aref fill-nospace-between-words-table ,char))
+ (inline-quote (aref fill-nospace-between-words-table ,char)))
;; KINSOKU is a Japanese word meaning a rule that should not be violated.
;; In Emacs, it is a term used for characters, e.g. punctuation marks,
;; parentheses, and so on, that should not be placed in the beginning
;; of a line or the end of a line.
-(defmacro shr-char-kinsoku-bol-p (char)
+(define-inline shr-char-kinsoku-bol-p (char)
"Return non-nil if a line ought not to begin with CHAR."
- `(let ((char ,char))
- (and (not (eq char ?'))
- (aref (char-category-set char) ?>))))
-(defmacro shr-char-kinsoku-eol-p (char)
+ (inline-letevals (char)
+ (inline-quote (and (not (eq ,char ?'))
+ (aref (char-category-set ,char) ?>)))))
+(define-inline shr-char-kinsoku-eol-p (char)
"Return non-nil if a line ought not to end with CHAR."
- `(aref (char-category-set ,char) ?<))
+ (inline-quote (aref (char-category-set ,char) ?<)))
(unless (shr-char-kinsoku-bol-p (make-char 'japanese-jisx0208 33 35))
(load "kinsoku" nil t))
;; Always chop off anchors.
(when (string-match "#.*" url)
(setq url (substring url 0 (match-beginning 0))))
+ ;; NB: <base href="" > URI may itself be relative to the document s URI
+ (setq url (shr-expand-url url))
(let* ((parsed (url-generic-parse-url url))
(local (url-filename parsed)))
(setf (url-filename parsed) "")
(defun shr-expand-url (url &optional base)
(setq base
(if base
+ ;; shr-parse-base should never call this with non-nil base!
(shr-parse-base base)
;; Bound by the parser.
shr-base))
(cond ((or (not url)
(not base)
(string-match "\\`[a-z]*:" url))
- ;; Absolute URL.
- (or url (car base)))
+ ;; Absolute or empty URI
+ (or url (nth 3 base)))
((eq (aref url 0) ?/)
(if (and (> (length url) 1)
(eq (aref url 1) ?/))
(when (> shr-indentation 0)
(insert (make-string shr-indentation ? ))))
-(defun shr-fontize-cont (cont &rest types)
+(defun shr-fontize-dom (dom &rest types)
(let (shr-start)
- (shr-generic cont)
+ (shr-generic dom)
(dolist (type types)
(shr-add-font (or shr-start (point)) (point) type))))
((eq size 'original)
(create-image data nil t :ascent 100
:format content-type))
+ ((eq content-type 'image/svg+xml)
+ (create-image data 'svg t :ascent 100))
((eq size 'full)
(ignore-errors
(shr-rescale-image data content-type)))
(shr-parse-image-data)))))
(defun shr-parse-image-data ()
- (list
- (buffer-substring (point) (point-max))
- (save-excursion
- (save-restriction
- (narrow-to-region (point-min) (point))
- (let ((content-type (mail-fetch-field "content-type")))
- (and content-type
- (intern content-type obarray)))))))
+ (let ((data (buffer-substring (point) (point-max)))
+ (content-type
+ (save-excursion
+ (save-restriction
+ (narrow-to-region (point-min) (point))
+ (let ((content-type (mail-fetch-field "content-type")))
+ (and content-type
+ ;; Remove any comments in the type string.
+ (intern (replace-regexp-in-string ";.*" "" content-type)
+ obarray)))))))
+ ;; SVG images may contain references to further images that we may
+ ;; want to block. So special-case these by parsing the XML data
+ ;; and remove the blocked bits.
+ (when (eq content-type 'image/svg+xml)
+ (setq data
+ (shr-dom-to-xml
+ (libxml-parse-xml-region (point) (point-max)))))
+ (list data content-type)))
(defun shr-image-displayer (content-function)
"Return a function to display an image.
(list (current-buffer) start end)
t t)))))
-(defun shr-heading (cont &rest types)
+(defun shr-heading (dom &rest types)
(shr-ensure-paragraph)
- (apply #'shr-fontize-cont cont types)
+ (apply #'shr-fontize-dom dom types)
(shr-ensure-paragraph))
(defun shr-urlify (start url &optional title)
(add-text-properties
start (point)
(list 'shr-url url
- 'help-echo (if title (format "%s (%s)" url title) url)
+ 'help-echo (if title (shr-fold-text (format "%s (%s)" url title)) url)
'follow-link t
'mouse-face 'highlight
'keymap shr-map)))
;;; Tag-specific rendering rules.
-(defun shr-tag-body (cont)
+(defun shr-tag-body (dom)
(let* ((start (point))
- (fgcolor (cdr (or (assq :fgcolor cont)
- (assq :text cont))))
- (bgcolor (cdr (assq :bgcolor cont)))
+ (fgcolor (or (dom-attr dom 'fgcolor) (dom-attr dom 'text)))
+ (bgcolor (dom-attr dom 'bgcolor))
(shr-stylesheet (list (cons 'color fgcolor)
(cons 'background-color bgcolor))))
- (shr-generic cont)
+ (shr-generic dom)
(shr-colorize-region start (point) fgcolor bgcolor)))
-(defun shr-tag-style (_cont)
+(defun shr-tag-style (_dom)
)
-(defun shr-tag-script (_cont)
+(defun shr-tag-script (_dom)
)
-(defun shr-tag-comment (_cont)
+(defun shr-tag-comment (_dom)
)
(defun shr-dom-to-xml (dom)
+ (with-temp-buffer
+ (shr-dom-print dom)
+ (buffer-string)))
+
+(defun shr-dom-print (dom)
"Convert DOM into a string containing the xml representation."
- (let ((arg " ")
- (text "")
- url)
- (dolist (sub (cdr dom))
+ (insert (format "<%s" (dom-tag dom)))
+ (dolist (attr (dom-attributes dom))
+ ;; Ignore attributes that start with a colon because they are
+ ;; private elements.
+ (unless (= (aref (format "%s" (car attr)) 0) ?:)
+ (insert (format " %s=\"%s\"" (car attr) (cdr attr)))))
+ (insert ">")
+ (let (url)
+ (dolist (elem (dom-children dom))
(cond
- ((listp (cdr sub))
- ;; Ignore external image definitions if required.
- ;; <image xlink:href="http://TRACKING_URL/"/>
- (when (or (not (eq (car sub) 'image))
- (not (setq url (cdr (assq ':xlink:href (cdr sub)))))
- (not shr-blocked-images)
- (not (string-match shr-blocked-images url)))
- (setq text (concat text (shr-dom-to-xml sub)))))
- ((eq (car sub) 'text)
- (setq text (concat text (cdr sub))))
- (t
- (setq arg (concat arg (format "%s=\"%s\" "
- (substring (symbol-name (car sub)) 1)
- (cdr sub)))))))
- (format "<%s%s>%s</%s>"
- (car dom)
- (substring arg 0 (1- (length arg)))
- text
- (car dom))))
-
-(defun shr-tag-svg (cont)
+ ((stringp elem)
+ (insert elem))
+ ((eq (dom-tag elem) 'comment)
+ )
+ ((or (not (eq (dom-tag elem) 'image))
+ ;; Filter out blocked elements inside the SVG image.
+ (not (setq url (dom-attr elem ':xlink:href)))
+ (not shr-blocked-images)
+ (not (string-match shr-blocked-images url)))
+ (insert " ")
+ (shr-dom-print elem)))))
+ (insert (format "</%s>" (dom-tag dom))))
+
+(defun shr-tag-svg (dom)
(when (and (image-type-available-p 'svg)
(not shr-inhibit-images))
- (funcall shr-put-image-function
- (shr-dom-to-xml (cons 'svg cont))
- "SVG Image")))
+ (funcall shr-put-image-function (list (shr-dom-to-xml dom) 'image/svg+xml)
+ "SVG Image")))
-(defun shr-tag-sup (cont)
+(defun shr-tag-sup (dom)
(let ((start (point)))
- (shr-generic cont)
+ (shr-generic dom)
(put-text-property start (point) 'display '(raise 0.5))))
-(defun shr-tag-sub (cont)
+(defun shr-tag-sub (dom)
(let ((start (point)))
- (shr-generic cont)
+ (shr-generic dom)
(put-text-property start (point) 'display '(raise -0.5))))
-(defun shr-tag-label (cont)
- (shr-generic cont)
+(defun shr-tag-label (dom)
+ (shr-generic dom)
(shr-ensure-paragraph))
-(defun shr-tag-p (cont)
+(defun shr-tag-p (dom)
(shr-ensure-paragraph)
(shr-indent)
- (shr-generic cont)
+ (shr-generic dom)
(shr-ensure-paragraph))
-(defun shr-tag-div (cont)
+(defun shr-tag-div (dom)
(shr-ensure-newline)
(shr-indent)
- (shr-generic cont)
+ (shr-generic dom)
(shr-ensure-newline))
-(defun shr-tag-s (cont)
- (shr-fontize-cont cont 'shr-strike-through))
+(defun shr-tag-s (dom)
+ (shr-fontize-dom dom 'shr-strike-through))
-(defun shr-tag-del (cont)
- (shr-fontize-cont cont 'shr-strike-through))
+(defun shr-tag-del (dom)
+ (shr-fontize-dom dom 'shr-strike-through))
-(defun shr-tag-b (cont)
- (shr-fontize-cont cont 'bold))
+(defun shr-tag-b (dom)
+ (shr-fontize-dom dom 'bold))
-(defun shr-tag-i (cont)
- (shr-fontize-cont cont 'italic))
+(defun shr-tag-i (dom)
+ (shr-fontize-dom dom 'italic))
-(defun shr-tag-em (cont)
- (shr-fontize-cont cont 'italic))
+(defun shr-tag-em (dom)
+ (shr-fontize-dom dom 'italic))
-(defun shr-tag-strong (cont)
- (shr-fontize-cont cont 'bold))
+(defun shr-tag-strong (dom)
+ (shr-fontize-dom dom 'bold))
-(defun shr-tag-u (cont)
- (shr-fontize-cont cont 'underline))
+(defun shr-tag-u (dom)
+ (shr-fontize-dom dom 'underline))
(defun shr-parse-style (style)
(when style
plist)))))
plist)))
-(defun shr-tag-base (cont)
- (let ((base (cdr (assq :href cont))))
- (when base
- (setq shr-base (shr-parse-base base))))
- (shr-generic cont))
+(defun shr-tag-base (dom)
+ (when-let (base (dom-attr dom 'href))
+ (setq shr-base (shr-parse-base base)))
+ (shr-generic dom))
-(defun shr-tag-a (cont)
- (let ((url (cdr (assq :href cont)))
- (title (cdr (assq :title cont)))
+(defun shr-tag-a (dom)
+ (let ((url (dom-attr dom 'href))
+ (title (dom-attr dom 'title))
(start (point))
shr-start)
- (shr-generic cont)
+ (shr-generic dom)
(when (and shr-target-id
- (equal (cdr (assq :name cont)) shr-target-id))
+ (equal (dom-attr dom 'name) shr-target-id))
;; We have a zero-length <a name="foo"> element, so just
;; insert... something.
(when (= start (point))
(not shr-inhibit-decoration))
(shr-urlify (or shr-start start) (shr-expand-url url) title))))
-(defun shr-tag-object (cont)
- (let ((start (point))
- url)
- (dolist (elem cont)
- (when (eq (car elem) 'embed)
- (setq url (or url (cdr (assq :src (cdr elem))))))
- (when (and (eq (car elem) 'param)
- (equal (cdr (assq :name (cdr elem))) "movie"))
- (setq url (or url (cdr (assq :value (cdr elem)))))))
- (when url
- (shr-insert " [multimedia] ")
- (shr-urlify start (shr-expand-url url)))
- (shr-generic cont)))
+(defun shr-tag-object (dom)
+ (unless shr-inhibit-images
+ (let ((start (point))
+ url multimedia image)
+ (when-let (type (dom-attr dom 'type))
+ (when (string-match "\\`image/svg" type)
+ (setq url (dom-attr dom 'data)
+ image t)))
+ (dolist (child (dom-non-text-children dom))
+ (cond
+ ((eq (dom-tag child) 'embed)
+ (setq url (or url (dom-attr child 'src))
+ multimedia t))
+ ((and (eq (dom-tag child) 'param)
+ (equal (dom-attr child 'name) "movie"))
+ (setq url (or url (dom-attr child 'value))
+ multimedia t))))
+ (when url
+ (cond
+ (image
+ (shr-tag-img dom url)
+ (setq dom nil))
+ (multimedia
+ (shr-insert " [multimedia] ")
+ (shr-urlify start (shr-expand-url url)))))
+ (when dom
+ (shr-generic dom)))))
(defcustom shr-prefer-media-type-alist '(("webm" . 1.0)
("ogv" . 1.0)
(defun shr--get-media-pref (elem)
"Determine the preference for ELEM.
The preference is a float determined from `shr-prefer-media-type'."
- (let ((type (cdr (assq :type elem)))
+ (let ((type (dom-attr elem 'type))
(p 0.0))
(unless type
- (setq type (cdr (assq :src elem))))
+ (setq type (dom-attr elem 'src)))
(when type
(dolist (pref shr-prefer-media-type-alist)
(when (and
(setq p (cdr pref)))))
p))
-(defun shr--extract-best-source (cont &optional url pref)
- "Extract the best `:src' property from <source> blocks in CONT."
+(defun shr--extract-best-source (dom &optional url pref)
+ "Extract the best `:src' property from <source> blocks in DOM."
(setq pref (or pref -1.0))
(let (new-pref)
- (dolist (elem cont)
- (when (and (eq (car elem) 'source)
+ (dolist (elem (dom-non-text-children dom))
+ (when (and (eq (dom-tag elem) 'source)
(< pref
(setq new-pref
(shr--get-media-pref elem))))
(setq pref new-pref
- url (cdr (assq :src elem)))
+ url (dom-attr elem 'src))
;; libxml's html parser isn't HTML5 compliant and non terminated
;; source tags might end up as children. So recursion it is...
- (dolist (child (cdr elem))
- (when (eq (car child) 'source)
+ (dolist (child (dom-non-text-children elem))
+ (when (eq (dom-tag child) 'source)
(let ((ret (shr--extract-best-source (list child) url pref)))
(when (< pref (cdr ret))
(setq url (car ret)
pref (cdr ret)))))))))
(cons url pref))
-(defun shr-tag-video (cont)
- (let ((image (cdr (assq :poster cont)))
- (url (cdr (assq :src cont)))
+(defun shr-tag-video (dom)
+ (let ((image (dom-attr dom 'poster))
+ (url (dom-attr dom 'src))
(start (point)))
(unless url
- (setq url (car (shr--extract-best-source cont))))
+ (setq url (car (shr--extract-best-source dom))))
(if image
(shr-tag-img nil image)
(shr-insert " [video] "))
(shr-urlify start (shr-expand-url url))))
-(defun shr-tag-audio (cont)
- (let ((url (cdr (assq :src cont)))
+(defun shr-tag-audio (dom)
+ (let ((url (dom-attr dom 'src))
(start (point)))
(unless url
- (setq url (car (shr--extract-best-source cont))))
+ (setq url (car (shr--extract-best-source dom))))
(shr-insert " [audio] ")
(shr-urlify start (shr-expand-url url))))
-(defun shr-tag-img (cont &optional url)
+(defun shr-tag-img (dom &optional url)
(when (or url
- (and cont
- (> (length (cdr (assq :src cont))) 0)))
+ (and dom
+ (> (length (dom-attr dom 'src)) 0)))
(when (and (> (current-column) 0)
(not (eq shr-state 'image)))
(insert "\n"))
- (let ((alt (cdr (assq :alt cont)))
- (url (shr-expand-url (or url (cdr (assq :src cont))))))
+ (let ((alt (dom-attr dom 'alt))
+ (url (shr-expand-url (or url (dom-attr dom 'src)))))
(let ((start (point-marker)))
(when (zerop (length alt))
(setq alt "*"))
(cond
- ((or (member (cdr (assq :height cont)) '("0" "1"))
- (member (cdr (assq :width cont)) '("0" "1")))
+ ((or (member (dom-attr dom 'height) '("0" "1"))
+ (member (dom-attr dom 'width) '("0" "1")))
;; Ignore zero-sized or single-pixel images.
)
((and (not shr-inhibit-images)
(put-text-property start (point) 'image-displayer
(shr-image-displayer shr-content-function))
(put-text-property start (point) 'help-echo
- (or (cdr (assq :title cont))
- alt)))
+ (shr-fold-text (or (dom-attr dom 'title) alt))))
(setq shr-state 'image)))))
-(defun shr-tag-pre (cont)
+(defun shr-tag-pre (dom)
(let ((shr-folding-mode 'none))
(shr-ensure-newline)
(shr-indent)
- (shr-generic cont)
+ (shr-generic dom)
(shr-ensure-newline)))
-(defun shr-tag-blockquote (cont)
+(defun shr-tag-blockquote (dom)
(shr-ensure-paragraph)
(shr-indent)
(let ((shr-indentation (+ shr-indentation 4)))
- (shr-generic cont))
+ (shr-generic dom))
(shr-ensure-paragraph))
-(defun shr-tag-dl (cont)
+(defun shr-tag-dl (dom)
(shr-ensure-paragraph)
- (shr-generic cont)
+ (shr-generic dom)
(shr-ensure-paragraph))
-(defun shr-tag-dt (cont)
+(defun shr-tag-dt (dom)
(shr-ensure-newline)
- (shr-generic cont)
+ (shr-generic dom)
(shr-ensure-newline))
-(defun shr-tag-dd (cont)
+(defun shr-tag-dd (dom)
(shr-ensure-newline)
(let ((shr-indentation (+ shr-indentation 4)))
- (shr-generic cont)))
+ (shr-generic dom)))
-(defun shr-tag-ul (cont)
+(defun shr-tag-ul (dom)
(shr-ensure-paragraph)
(let ((shr-list-mode 'ul))
- (shr-generic cont))
+ (shr-generic dom))
(shr-ensure-paragraph))
-(defun shr-tag-ol (cont)
+(defun shr-tag-ol (dom)
(shr-ensure-paragraph)
(let ((shr-list-mode 1))
- (shr-generic cont))
+ (shr-generic dom))
(shr-ensure-paragraph))
-(defun shr-tag-li (cont)
+(defun shr-tag-li (dom)
(shr-ensure-newline)
(shr-indent)
(let* ((bullet
shr-bullet))
(shr-indentation (+ shr-indentation (length bullet))))
(insert bullet)
- (shr-generic cont)))
+ (shr-generic dom)))
-(defun shr-tag-br (cont)
+(defun shr-tag-br (dom)
(when (and (not (bobp))
;; Only add a newline if we break the current line, or
;; the previous line isn't a blank line.
(not (= (char-after (- (point) 2)) ?\n)))))
(insert "\n")
(shr-indent))
- (shr-generic cont))
+ (shr-generic dom))
-(defun shr-tag-span (cont)
- (shr-generic cont))
+(defun shr-tag-span (dom)
+ (shr-generic dom))
-(defun shr-tag-h1 (cont)
- (shr-heading cont 'bold 'underline))
+(defun shr-tag-h1 (dom)
+ (shr-heading dom 'bold 'underline))
-(defun shr-tag-h2 (cont)
- (shr-heading cont 'bold))
+(defun shr-tag-h2 (dom)
+ (shr-heading dom 'bold))
-(defun shr-tag-h3 (cont)
- (shr-heading cont 'italic))
+(defun shr-tag-h3 (dom)
+ (shr-heading dom 'italic))
-(defun shr-tag-h4 (cont)
- (shr-heading cont))
+(defun shr-tag-h4 (dom)
+ (shr-heading dom))
-(defun shr-tag-h5 (cont)
- (shr-heading cont))
+(defun shr-tag-h5 (dom)
+ (shr-heading dom))
-(defun shr-tag-h6 (cont)
- (shr-heading cont))
+(defun shr-tag-h6 (dom)
+ (shr-heading dom))
-(defun shr-tag-hr (_cont)
+(defun shr-tag-hr (_dom)
(shr-ensure-newline)
(insert (make-string shr-internal-width shr-hr-line) "\n"))
-(defun shr-tag-title (cont)
- (shr-heading cont 'bold 'underline))
+(defun shr-tag-title (dom)
+ (shr-heading dom 'bold 'underline))
-(defun shr-tag-font (cont)
+(defun shr-tag-font (dom)
(let* ((start (point))
- (color (cdr (assq :color cont)))
+ (color (dom-attr dom 'color))
(shr-stylesheet (nconc (list (cons 'color color))
shr-stylesheet)))
- (shr-generic cont)
+ (shr-generic dom)
(when color
(shr-colorize-region start (point) color
(cdr (assq 'background-color shr-stylesheet))))))
;; main buffer). Now we know how much space each TD really takes, so
;; we then render everything again with the new widths, and finally
;; insert all these boxes into the main buffer.
-(defun shr-tag-table-1 (cont)
- (setq cont (or (cdr (assq 'tbody cont))
- cont))
+(defun shr-tag-table-1 (dom)
+ (setq dom (or (dom-child-by-tag dom 'tbody) dom))
(let* ((shr-inhibit-images t)
(shr-table-depth (1+ shr-table-depth))
(shr-kinsoku-shorten t)
;; Find all suggested widths.
- (columns (shr-column-specs cont))
+ (columns (shr-column-specs dom))
;; Compute how many characters 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 cont suggested-widths))
+ (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 cont (make-vector (length columns) 500)))
+ (natural (shr-make-table dom (make-vector (length columns) 500)))
(sketch-widths (shr-table-widths sketch natural suggested-widths)))
;; This probably won't work very well.
(when (> (+ (loop for width across sketch-widths
(frame-width))
(setq truncate-lines t))
;; Then render the table again with these new "hard" widths.
- (shr-insert-table (shr-make-table cont sketch-widths t) sketch-widths)))
+ (shr-insert-table (shr-make-table dom sketch-widths t) sketch-widths)))
-(defun shr-tag-table (cont)
+(defun shr-tag-table (dom)
(shr-ensure-paragraph)
- (let* ((caption (cdr (assq 'caption cont)))
- (header (cdr (assq 'thead cont)))
- (body (or (cdr (assq 'tbody cont)) cont))
- (footer (cdr (assq 'tfoot cont)))
- (bgcolor (cdr (assq :bgcolor cont)))
+ (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)))
+ (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))
(nfooter (if footer (shr-max-columns footer))))
(if (and (not caption)
(not header)
- (not (cdr (assq 'tbody cont)))
- (not (cdr (assq 'tr cont)))
+ (not (dom-child-by-tag dom 'tbody))
+ (not (dom-child-by-tag dom 'tr))
(not footer))
;; The table is totally invalid and just contains random junk.
;; Try to output it anyway.
- (shr-generic cont)
+ (shr-generic dom)
;; It's a real table, so render it.
(shr-tag-table-1
(nconc
- (if caption `((tr (td ,@caption))))
- (if header
- (if footer
- ;; header + body + footer
- (if (= nheader nbody)
- (if (= nbody nfooter)
- `((tr (td (table (tbody ,@header ,@body ,@footer)))))
- (nconc `((tr (td (table (tbody ,@header ,@body)))))
- (if (= nfooter 1)
- footer
- `((tr (td (table (tbody ,@footer))))))))
- (nconc `((tr (td (table (tbody ,@header)))))
- (if (= nbody nfooter)
- `((tr (td (table (tbody ,@body ,@footer)))))
- (nconc `((tr (td (table (tbody ,@body)))))
- (if (= nfooter 1)
- footer
- `((tr (td (table (tbody ,@footer))))))))))
- ;; header + body
- (if (= nheader nbody)
- `((tr (td (table (tbody ,@header ,@body)))))
- (if (= nheader 1)
- `(,@header (tr (td (table (tbody ,@body)))))
- `((tr (td (table (tbody ,@header))))
- (tr (td (table (tbody ,@body))))))))
- (if footer
- ;; body + footer
- (if (= nbody nfooter)
- `((tr (td (table (tbody ,@body ,@footer)))))
- (nconc `((tr (td (table (tbody ,@body)))))
- (if (= nfooter 1)
- footer
- `((tr (td (table (tbody ,@footer))))))))
- (if caption
- `((tr (td (table (tbody ,@body)))))
- body))))))
+ (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
+ ,@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)))))
(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)
- (dolist (elem (shr-find-elements cont 'img))
- (shr-tag-img (cdr elem))))))
-
-(defun shr-find-elements (cont type)
- (let (result)
- (dolist (elem cont)
- (cond ((eq (car elem) type)
- (push elem result))
- ((consp (cdr elem))
- (setq result (nconc (shr-find-elements (cdr elem) type) result)))))
- (nreverse result)))
+ (dolist (elem (dom-by-tag dom 'object))
+ (shr-tag-object elem))
+ (dolist (elem (dom-by-tag dom 'img))
+ (shr-tag-img elem)))))
(defun shr-insert-table (table widths)
(let* ((collapse (equal (cdr (assq 'border-collapse shr-stylesheet))
(aref widths i))))))))
widths))
-(defun shr-make-table (cont widths &optional fill)
- (or (cadr (assoc (list cont widths fill) shr-content-cache))
- (let ((data (shr-make-table-1 cont widths fill)))
- (push (list (list cont widths fill) data)
+(defun shr-make-table (dom widths &optional fill)
+ (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)
data)))
-(defun shr-make-table-1 (cont widths &optional fill)
+(defun shr-make-table-1 (dom widths &optional fill)
(let ((trs nil)
(shr-inhibit-decoration (not fill))
(rowspans (make-vector (length widths) 0))
width colspan)
- (dolist (row cont)
- (when (eq (car row) 'tr)
+ (dolist (row (dom-non-text-children dom))
+ (when (eq (dom-tag row) 'tr)
(let ((tds nil)
- (columns (cdr row))
+ (columns (dom-children row))
(i 0)
(width-column 0)
column)
(pop columns)
(aset rowspans i (1- (aref rowspans i)))
'(td)))
- (when (or (memq (car column) '(td th))
- (not column))
- (when (cdr (assq :rowspan (cdr column)))
+ (when (and (not (stringp column))
+ (or (memq (dom-tag column) '(td th))
+ (not column)))
+ (when-let (span (dom-attr column 'rowspan))
(aset rowspans i (+ (aref rowspans i)
- (1- (string-to-number
- (cdr (assq :rowspan (cdr column))))))))
+ (1- (string-to-number span)))))
;; Sanity check for invalid column-spans.
(when (>= width-column (length widths))
(setq width-column 0))
(aref widths width-column)
10))
(when (and fill
- (setq colspan (cdr (assq :colspan (cdr column)))))
+ (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
(setq width-column (+ width-column (1- colspan))))
(when (or column
(not fill))
- (push (shr-render-td (cdr column) width fill)
+ (push (shr-render-td column width fill)
tds))
(setq i (1+ i)
width-column (1+ width-column))))
(push (nreverse tds) trs))))
(nreverse trs)))
-(defun shr-render-td (cont width fill)
+(defun shr-render-td (dom width fill)
(with-temp-buffer
- (let ((bgcolor (cdr (assq :bgcolor cont)))
- (fgcolor (cdr (assq :fgcolor cont)))
- (style (cdr (assq :style cont)))
+ (let ((bgcolor (dom-attr dom 'bgcolor))
+ (fgcolor (dom-attr dom 'fgcolor))
+ (style (dom-attr dom 'style))
(shr-stylesheet shr-stylesheet)
actual-colors)
(when style
(setq shr-stylesheet (append style shr-stylesheet)))
(let ((shr-internal-width width)
(shr-indentation 0))
- (shr-descend (cons 'td cont)))
+ (shr-descend dom))
;; Delete padding at the bottom of the TDs.
(delete-region
(point)
(if (zerop (buffer-size))
(insert (make-string width ? ))
;; Otherwise, fill the buffer.
- (let ((align (cdr (assq :align cont)))
+ (let ((align (dom-attr dom 'align))
length)
(while (not (eobp))
(end-of-line)
widths))
;; Return a summary of the number and shape of the TDs in the table.
-(defun shr-column-specs (cont)
- (let ((columns (make-vector (shr-max-columns cont) 1)))
- (dolist (row cont)
- (when (eq (car row) 'tr)
+(defun shr-column-specs (dom)
+ (let ((columns (make-vector (shr-max-columns dom) 1)))
+ (dolist (row (dom-non-text-children dom))
+ (when (eq (dom-tag row) 'tr)
(let ((i 0))
- (dolist (column (cdr row))
- (when (memq (car column) '(td th))
- (let ((width (cdr (assq :width (cdr column)))))
+ (dolist (column (dom-children row))
+ (when (and (not (stringp column))
+ (memq (dom-tag column) '(td th)))
+ (let ((width (dom-attr column 'width)))
(when (and width
(string-match "\\([0-9]+\\)%" width)
(not (zerop (setq width (string-to-number
(setq i (1+ i)))))))
columns))
-(defun shr-count (cont elem)
+(defun shr-count (dom elem)
(let ((i 0))
- (dolist (sub cont)
- (when (eq (car sub) elem)
+ (dolist (sub (dom-children dom))
+ (when (and (not (stringp sub))
+ (eq (dom-tag sub) elem))
(setq i (1+ i))))
i))
-(defun shr-max-columns (cont)
+(defun shr-max-columns (dom)
(let ((max 0))
- (dolist (row cont)
- (when (eq (car row) 'tr)
- (setq max (max max (+ (shr-count (cdr row) 'td)
- (shr-count (cdr row) 'th))))))
+ (dolist (row (dom-children dom))
+ (when (and (not (stringp row))
+ (eq (dom-tag row) 'tr))
+ (setq max (max max (+ (shr-count row 'td)
+ (shr-count row 'th))))))
max))
(provide 'shr)