procyberian/emacs
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

* lisp/net/shr.el (shr-tag-table): Avoid duplication of images.

Browse source 
(shr-collect-extra-strings-in-table): Render images as well.
This commit is contained in:
Katsumi Yamaoka 2016-11-14 06:48:06 +00:00
parent cbed42838e
commit 99e7b99e43
1 changed files with 37 additions and 41 deletions
Download patch file Download diff file Expand all files Collapse all files

50
lisp/net/shr.el
View file

@ -1895,46 +1895,46 @@ The preference is a float determined from `shr-prefer-media-type'."
bgcolor)) bgcolor))
;; Finally, insert all the images after the table. The Emacs buffer ;; Finally, insert all the images after the table. The Emacs buffer
;; model isn't strong enough to allow us to put the images actually ;; model isn't strong enough to allow us to put the images actually
;; into the tables. ;; into the tables. It inserts also non-td/th objects.
(when (zerop shr-table-depth) (when (zerop shr-table-depth)
(save-excursion (save-excursion
(shr-expand-alignments start (point))) (shr-expand-alignments start (point)))
;; Insert also non-td/th objects.
(save-restriction (save-restriction
(narrow-to-region (point) (point)) (narrow-to-region (point) (point))
(insert (mapconcat #'identity (insert (mapconcat #'identity
(shr-collect-extra-strings-in-table dom) (shr-collect-extra-strings-in-table dom)
"\n")) "\n"))
(shr-fill-lines (point-min) (point-max))) (shr-fill-lines (point-min) (point-max))))))
(dolist (elem (dom-by-tag dom 'object))
(shr-tag-object elem))
(dolist (elem (dom-by-tag dom 'img))
(shr-tag-img elem)))))
(defun shr-collect-extra-strings-in-table (dom &optional flags) (defun shr-collect-extra-strings-in-table (dom &optional flags)
"Return extra strings in DOM of which the root is a table clause. "Return extra strings in DOM of which the root is a table clause.
Render extra child tables of which the parent is not td or th as well. Render <img>s and <object>s, and strings and child <table>s of which
FLAGS is a cons of two boolean flags that control whether to collect the parent is not <td> or <th> as well. FLAGS is a cons of two
or render objects." boolean flags that control whether to collect or render objects."
;; Currently this function supports extra strings and <table>s that ;; As for strings and child <table>s, it runs recursively and
;; are children of <table> or <tr> clauses, not <td> nor <th>. ;; collects or renders those objects if the cdr of FLAGS is nil.
;; It runs recursively and collects strings or renders <table>s if ;; FLAGS becomes (t . nil) if a <tr> clause is found in the children
;; the cdr of FLAGS is nil. FLAGS becomes (t . nil) if a <tr> ;; of DOM, and becomes (t . t) if a <td> or a <th> clause is found
;; clause is found in the children of DOM, and becomes (t . t) if ;; and the car is t then. When a <table> clause is found, FLAGS
;; a <td> or a <th> clause is found and the car is t then. ;; becomes nil if the cdr is t then. But if the cdr is nil then,
;; When a <table> clause is found, FLAGS becomes nil if the cdr is t ;; it renders the <table>.
;; then. But if the cdr is nil then, render the <table>. (cl-loop for child in (dom-children dom) with recurse with tag
(cl-loop for child in (dom-children dom) with tag with recurse do (setq recurse nil)
if (stringp child) if (stringp child)
unless (cdr flags) unless (cdr flags)
when (string-match "\\(?:[^\t\n\r ]+[\t\n\r ]+\\)*[^\t\n\r ]+" when (string-match "\\(?:[^\t\n\r ]+[\t\n\r ]+\\)*[^\t\n\r ]+"
child) child)
collect (match-string 0 child) collect (match-string 0 child)
end end end end
else if (consp child)
do (setq tag (dom-tag child)) and
unless (memq tag '(comment style))
if (eq tag 'img)
do (shr-tag-img child)
else if (eq tag 'object)
do (shr-tag-object child)
else else
do (setq tag (dom-tag child) do (setq recurse t) and
recurse t)
and
if (eq tag 'tr) if (eq tag 'tr)
do (setq flags '(t . nil)) do (setq flags '(t . nil))
else if (memq tag '(td th)) else if (memq tag '(td th))
@ -1947,11 +1947,7 @@ or render objects."
else else
do (setq recurse nil) do (setq recurse nil)
(shr-tag-table child) (shr-tag-table child)
end end end end end end end end end end
else
when (memq tag '(comment style))
do (setq recurse nil)
end end end end and
when recurse when recurse
append (shr-collect-extra-strings-in-table child flags))) append (shr-collect-extra-strings-in-table child flags)))