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

78
lisp/net/shr.el
View file

@ -1895,65 +1895,61 @@ 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 else if (consp child)
do (setq tag (dom-tag child) do (setq tag (dom-tag child)) and
recurse t) unless (memq tag '(comment style))
and if (eq tag 'img)
if (eq tag 'tr) do (shr-tag-img child)
do (setq flags '(t . nil)) else if (eq tag 'object)
else if (memq tag '(td th)) do (shr-tag-object child)
when (car flags)
do (setq flags '(t . t))
end
else if (eq tag 'table)
if (cdr flags)
do (setq flags nil)
else else
do (setq recurse nil) do (setq recurse t) and
(shr-tag-table child) if (eq tag 'tr)
end do (setq flags '(t . nil))
else else if (memq tag '(td th))
when (memq tag '(comment style)) when (car flags)
do (setq recurse nil) do (setq flags '(t . t))
end end end end and end
when recurse else if (eq tag 'table)
append (shr-collect-extra-strings-in-table child flags))) if (cdr flags)
do (setq flags nil)
else
do (setq recurse nil)
(shr-tag-table child)
end end end end end end end end end
when recurse
append (shr-collect-extra-strings-in-table child flags)))
(defun shr-insert-table (table widths) (defun shr-insert-table (table widths)
(let* ((collapse (equal (cdr (assq 'border-collapse shr-stylesheet)) (let* ((collapse (equal (cdr (assq 'border-collapse shr-stylesheet))