aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorLars Magne Ingebrigtsen2014-11-26 19:41:13 +0100
committerLars Magne Ingebrigtsen2014-11-26 19:42:29 +0100
commitd9ba097fe4c17ed77e730c627f85ee0ed94da294 (patch)
tree9c9409293ea88edde98bda1668468734045bcae7
parent115178cd46b10383a12bd865739d0d55eea20251 (diff)
downloademacs-d9ba097fe4c17ed77e730c627f85ee0ed94da294.tar.gz
emacs-d9ba097fe4c17ed77e730c627f85ee0ed94da294.zip
Use the new dom.el accessors in shr and eww
* net/shr.el: Ditto. * net/eww.el: Use the new dom.el accessors throughout.
-rw-r--r--lisp/net/eww.el240
-rw-r--r--lisp/net/shr.el483
2 files changed, 327 insertions, 396 deletions
diff --git a/lisp/net/eww.el b/lisp/net/eww.el
index 97939cb611a..f9be0b6521f 100644
--- a/lisp/net/eww.el
+++ b/lisp/net/eww.el
@@ -406,38 +406,38 @@ See the `eww-search-prefix' variable for the search engine used."
406 (setq eww-history-position 0) 406 (setq eww-history-position 0)
407 (eww-update-header-line-format)))) 407 (eww-update-header-line-format))))
408 408
409(defun eww-handle-link (cont) 409(defun eww-handle-link (dom)
410 (let* ((rel (assq :rel cont)) 410 (let* ((rel (dom-attr dom 'rel))
411 (href (assq :href cont)) 411 (href (dom-attr dom 'href))
412 (where (assoc 412 (where (assoc
413 ;; The text associated with :rel is case-insensitive. 413 ;; The text associated with :rel is case-insensitive.
414 (if rel (downcase (cdr rel))) 414 (if rel (downcase rel))
415 '(("next" . :next) 415 '(("next" . :next)
416 ;; Texinfo uses "previous", but HTML specifies 416 ;; Texinfo uses "previous", but HTML specifies
417 ;; "prev", so recognize both. 417 ;; "prev", so recognize both.
418 ("previous" . :previous) 418 ("previous" . :previous)
419 ("prev" . :previous) 419 ("prev" . :previous)
420 ;; HTML specifies "start" but also "contents", 420 ;; HTML specifies "start" but also "contents",
421 ;; and Gtk seems to use "home". Recognize 421 ;; and Gtk seems to use "home". Recognize
422 ;; them all; but store them in different 422 ;; them all; but store them in different
423 ;; variables so that we can readily choose the 423 ;; variables so that we can readily choose the
424 ;; "best" one. 424 ;; "best" one.
425 ("start" . :start) 425 ("start" . :start)
426 ("home" . :home) 426 ("home" . :home)
427 ("contents" . :contents) 427 ("contents" . :contents)
428 ("up" . up))))) 428 ("up" . up)))))
429 (and href 429 (and href
430 where 430 where
431 (plist-put eww-data (cdr where) (cdr href))))) 431 (plist-put eww-data (cdr where) href))))
432 432
433(defun eww-tag-link (cont) 433(defun eww-tag-link (dom)
434 (eww-handle-link cont) 434 (eww-handle-link dom)
435 (shr-generic cont)) 435 (shr-generic dom))
436 436
437(defun eww-tag-a (cont) 437(defun eww-tag-a (dom)
438 (eww-handle-link cont) 438 (eww-handle-link dom)
439 (let ((start (point))) 439 (let ((start (point)))
440 (shr-tag-a cont) 440 (shr-tag-a dom)
441 (put-text-property start (point) 'keymap eww-link-keymap))) 441 (put-text-property start (point) 'keymap eww-link-keymap)))
442 442
443(defun eww-update-header-line-format () 443(defun eww-update-header-line-format ()
@@ -452,25 +452,24 @@ See the `eww-search-prefix' variable for the search engine used."
452 (?t . ,(or (plist-get eww-data :title) "")))))) 452 (?t . ,(or (plist-get eww-data :title) ""))))))
453 (setq header-line-format nil))) 453 (setq header-line-format nil)))
454 454
455(defun eww-tag-title (cont) 455(defun eww-tag-title (dom)
456 (let ((title "")) 456 (let ((title ""))
457 (dolist (sub cont) 457 (dolist (sub (dom-children dom))
458 (when (eq (car sub) 'text) 458 (when (stringp sub)
459 (setq title (concat title (cdr sub))))) 459 (setq title (concat title sub))))
460 (plist-put eww-data :title 460 (plist-put eww-data :title
461 (replace-regexp-in-string 461 (replace-regexp-in-string
462 "^ \\| $" "" 462 "^ \\| $" ""
463 (replace-regexp-in-string "[ \t\r\n]+" " " title)))) 463 (replace-regexp-in-string "[ \t\r\n]+" " " title))))
464 (eww-update-header-line-format)) 464 (eww-update-header-line-format))
465 465
466(defun eww-tag-body (cont) 466(defun eww-tag-body (dom)
467 (let* ((start (point)) 467 (let* ((start (point))
468 (fgcolor (cdr (or (assq :fgcolor cont) 468 (fgcolor (or (dom-attr dom 'fgcolor) (dom-attr dom 'text)))
469 (assq :text cont)))) 469 (bgcolor (dom-attr dom 'bgcolor))
470 (bgcolor (cdr (assq :bgcolor cont)))
471 (shr-stylesheet (list (cons 'color fgcolor) 470 (shr-stylesheet (list (cons 'color fgcolor)
472 (cons 'background-color bgcolor)))) 471 (cons 'background-color bgcolor))))
473 (shr-generic cont) 472 (shr-generic dom)
474 (shr-colorize-region start (point) fgcolor bgcolor))) 473 (shr-colorize-region start (point) fgcolor bgcolor)))
475 474
476(defun eww-display-raw (buffer &optional encode) 475(defun eww-display-raw (buffer &optional encode)
@@ -550,18 +549,16 @@ contains the main textual portion, leaving out navigation menus and
550the like." 549the like."
551 (interactive) 550 (interactive)
552 (let* ((old-data eww-data) 551 (let* ((old-data eww-data)
553 (dom (shr-transform-dom 552 (dom (with-temp-buffer
554 (with-temp-buffer 553 (insert (plist-get old-data :source))
555 (insert (plist-get old-data :source)) 554 (condition-case nil
556 (condition-case nil 555 (decode-coding-region (point-min) (point-max) 'utf-8)
557 (decode-coding-region (point-min) (point-max) 'utf-8) 556 (coding-system-error nil))
558 (coding-system-error nil)) 557 (libxml-parse-html-region (point-min) (point-max)))))
559 (libxml-parse-html-region (point-min) (point-max))))))
560 (eww-score-readability dom) 558 (eww-score-readability dom)
561 (eww-save-history) 559 (eww-save-history)
562 (eww-display-html nil nil 560 (eww-display-html nil nil
563 (shr-retransform-dom 561 (eww-highest-readability dom)
564 (eww-highest-readability dom))
565 nil (current-buffer)) 562 nil (current-buffer))
566 (dolist (elem '(:source :url :title :next :previous :up)) 563 (dolist (elem '(:source :url :title :next :previous :up))
567 (plist-put eww-data elem (plist-get old-data elem))) 564 (plist-put eww-data elem (plist-get old-data elem)))
@@ -570,41 +567,35 @@ the like."
570(defun eww-score-readability (node) 567(defun eww-score-readability (node)
571 (let ((score -1)) 568 (let ((score -1))
572 (cond 569 (cond
573 ((memq (car node) '(script head comment)) 570 ((memq (dom-tag node) '(script head comment))
574 (setq score -2)) 571 (setq score -2))
575 ((eq (car node) 'meta) 572 ((eq (dom-tag node) 'meta)
576 (setq score -1)) 573 (setq score -1))
577 ((eq (car node) 'img) 574 ((eq (dom-tag node) 'img)
578 (setq score 2)) 575 (setq score 2))
579 ((eq (car node) 'a) 576 ((eq (dom-tag node) 'a)
580 (setq score (- (length (split-string 577 (setq score (- (length (split-string (dom-text node))))))
581 (or (cdr (assoc 'text (cdr node))) ""))))))
582 (t 578 (t
583 (dolist (elem (cdr node)) 579 (dolist (elem (dom-children node))
584 (cond 580 (if (stringp elem)
585 ((and (stringp (cdr elem)) 581 (setq score (+ score (length (split-string elem))))
586 (eq (car elem) 'text))
587 (setq score (+ score (length (split-string (cdr elem))))))
588 ((consp (cdr elem))
589 (setq score (+ score 582 (setq score (+ score
590 (or (cdr (assoc :eww-readability-score (cdr elem))) 583 (or (cdr (assoc :eww-readability-score (cdr elem)))
591 (eww-score-readability elem))))))))) 584 (eww-score-readability elem))))))))
592 ;; Cache the score of the node to avoid recomputing all the time. 585 ;; Cache the score of the node to avoid recomputing all the time.
593 (setcdr node (cons (cons :eww-readability-score score) (cdr node))) 586 (dom-set-attribute node :eww-readability-score score)
594 score)) 587 score))
595 588
596(defun eww-highest-readability (node) 589(defun eww-highest-readability (node)
597 (let ((result node) 590 (let ((result node)
598 highest) 591 highest)
599 (dolist (elem (cdr node)) 592 (dolist (elem (dom-children node))
600 (when (and (consp (cdr elem)) 593 (when (> (or (dom-attr
601 (> (or (cdr (assoc 594 (setq highest (eww-highest-readability elem))
602 :eww-readability-score 595 :eww-readability-score)
603 (setq highest 596 most-negative-fixnum)
604 (eww-highest-readability elem)))) 597 (or (dom-attr (cdr result) :eww-readability-score)
605 most-negative-fixnum) 598 most-negative-fixnum))
606 (or (cdr (assoc :eww-readability-score (cdr result)))
607 most-negative-fixnum)))
608 (setq result highest))) 599 (setq result highest)))
609 result)) 600 result))
610 601
@@ -864,13 +855,12 @@ appears in a <link> or <a> tag."
864 (1- (next-single-property-change 855 (1- (next-single-property-change
865 (point) 'eww-form nil (point-max)))) 856 (point) 'eww-form nil (point-max))))
866 857
867(defun eww-tag-form (cont) 858(defun eww-tag-form (dom)
868 (let ((eww-form 859 (let ((eww-form (list (cons :method (dom-attr dom 'method))
869 (list (assq :method cont) 860 (cons :action (dom-attr dom 'action))))
870 (assq :action cont)))
871 (start (point))) 861 (start (point)))
872 (shr-ensure-paragraph) 862 (shr-ensure-paragraph)
873 (shr-generic cont) 863 (shr-generic dom)
874 (unless (bolp) 864 (unless (bolp)
875 (insert "\n")) 865 (insert "\n"))
876 (insert "\n") 866 (insert "\n")
@@ -878,9 +868,9 @@ appears in a <link> or <a> tag."
878 (put-text-property start (1+ start) 868 (put-text-property start (1+ start)
879 'eww-form eww-form)))) 869 'eww-form eww-form))))
880 870
881(defun eww-form-submit (cont) 871(defun eww-form-submit (dom)
882 (let ((start (point)) 872 (let ((start (point))
883 (value (cdr (assq :value cont)))) 873 (value (dom-attr dom 'value)))
884 (setq value 874 (setq value
885 (if (zerop (length value)) 875 (if (zerop (length value))
886 "Submit" 876 "Submit"
@@ -891,28 +881,28 @@ appears in a <link> or <a> tag."
891 (list :eww-form eww-form 881 (list :eww-form eww-form
892 :value value 882 :value value
893 :type "submit" 883 :type "submit"
894 :name (cdr (assq :name cont)))) 884 :name (dom-attr dom 'name)))
895 (put-text-property start (point) 'keymap eww-submit-map) 885 (put-text-property start (point) 'keymap eww-submit-map)
896 (insert " "))) 886 (insert " ")))
897 887
898(defun eww-form-checkbox (cont) 888(defun eww-form-checkbox (dom)
899 (let ((start (point))) 889 (let ((start (point)))
900 (if (cdr (assq :checked cont)) 890 (if (dom-attr dom 'checked)
901 (insert eww-form-checkbox-selected-symbol) 891 (insert eww-form-checkbox-selected-symbol)
902 (insert eww-form-checkbox-symbol)) 892 (insert eww-form-checkbox-symbol))
903 (add-face-text-property start (point) 'eww-form-checkbox) 893 (add-face-text-property start (point) 'eww-form-checkbox)
904 (put-text-property start (point) 'eww-form 894 (put-text-property start (point) 'eww-form
905 (list :eww-form eww-form 895 (list :eww-form eww-form
906 :value (cdr (assq :value cont)) 896 :value (dom-attr dom 'value)
907 :type (downcase (cdr (assq :type cont))) 897 :type (downcase (dom-attr dom 'type))
908 :checked (cdr (assq :checked cont)) 898 :checked (dom-attr dom 'checked)
909 :name (cdr (assq :name cont)))) 899 :name (dom-attr dom 'name)))
910 (put-text-property start (point) 'keymap eww-checkbox-map) 900 (put-text-property start (point) 'keymap eww-checkbox-map)
911 (insert " "))) 901 (insert " ")))
912 902
913(defun eww-form-file (cont) 903(defun eww-form-file (dom)
914 (let ((start (point)) 904 (let ((start (point))
915 (value (cdr (assq :value cont)))) 905 (value (dom-attr dom 'value)))
916 (setq value 906 (setq value
917 (if (zerop (length value)) 907 (if (zerop (length value))
918 " No file selected" 908 " No file selected"
@@ -922,9 +912,9 @@ appears in a <link> or <a> tag."
922 (insert value) 912 (insert value)
923 (put-text-property start (point) 'eww-form 913 (put-text-property start (point) 'eww-form
924 (list :eww-form eww-form 914 (list :eww-form eww-form
925 :value (cdr (assq :value cont)) 915 :value (dom-attr dom 'value)
926 :type (downcase (cdr (assq :type cont))) 916 :type (downcase (dom-attr dom 'type))
927 :name (cdr (assq :name cont)))) 917 :name (dom-attr dom 'name)))
928 (put-text-property start (point) 'keymap eww-submit-file) 918 (put-text-property start (point) 'keymap eww-submit-file)
929 (insert " "))) 919 (insert " ")))
930 920
@@ -938,16 +928,13 @@ appears in a <link> or <a> tag."
938 (eww-update-field filename (length "Browse")) 928 (eww-update-field filename (length "Browse"))
939 (plist-put input :filename filename)))) 929 (plist-put input :filename filename))))
940 930
941(defun eww-form-text (cont) 931(defun eww-form-text (dom)
942 (let ((start (point)) 932 (let ((start (point))
943 (type (downcase (or (cdr (assq :type cont)) 933 (type (downcase (or (dom-attr dom 'type) "text")))
944 "text"))) 934 (value (or (dom-attr dom 'value) ""))
945 (value (or (cdr (assq :value cont)) "")) 935 (width (string-to-number (or (dom-attr dom 'size) "40")))
946 (width (string-to-number 936 (readonly-property (if (or (dom-attr dom 'disabled)
947 (or (cdr (assq :size cont)) 937 (dom-attr dom 'readonly))
948 "40")))
949 (readonly-property (if (or (cdr (assq :disabled cont))
950 (cdr (assq :readonly cont)))
951 'read-only 938 'read-only
952 'inhibit-read-only))) 939 'inhibit-read-only)))
953 (insert value) 940 (insert value)
@@ -961,7 +948,7 @@ appears in a <link> or <a> tag."
961 (list :eww-form eww-form 948 (list :eww-form eww-form
962 :value value 949 :value value
963 :type type 950 :type type
964 :name (cdr (assq :name cont)))) 951 :name (dom-attr dom 'name)))
965 (insert " "))) 952 (insert " ")))
966 953
967(defconst eww-text-input-types '("text" "password" "textarea" 954(defconst eww-text-input-types '("text" "password" "textarea"
@@ -1014,15 +1001,11 @@ See URL `https://developer.mozilla.org/en-US/docs/Web/HTML/Element/Input'.")
1014 (put-text-property start (+ start (length value)) 1001 (put-text-property start (+ start (length value))
1015 'display (make-string (length value) ?*)))))))) 1002 'display (make-string (length value) ?*))))))))
1016 1003
1017(defun eww-tag-textarea (cont) 1004(defun eww-tag-textarea (dom)
1018 (let ((start (point)) 1005 (let ((start (point))
1019 (value (or (cdr (assq :value cont)) "")) 1006 (value (or (dom-attr dom 'value) ""))
1020 (lines (string-to-number 1007 (lines (string-to-number (or (dom-attr dom 'rows) "10")))
1021 (or (cdr (assq :rows cont)) 1008 (width (string-to-number (or (dom-attr dom 'cols) "10")))
1022 "10")))
1023 (width (string-to-number
1024 (or (cdr (assq :cols cont))
1025 "10")))
1026 end) 1009 end)
1027 (shr-ensure-newline) 1010 (shr-ensure-newline)
1028 (insert value) 1011 (insert value)
@@ -1047,23 +1030,22 @@ See URL `https://developer.mozilla.org/en-US/docs/Web/HTML/Element/Input'.")
1047 (list :eww-form eww-form 1030 (list :eww-form eww-form
1048 :value value 1031 :value value
1049 :type "textarea" 1032 :type "textarea"
1050 :name (cdr (assq :name cont)))))) 1033 :name (dom-attr dom 'name)))))
1051 1034
1052(defun eww-tag-input (cont) 1035(defun eww-tag-input (dom)
1053 (let ((type (downcase (or (cdr (assq :type cont)) 1036 (let ((type (downcase (or (dom-attr dom 'type) "text")))
1054 "text")))
1055 (start (point))) 1037 (start (point)))
1056 (cond 1038 (cond
1057 ((or (equal type "checkbox") 1039 ((or (equal type "checkbox")
1058 (equal type "radio")) 1040 (equal type "radio"))
1059 (eww-form-checkbox cont)) 1041 (eww-form-checkbox dom))
1060 ((equal type "file") 1042 ((equal type "file")
1061 (eww-form-file cont)) 1043 (eww-form-file dom))
1062 ((equal type "submit") 1044 ((equal type "submit")
1063 (eww-form-submit cont)) 1045 (eww-form-submit dom))
1064 ((equal type "hidden") 1046 ((equal type "hidden")
1065 (let ((form eww-form) 1047 (let ((form eww-form)
1066 (name (cdr (assq :name cont)))) 1048 (name (dom-attr dom 'name)))
1067 ;; Don't add <input type=hidden> elements repeatedly. 1049 ;; Don't add <input type=hidden> elements repeatedly.
1068 (while (and form 1050 (while (and form
1069 (or (not (consp (car form))) 1051 (or (not (consp (car form)))
@@ -1075,34 +1057,33 @@ See URL `https://developer.mozilla.org/en-US/docs/Web/HTML/Element/Input'.")
1075 (nconc eww-form (list 1057 (nconc eww-form (list
1076 (list 'hidden 1058 (list 'hidden
1077 :name name 1059 :name name
1078 :value (cdr (assq :value cont)))))))) 1060 :value (dom-attr dom 'value)))))))
1079 (t 1061 (t
1080 (eww-form-text cont))) 1062 (eww-form-text dom)))
1081 (unless (= start (point)) 1063 (unless (= start (point))
1082 (put-text-property start (1+ start) 'help-echo "Input field")))) 1064 (put-text-property start (1+ start) 'help-echo "Input field"))))
1083 1065
1084(defun eww-tag-select (cont) 1066(defun eww-tag-select (dom)
1085 (shr-ensure-paragraph) 1067 (shr-ensure-paragraph)
1086 (let ((menu (list :name (cdr (assq :name cont)) 1068 (let ((menu (list :name (dom-attr dom 'name)
1087 :eww-form eww-form)) 1069 :eww-form eww-form))
1088 (options nil) 1070 (options nil)
1089 (start (point)) 1071 (start (point))
1090 (max 0) 1072 (max 0)
1091 opelem) 1073 opelem)
1092 (if (eq (car (car cont)) 'optgroup) 1074 (if (eq (dom-tag dom) 'optgroup)
1093 (dolist (groupelem cont) 1075 (dolist (groupelem (dom-children dom))
1094 (unless (cdr (assq :disabled (cdr groupelem))) 1076 (unless (dom-attr groupelem 'disabled)
1095 (setq opelem (append opelem (cdr (cdr groupelem)))))) 1077 (setq opelem (append opelem (list groupelem)))))
1096 (setq opelem cont)) 1078 (setq opelem (list dom)))
1097 (dolist (elem opelem) 1079 (dolist (elem opelem)
1098 (when (eq (car elem) 'option) 1080 (when (eq (dom-tag elem) 'option)
1099 (when (cdr (assq :selected (cdr elem))) 1081 (when (dom-attr elem 'selected)
1100 (nconc menu (list :value 1082 (nconc menu (list :value (dom-attr elem 'value))))
1101 (cdr (assq :value (cdr elem)))))) 1083 (let ((display (dom-text elem)))
1102 (let ((display (or (cdr (assq 'text (cdr elem))) "")))
1103 (setq max (max max (length display))) 1084 (setq max (max max (length display)))
1104 (push (list 'item 1085 (push (list 'item
1105 :value (cdr (assq :value (cdr elem))) 1086 :value (dom-attr elem 'value)
1106 :display display) 1087 :display display)
1107 options)))) 1088 options))))
1108 (when options 1089 (when options
@@ -1302,8 +1283,7 @@ See URL `https://developer.mozilla.org/en-US/docs/Web/HTML/Element/Input'.")
1302 (eww-browse-url 1283 (eww-browse-url
1303 (concat 1284 (concat
1304 (if (cdr (assq :action form)) 1285 (if (cdr (assq :action form))
1305 (shr-expand-url (cdr (assq :action form)) 1286 (shr-expand-url (cdr (assq :action form)) (plist-get eww-data :url))
1306 (plist-get eww-data :url))
1307 (plist-get eww-data :url)) 1287 (plist-get eww-data :url))
1308 "?" 1288 "?"
1309 (mm-url-encode-www-form-urlencoded values)))))) 1289 (mm-url-encode-www-form-urlencoded values))))))
diff --git a/lisp/net/shr.el b/lisp/net/shr.el
index 1ced4e01163..22bceeb9ecc 100644
--- a/lisp/net/shr.el
+++ b/lisp/net/shr.el
@@ -33,6 +33,8 @@
33(eval-when-compile (require 'cl)) 33(eval-when-compile (require 'cl))
34(eval-when-compile (require 'url)) ;For url-filename's setf handler. 34(eval-when-compile (require 'url)) ;For url-filename's setf handler.
35(require 'browse-url) 35(require 'browse-url)
36(require 'subr-x)
37(require 'dom)
36 38
37(defgroup shr nil 39(defgroup shr nil
38 "Simple HTML Renderer" 40 "Simple HTML Renderer"
@@ -205,7 +207,7 @@ DOM should be a parse tree as generated by
205 (shr-depth 0) 207 (shr-depth 0)
206 (shr-warning nil) 208 (shr-warning nil)
207 (shr-internal-width (or shr-width (1- (window-width))))) 209 (shr-internal-width (or shr-width (1- (window-width)))))
208 (shr-descend (shr-transform-dom dom)) 210 (shr-descend dom)
209 (shr-remove-trailing-whitespace start (point)) 211 (shr-remove-trailing-whitespace start (point))
210 (when shr-warning 212 (when shr-warning
211 (message "%s" shr-warning)))) 213 (message "%s" shr-warning))))
@@ -366,53 +368,20 @@ size, and full-buffer size."
366 368
367;;; Utility functions. 369;;; Utility functions.
368 370
369(defun shr-transform-dom (dom) 371(defsubst shr-generic (dom)
370 (let ((result (list (pop dom)))) 372 (dolist (sub (dom-children dom))
371 (dolist (arg (pop dom)) 373 (if (stringp sub)
372 (push (cons (intern (concat ":" (symbol-name (car arg))) obarray) 374 (shr-insert sub)
373 (cdr arg)) 375 (shr-descend sub))))
374 result))
375 (dolist (sub dom)
376 (if (stringp sub)
377 (push (cons 'text sub) result)
378 (push (shr-transform-dom sub) result)))
379 (nreverse result)))
380
381(defun shr-retransform-dom (dom)
382 "Transform the shr DOM back into the libxml DOM."
383 (let ((tag (car dom))
384 (attributes nil)
385 (sub-nodes nil))
386 (dolist (elem (cdr dom))
387 (cond
388 ((and (stringp (cdr elem))
389 (eq (car elem) 'text))
390 (push (cdr elem) sub-nodes))
391 ((not (listp (cdr elem)))
392 (push (cons (intern (substring (symbol-name (car elem)) 1) obarray)
393 (cdr elem))
394 attributes))
395 (t
396 (push (shr-retransform-dom elem) sub-nodes))))
397 (append (list tag (nreverse attributes))
398 (nreverse sub-nodes))))
399
400(defsubst shr-generic (cont)
401 (dolist (sub cont)
402 (cond
403 ((eq (car sub) 'text)
404 (shr-insert (cdr sub)))
405 ((listp (cdr sub))
406 (shr-descend sub)))))
407 376
408(defun shr-descend (dom) 377(defun shr-descend (dom)
409 (let ((function 378 (let ((function
410 (or 379 (or
411 ;; Allow other packages to override (or provide) rendering 380 ;; Allow other packages to override (or provide) rendering
412 ;; of elements. 381 ;; of elements.
413 (cdr (assq (car dom) shr-external-rendering-functions)) 382 (cdr (assq (dom-tag dom) shr-external-rendering-functions))
414 (intern (concat "shr-tag-" (symbol-name (car dom))) obarray))) 383 (intern (concat "shr-tag-" (symbol-name (dom-tag dom))) obarray)))
415 (style (cdr (assq :style (cdr dom)))) 384 (style (dom-attr dom 'style))
416 (shr-stylesheet shr-stylesheet) 385 (shr-stylesheet shr-stylesheet)
417 (shr-depth (1+ shr-depth)) 386 (shr-depth (1+ shr-depth))
418 (start (point))) 387 (start (point)))
@@ -427,10 +396,10 @@ size, and full-buffer size."
427 ;; If we have a display:none, then just ignore this part of the DOM. 396 ;; If we have a display:none, then just ignore this part of the DOM.
428 (unless (equal (cdr (assq 'display shr-stylesheet)) "none") 397 (unless (equal (cdr (assq 'display shr-stylesheet)) "none")
429 (if (fboundp function) 398 (if (fboundp function)
430 (funcall function (cdr dom)) 399 (funcall function dom)
431 (shr-generic (cdr dom))) 400 (shr-generic dom))
432 (when (and shr-target-id 401 (when (and shr-target-id
433 (equal (cdr (assq :id (cdr dom))) shr-target-id)) 402 (equal (dom-attr dom 'id) shr-target-id))
434 ;; If the element was empty, we don't have anything to put the 403 ;; If the element was empty, we don't have anything to put the
435 ;; anchor on. So just insert a dummy character. 404 ;; anchor on. So just insert a dummy character.
436 (when (= start (point)) 405 (when (= start (point))
@@ -684,9 +653,9 @@ size, and full-buffer size."
684 (when (> shr-indentation 0) 653 (when (> shr-indentation 0)
685 (insert (make-string shr-indentation ? )))) 654 (insert (make-string shr-indentation ? ))))
686 655
687(defun shr-fontize-cont (cont &rest types) 656(defun shr-fontize-dom (dom &rest types)
688 (let (shr-start) 657 (let (shr-start)
689 (shr-generic cont) 658 (shr-generic dom)
690 (dolist (type types) 659 (dolist (type types)
691 (shr-add-font (or shr-start (point)) (point) type)))) 660 (shr-add-font (or shr-start (point)) (point) type))))
692 661
@@ -879,8 +848,7 @@ Return a string with image data."
879 (when (eq content-type 'image/svg+xml) 848 (when (eq content-type 'image/svg+xml)
880 (setq data 849 (setq data
881 (shr-dom-to-xml 850 (shr-dom-to-xml
882 (shr-transform-dom 851 (libxml-parse-xml-region (point) (point-max)))))
883 (libxml-parse-xml-region (point) (point-max))))))
884 (list data content-type))) 852 (list data content-type)))
885 853
886(defun shr-image-displayer (content-function) 854(defun shr-image-displayer (content-function)
@@ -903,9 +871,9 @@ START, and END. Note that START and END should be markers."
903 (list (current-buffer) start end) 871 (list (current-buffer) start end)
904 t t))))) 872 t t)))))
905 873
906(defun shr-heading (cont &rest types) 874(defun shr-heading (dom &rest types)
907 (shr-ensure-paragraph) 875 (shr-ensure-paragraph)
908 (apply #'shr-fontize-cont cont types) 876 (apply #'shr-fontize-dom dom types)
909 (shr-ensure-paragraph)) 877 (shr-ensure-paragraph))
910 878
911(defun shr-urlify (start url &optional title) 879(defun shr-urlify (start url &optional title)
@@ -1014,105 +982,98 @@ ones, in case fg and bg are nil."
1014 982
1015;;; Tag-specific rendering rules. 983;;; Tag-specific rendering rules.
1016 984
1017(defun shr-tag-body (cont) 985(defun shr-tag-body (dom)
1018 (let* ((start (point)) 986 (let* ((start (point))
1019 (fgcolor (cdr (or (assq :fgcolor cont) 987 (fgcolor (or (dom-attr dom 'fgcolor) (dom-attr dom 'text)))
1020 (assq :text cont)))) 988 (bgcolor (dom-attr dom 'bgcolor))
1021 (bgcolor (cdr (assq :bgcolor cont)))
1022 (shr-stylesheet (list (cons 'color fgcolor) 989 (shr-stylesheet (list (cons 'color fgcolor)
1023 (cons 'background-color bgcolor)))) 990 (cons 'background-color bgcolor))))
1024 (shr-generic cont) 991 (shr-generic dom)
1025 (shr-colorize-region start (point) fgcolor bgcolor))) 992 (shr-colorize-region start (point) fgcolor bgcolor)))
1026 993
1027(defun shr-tag-style (_cont) 994(defun shr-tag-style (_dom)
1028 ) 995 )
1029 996
1030(defun shr-tag-script (_cont) 997(defun shr-tag-script (_dom)
1031 ) 998 )
1032 999
1033(defun shr-tag-comment (_cont) 1000(defun shr-tag-comment (_dom)
1034 ) 1001 )
1035 1002
1036(defun shr-dom-to-xml (dom) 1003(defun shr-dom-to-xml (dom)
1004 (with-temp-buffer
1005 (shr-dom-print dom)
1006 (buffer-string)))
1007
1008(defun shr-dom-print (dom)
1037 "Convert DOM into a string containing the xml representation." 1009 "Convert DOM into a string containing the xml representation."
1038 (let ((arg " ") 1010 (insert (format "<%s" (dom-tag dom)))
1039 (text "") 1011 (dolist (attr (dom-attributes dom))
1040 url) 1012 ;; Ignore attributes that start with a colon.
1041 (dolist (sub (cdr dom)) 1013 (unless (= (aref (format "%s" (car attr)) 0) ?:)
1042 (cond 1014 (insert (format " %s=\"%s\"" (car attr) (cdr attr)))))
1043 ((listp (cdr sub)) 1015 (insert ">")
1044 ;; Ignore external image definitions if required. 1016 (let (url)
1045 ;; <image xlink:href="http://TRACKING_URL/"/> 1017 (dolist (elem (dom-children dom))
1046 (when (or (not (eq (car sub) 'image)) 1018 (when (or (not (eq (dom-tag elem) 'image))
1047 (not (setq url (cdr (assq ':xlink:href (cdr sub))))) 1019 (not (setq url (dom-attr elem ':xlink:href)))
1048 (not shr-blocked-images) 1020 (not shr-blocked-images)
1049 (not (string-match shr-blocked-images url))) 1021 (not (string-match shr-blocked-images url)))
1050 (setq text (concat text (shr-dom-to-xml sub))))) 1022 (insert " ")
1051 ((eq (car sub) 'text) 1023 (shr-dom-print elem))))
1052 (setq text (concat text (cdr sub)))) 1024 (insert (format "</%s>" (dom-tag dom))))
1053 (t 1025
1054 (setq arg (concat arg (format "%s=\"%s\" " 1026(defun shr-tag-svg (dom)
1055 (substring (symbol-name (car sub)) 1)
1056 (cdr sub)))))))
1057 (format "<%s%s>%s</%s>"
1058 (car dom)
1059 (substring arg 0 (1- (length arg)))
1060 text
1061 (car dom))))
1062
1063(defun shr-tag-svg (cont)
1064 (when (and (image-type-available-p 'svg) 1027 (when (and (image-type-available-p 'svg)
1065 (not shr-inhibit-images)) 1028 (not shr-inhibit-images))
1066 (funcall shr-put-image-function 1029 (funcall shr-put-image-function (shr-dom-to-xml dom) "SVG Image")))
1067 (shr-dom-to-xml (cons 'svg cont))
1068 "SVG Image")))
1069 1030
1070(defun shr-tag-sup (cont) 1031(defun shr-tag-sup (dom)
1071 (let ((start (point))) 1032 (let ((start (point)))
1072 (shr-generic cont) 1033 (shr-generic dom)
1073 (put-text-property start (point) 'display '(raise 0.5)))) 1034 (put-text-property start (point) 'display '(raise 0.5))))
1074 1035
1075(defun shr-tag-sub (cont) 1036(defun shr-tag-sub (dom)
1076 (let ((start (point))) 1037 (let ((start (point)))
1077 (shr-generic cont) 1038 (shr-generic dom)
1078 (put-text-property start (point) 'display '(raise -0.5)))) 1039 (put-text-property start (point) 'display '(raise -0.5))))
1079 1040
1080(defun shr-tag-label (cont) 1041(defun shr-tag-label (dom)
1081 (shr-generic cont) 1042 (shr-generic dom)
1082 (shr-ensure-paragraph)) 1043 (shr-ensure-paragraph))
1083 1044
1084(defun shr-tag-p (cont) 1045(defun shr-tag-p (dom)
1085 (shr-ensure-paragraph) 1046 (shr-ensure-paragraph)
1086 (shr-indent) 1047 (shr-indent)
1087 (shr-generic cont) 1048 (shr-generic dom)
1088 (shr-ensure-paragraph)) 1049 (shr-ensure-paragraph))
1089 1050
1090(defun shr-tag-div (cont) 1051(defun shr-tag-div (dom)
1091 (shr-ensure-newline) 1052 (shr-ensure-newline)
1092 (shr-indent) 1053 (shr-indent)
1093 (shr-generic cont) 1054 (shr-generic dom)
1094 (shr-ensure-newline)) 1055 (shr-ensure-newline))
1095 1056
1096(defun shr-tag-s (cont) 1057(defun shr-tag-s (dom)
1097 (shr-fontize-cont cont 'shr-strike-through)) 1058 (shr-fontize-dom dom 'shr-strike-through))
1098 1059
1099(defun shr-tag-del (cont) 1060(defun shr-tag-del (dom)
1100 (shr-fontize-cont cont 'shr-strike-through)) 1061 (shr-fontize-dom dom 'shr-strike-through))
1101 1062
1102(defun shr-tag-b (cont) 1063(defun shr-tag-b (dom)
1103 (shr-fontize-cont cont 'bold)) 1064 (shr-fontize-dom dom 'bold))
1104 1065
1105(defun shr-tag-i (cont) 1066(defun shr-tag-i (dom)
1106 (shr-fontize-cont cont 'italic)) 1067 (shr-fontize-dom dom 'italic))
1107 1068
1108(defun shr-tag-em (cont) 1069(defun shr-tag-em (dom)
1109 (shr-fontize-cont cont 'italic)) 1070 (shr-fontize-dom dom 'italic))
1110 1071
1111(defun shr-tag-strong (cont) 1072(defun shr-tag-strong (dom)
1112 (shr-fontize-cont cont 'bold)) 1073 (shr-fontize-dom dom 'bold))
1113 1074
1114(defun shr-tag-u (cont) 1075(defun shr-tag-u (dom)
1115 (shr-fontize-cont cont 'underline)) 1076 (shr-fontize-dom dom 'underline))
1116 1077
1117(defun shr-parse-style (style) 1078(defun shr-parse-style (style)
1118 (when style 1079 (when style
@@ -1134,20 +1095,19 @@ ones, in case fg and bg are nil."
1134 plist))))) 1095 plist)))))
1135 plist))) 1096 plist)))
1136 1097
1137(defun shr-tag-base (cont) 1098(defun shr-tag-base (dom)
1138 (let ((base (cdr (assq :href cont)))) 1099 (when-let (base (dom-attr dom 'href))
1139 (when base 1100 (setq shr-base (shr-parse-base base)))
1140 (setq shr-base (shr-parse-base base)))) 1101 (shr-generic dom))
1141 (shr-generic cont))
1142 1102
1143(defun shr-tag-a (cont) 1103(defun shr-tag-a (dom)
1144 (let ((url (cdr (assq :href cont))) 1104 (let ((url (dom-attr dom 'href))
1145 (title (cdr (assq :title cont))) 1105 (title (dom-attr dom 'title))
1146 (start (point)) 1106 (start (point))
1147 shr-start) 1107 shr-start)
1148 (shr-generic cont) 1108 (shr-generic dom)
1149 (when (and shr-target-id 1109 (when (and shr-target-id
1150 (equal (cdr (assq :name cont)) shr-target-id)) 1110 (equal (dom-attr dom 'name) shr-target-id))
1151 ;; We have a zero-length <a name="foo"> element, so just 1111 ;; We have a zero-length <a name="foo"> element, so just
1152 ;; insert... something. 1112 ;; insert... something.
1153 (when (= start (point)) 1113 (when (= start (point))
@@ -1158,33 +1118,33 @@ ones, in case fg and bg are nil."
1158 (not shr-inhibit-decoration)) 1118 (not shr-inhibit-decoration))
1159 (shr-urlify (or shr-start start) (shr-expand-url url) title)))) 1119 (shr-urlify (or shr-start start) (shr-expand-url url) title))))
1160 1120
1161(defun shr-tag-object (cont) 1121(defun shr-tag-object (dom)
1162 (unless shr-inhibit-images 1122 (unless shr-inhibit-images
1163 (let ((start (point)) 1123 (let ((start (point))
1164 url multimedia image) 1124 url multimedia image)
1165 (dolist (elem cont) 1125 (when-let (type (dom-attr dom 'type))
1126 (when (string-match "\\`image/svg" type)
1127 (setq url (dom-attr dom 'data)
1128 image t)))
1129 (dolist (child (dom-children dom))
1166 (cond 1130 (cond
1167 ((eq (car elem) 'embed) 1131 ((eq (dom-tag child) 'embed)
1168 (setq url (or url (cdr (assq :src (cdr elem)))) 1132 (setq url (or url (dom-attr child 'src))
1169 multimedia t))
1170 ((and (eq (car elem) 'param)
1171 (equal (cdr (assq :name (cdr elem))) "movie"))
1172 (setq url (or url (cdr (assq :value (cdr elem))))
1173 multimedia t)) 1133 multimedia t))
1174 ((and (eq (car elem) :type) 1134 ((and (eq (dom-tag child) 'param)
1175 (string-match "\\`image/svg" (cdr elem))) 1135 (equal (dom-attr child 'name) "movie"))
1176 (setq url (cdr (assq :data cont)) 1136 (setq url (or url (dom-attr child 'value))
1177 image t)))) 1137 multimedia t))))
1178 (when url 1138 (when url
1179 (cond 1139 (cond
1180 (image 1140 (image
1181 (shr-tag-img cont url) 1141 (shr-tag-img dom url)
1182 (setq cont nil)) 1142 (setq dom nil))
1183 (multimedia 1143 (multimedia
1184 (shr-insert " [multimedia] ") 1144 (shr-insert " [multimedia] ")
1185 (shr-urlify start (shr-expand-url url))))) 1145 (shr-urlify start (shr-expand-url url)))))
1186 (when cont 1146 (when dom
1187 (shr-generic cont))))) 1147 (shr-generic dom)))))
1188 1148
1189(defcustom shr-prefer-media-type-alist '(("webm" . 1.0) 1149(defcustom shr-prefer-media-type-alist '(("webm" . 1.0)
1190 ("ogv" . 1.0) 1150 ("ogv" . 1.0)
@@ -1203,10 +1163,10 @@ url if no type is specified. The value should be a float in the range 0.0 to
1203(defun shr--get-media-pref (elem) 1163(defun shr--get-media-pref (elem)
1204 "Determine the preference for ELEM. 1164 "Determine the preference for ELEM.
1205The preference is a float determined from `shr-prefer-media-type'." 1165The preference is a float determined from `shr-prefer-media-type'."
1206 (let ((type (cdr (assq :type elem))) 1166 (let ((type (dom-attr elem 'type))
1207 (p 0.0)) 1167 (p 0.0))
1208 (unless type 1168 (unless type
1209 (setq type (cdr (assq :src elem)))) 1169 (setq type (dom-attr elem 'src)))
1210 (when type 1170 (when type
1211 (dolist (pref shr-prefer-media-type-alist) 1171 (dolist (pref shr-prefer-media-type-alist)
1212 (when (and 1172 (when (and
@@ -1215,61 +1175,61 @@ The preference is a float determined from `shr-prefer-media-type'."
1215 (setq p (cdr pref))))) 1175 (setq p (cdr pref)))))
1216 p)) 1176 p))
1217 1177
1218(defun shr--extract-best-source (cont &optional url pref) 1178(defun shr--extract-best-source (dom &optional url pref)
1219 "Extract the best `:src' property from <source> blocks in CONT." 1179 "Extract the best `:src' property from <source> blocks in DOM."
1220 (setq pref (or pref -1.0)) 1180 (setq pref (or pref -1.0))
1221 (let (new-pref) 1181 (let (new-pref)
1222 (dolist (elem cont) 1182 (dolist (elem (dom-children dom))
1223 (when (and (eq (car elem) 'source) 1183 (when (and (eq (dom-tag elem) 'source)
1224 (< pref 1184 (< pref
1225 (setq new-pref 1185 (setq new-pref
1226 (shr--get-media-pref elem)))) 1186 (shr--get-media-pref elem))))
1227 (setq pref new-pref 1187 (setq pref new-pref
1228 url (cdr (assq :src elem))) 1188 url (dom-attr elem 'src))
1229 ;; libxml's html parser isn't HTML5 compliant and non terminated 1189 ;; libxml's html parser isn't HTML5 compliant and non terminated
1230 ;; source tags might end up as children. So recursion it is... 1190 ;; source tags might end up as children. So recursion it is...
1231 (dolist (child (cdr elem)) 1191 (dolist (child (dom-children elem))
1232 (when (eq (car child) 'source) 1192 (when (eq (dom-tag child) 'source)
1233 (let ((ret (shr--extract-best-source (list child) url pref))) 1193 (let ((ret (shr--extract-best-source (list child) url pref)))
1234 (when (< pref (cdr ret)) 1194 (when (< pref (cdr ret))
1235 (setq url (car ret) 1195 (setq url (car ret)
1236 pref (cdr ret))))))))) 1196 pref (cdr ret)))))))))
1237 (cons url pref)) 1197 (cons url pref))
1238 1198
1239(defun shr-tag-video (cont) 1199(defun shr-tag-video (dom)
1240 (let ((image (cdr (assq :poster cont))) 1200 (let ((image (dom-attr dom 'poster))
1241 (url (cdr (assq :src cont))) 1201 (url (dom-attr dom 'src))
1242 (start (point))) 1202 (start (point)))
1243 (unless url 1203 (unless url
1244 (setq url (car (shr--extract-best-source cont)))) 1204 (setq url (car (shr--extract-best-source dom))))
1245 (if image 1205 (if image
1246 (shr-tag-img nil image) 1206 (shr-tag-img nil image)
1247 (shr-insert " [video] ")) 1207 (shr-insert " [video] "))
1248 (shr-urlify start (shr-expand-url url)))) 1208 (shr-urlify start (shr-expand-url url))))
1249 1209
1250(defun shr-tag-audio (cont) 1210(defun shr-tag-audio (dom)
1251 (let ((url (cdr (assq :src cont))) 1211 (let ((url (dom-attr dom 'src))
1252 (start (point))) 1212 (start (point)))
1253 (unless url 1213 (unless url
1254 (setq url (car (shr--extract-best-source cont)))) 1214 (setq url (car (shr--extract-best-source dom))))
1255 (shr-insert " [audio] ") 1215 (shr-insert " [audio] ")
1256 (shr-urlify start (shr-expand-url url)))) 1216 (shr-urlify start (shr-expand-url url))))
1257 1217
1258(defun shr-tag-img (cont &optional url) 1218(defun shr-tag-img (dom &optional url)
1259 (when (or url 1219 (when (or url
1260 (and cont 1220 (and dom
1261 (> (length (cdr (assq :src cont))) 0))) 1221 (> (length (dom-attr dom 'src)) 0)))
1262 (when (and (> (current-column) 0) 1222 (when (and (> (current-column) 0)
1263 (not (eq shr-state 'image))) 1223 (not (eq shr-state 'image)))
1264 (insert "\n")) 1224 (insert "\n"))
1265 (let ((alt (cdr (assq :alt cont))) 1225 (let ((alt (dom-attr dom 'alt))
1266 (url (shr-expand-url (or url (cdr (assq :src cont)))))) 1226 (url (shr-expand-url (or url (dom-attr dom 'src)))))
1267 (let ((start (point-marker))) 1227 (let ((start (point-marker)))
1268 (when (zerop (length alt)) 1228 (when (zerop (length alt))
1269 (setq alt "*")) 1229 (setq alt "*"))
1270 (cond 1230 (cond
1271 ((or (member (cdr (assq :height cont)) '("0" "1")) 1231 ((or (member (dom-attr dom 'height) '("0" "1"))
1272 (member (cdr (assq :width cont)) '("0" "1"))) 1232 (member (dom-attr dom 'width) '("0" "1")))
1273 ;; Ignore zero-sized or single-pixel images. 1233 ;; Ignore zero-sized or single-pixel images.
1274 ) 1234 )
1275 ((and (not shr-inhibit-images) 1235 ((and (not shr-inhibit-images)
@@ -1315,52 +1275,51 @@ The preference is a float determined from `shr-prefer-media-type'."
1315 (put-text-property start (point) 'image-displayer 1275 (put-text-property start (point) 'image-displayer
1316 (shr-image-displayer shr-content-function)) 1276 (shr-image-displayer shr-content-function))
1317 (put-text-property start (point) 'help-echo 1277 (put-text-property start (point) 'help-echo
1318 (or (cdr (assq :title cont)) 1278 (or (dom-attr dom 'title) alt)))
1319 alt)))
1320 (setq shr-state 'image))))) 1279 (setq shr-state 'image)))))
1321 1280
1322(defun shr-tag-pre (cont) 1281(defun shr-tag-pre (dom)
1323 (let ((shr-folding-mode 'none)) 1282 (let ((shr-folding-mode 'none))
1324 (shr-ensure-newline) 1283 (shr-ensure-newline)
1325 (shr-indent) 1284 (shr-indent)
1326 (shr-generic cont) 1285 (shr-generic dom)
1327 (shr-ensure-newline))) 1286 (shr-ensure-newline)))
1328 1287
1329(defun shr-tag-blockquote (cont) 1288(defun shr-tag-blockquote (dom)
1330 (shr-ensure-paragraph) 1289 (shr-ensure-paragraph)
1331 (shr-indent) 1290 (shr-indent)
1332 (let ((shr-indentation (+ shr-indentation 4))) 1291 (let ((shr-indentation (+ shr-indentation 4)))
1333 (shr-generic cont)) 1292 (shr-generic dom))
1334 (shr-ensure-paragraph)) 1293 (shr-ensure-paragraph))
1335 1294
1336(defun shr-tag-dl (cont) 1295(defun shr-tag-dl (dom)
1337 (shr-ensure-paragraph) 1296 (shr-ensure-paragraph)
1338 (shr-generic cont) 1297 (shr-generic dom)
1339 (shr-ensure-paragraph)) 1298 (shr-ensure-paragraph))
1340 1299
1341(defun shr-tag-dt (cont) 1300(defun shr-tag-dt (dom)
1342 (shr-ensure-newline) 1301 (shr-ensure-newline)
1343 (shr-generic cont) 1302 (shr-generic dom)
1344 (shr-ensure-newline)) 1303 (shr-ensure-newline))
1345 1304
1346(defun shr-tag-dd (cont) 1305(defun shr-tag-dd (dom)
1347 (shr-ensure-newline) 1306 (shr-ensure-newline)
1348 (let ((shr-indentation (+ shr-indentation 4))) 1307 (let ((shr-indentation (+ shr-indentation 4)))
1349 (shr-generic cont))) 1308 (shr-generic dom)))
1350 1309
1351(defun shr-tag-ul (cont) 1310(defun shr-tag-ul (dom)
1352 (shr-ensure-paragraph) 1311 (shr-ensure-paragraph)
1353 (let ((shr-list-mode 'ul)) 1312 (let ((shr-list-mode 'ul))
1354 (shr-generic cont)) 1313 (shr-generic dom))
1355 (shr-ensure-paragraph)) 1314 (shr-ensure-paragraph))
1356 1315
1357(defun shr-tag-ol (cont) 1316(defun shr-tag-ol (dom)
1358 (shr-ensure-paragraph) 1317 (shr-ensure-paragraph)
1359 (let ((shr-list-mode 1)) 1318 (let ((shr-list-mode 1))
1360 (shr-generic cont)) 1319 (shr-generic dom))
1361 (shr-ensure-paragraph)) 1320 (shr-ensure-paragraph))
1362 1321
1363(defun shr-tag-li (cont) 1322(defun shr-tag-li (dom)
1364 (shr-ensure-newline) 1323 (shr-ensure-newline)
1365 (shr-indent) 1324 (shr-indent)
1366 (let* ((bullet 1325 (let* ((bullet
@@ -1371,9 +1330,9 @@ The preference is a float determined from `shr-prefer-media-type'."
1371 shr-bullet)) 1330 shr-bullet))
1372 (shr-indentation (+ shr-indentation (length bullet)))) 1331 (shr-indentation (+ shr-indentation (length bullet))))
1373 (insert bullet) 1332 (insert bullet)
1374 (shr-generic cont))) 1333 (shr-generic dom)))
1375 1334
1376(defun shr-tag-br (cont) 1335(defun shr-tag-br (dom)
1377 (when (and (not (bobp)) 1336 (when (and (not (bobp))
1378 ;; Only add a newline if we break the current line, or 1337 ;; Only add a newline if we break the current line, or
1379 ;; the previous line isn't a blank line. 1338 ;; the previous line isn't a blank line.
@@ -1382,42 +1341,42 @@ The preference is a float determined from `shr-prefer-media-type'."
1382 (not (= (char-after (- (point) 2)) ?\n))))) 1341 (not (= (char-after (- (point) 2)) ?\n)))))
1383 (insert "\n") 1342 (insert "\n")
1384 (shr-indent)) 1343 (shr-indent))
1385 (shr-generic cont)) 1344 (shr-generic dom))
1386 1345
1387(defun shr-tag-span (cont) 1346(defun shr-tag-span (dom)
1388 (shr-generic cont)) 1347 (shr-generic dom))
1389 1348
1390(defun shr-tag-h1 (cont) 1349(defun shr-tag-h1 (dom)
1391 (shr-heading cont 'bold 'underline)) 1350 (shr-heading dom 'bold 'underline))
1392 1351
1393(defun shr-tag-h2 (cont) 1352(defun shr-tag-h2 (dom)
1394 (shr-heading cont 'bold)) 1353 (shr-heading dom 'bold))
1395 1354
1396(defun shr-tag-h3 (cont) 1355(defun shr-tag-h3 (dom)
1397 (shr-heading cont 'italic)) 1356 (shr-heading dom 'italic))
1398 1357
1399(defun shr-tag-h4 (cont) 1358(defun shr-tag-h4 (dom)
1400 (shr-heading cont)) 1359 (shr-heading dom))
1401 1360
1402(defun shr-tag-h5 (cont) 1361(defun shr-tag-h5 (dom)
1403 (shr-heading cont)) 1362 (shr-heading dom))
1404 1363
1405(defun shr-tag-h6 (cont) 1364(defun shr-tag-h6 (dom)
1406 (shr-heading cont)) 1365 (shr-heading dom))
1407 1366
1408(defun shr-tag-hr (_cont) 1367(defun shr-tag-hr (_dom)
1409 (shr-ensure-newline) 1368 (shr-ensure-newline)
1410 (insert (make-string shr-internal-width shr-hr-line) "\n")) 1369 (insert (make-string shr-internal-width shr-hr-line) "\n"))
1411 1370
1412(defun shr-tag-title (cont) 1371(defun shr-tag-title (dom)
1413 (shr-heading cont 'bold 'underline)) 1372 (shr-heading dom 'bold 'underline))
1414 1373
1415(defun shr-tag-font (cont) 1374(defun shr-tag-font (dom)
1416 (let* ((start (point)) 1375 (let* ((start (point))
1417 (color (cdr (assq :color cont))) 1376 (color (dom-attr dom 'color))
1418 (shr-stylesheet (nconc (list (cons 'color color)) 1377 (shr-stylesheet (nconc (list (cons 'color color))
1419 shr-stylesheet))) 1378 shr-stylesheet)))
1420 (shr-generic cont) 1379 (shr-generic dom)
1421 (when color 1380 (when color
1422 (shr-colorize-region start (point) color 1381 (shr-colorize-region start (point) color
1423 (cdr (assq 'background-color shr-stylesheet)))))) 1382 (cdr (assq 'background-color shr-stylesheet))))))
@@ -1432,23 +1391,22 @@ The preference is a float determined from `shr-prefer-media-type'."
1432;; main buffer). Now we know how much space each TD really takes, so 1391;; main buffer). Now we know how much space each TD really takes, so
1433;; we then render everything again with the new widths, and finally 1392;; we then render everything again with the new widths, and finally
1434;; insert all these boxes into the main buffer. 1393;; insert all these boxes into the main buffer.
1435(defun shr-tag-table-1 (cont) 1394(defun shr-tag-table-1 (dom)
1436 (setq cont (or (cdr (assq 'tbody cont)) 1395 (setq dom (or (dom-child-by-tag dom 'tbody) dom))
1437 cont))
1438 (let* ((shr-inhibit-images t) 1396 (let* ((shr-inhibit-images t)
1439 (shr-table-depth (1+ shr-table-depth)) 1397 (shr-table-depth (1+ shr-table-depth))
1440 (shr-kinsoku-shorten t) 1398 (shr-kinsoku-shorten t)
1441 ;; Find all suggested widths. 1399 ;; Find all suggested widths.
1442 (columns (shr-column-specs cont)) 1400 (columns (shr-column-specs dom))
1443 ;; Compute how many characters wide each TD should be. 1401 ;; Compute how many characters wide each TD should be.
1444 (suggested-widths (shr-pro-rate-columns columns)) 1402 (suggested-widths (shr-pro-rate-columns columns))
1445 ;; Do a "test rendering" to see how big each TD is (this can 1403 ;; Do a "test rendering" to see how big each TD is (this can
1446 ;; be smaller (if there's little text) or bigger (if there's 1404 ;; be smaller (if there's little text) or bigger (if there's
1447 ;; unbreakable text). 1405 ;; unbreakable text).
1448 (sketch (shr-make-table cont suggested-widths)) 1406 (sketch (shr-make-table dom suggested-widths))
1449 ;; Compute the "natural" width by setting each column to 500 1407 ;; Compute the "natural" width by setting each column to 500
1450 ;; characters and see how wide they really render. 1408 ;; characters and see how wide they really render.
1451 (natural (shr-make-table cont (make-vector (length columns) 500))) 1409 (natural (shr-make-table dom (make-vector (length columns) 500)))
1452 (sketch-widths (shr-table-widths sketch natural suggested-widths))) 1410 (sketch-widths (shr-table-widths sketch natural suggested-widths)))
1453 ;; This probably won't work very well. 1411 ;; This probably won't work very well.
1454 (when (> (+ (loop for width across sketch-widths 1412 (when (> (+ (loop for width across sketch-widths
@@ -1457,15 +1415,15 @@ The preference is a float determined from `shr-prefer-media-type'."
1457 (frame-width)) 1415 (frame-width))
1458 (setq truncate-lines t)) 1416 (setq truncate-lines t))
1459 ;; Then render the table again with these new "hard" widths. 1417 ;; Then render the table again with these new "hard" widths.
1460 (shr-insert-table (shr-make-table cont sketch-widths t) sketch-widths))) 1418 (shr-insert-table (shr-make-table dom sketch-widths t) sketch-widths)))
1461 1419
1462(defun shr-tag-table (cont) 1420(defun shr-tag-table (dom)
1463 (shr-ensure-paragraph) 1421 (shr-ensure-paragraph)
1464 (let* ((caption (cdr (assq 'caption cont))) 1422 (let* ((caption (dom-child-by-tag dom 'caption))
1465 (header (cdr (assq 'thead cont))) 1423 (header (dom-child-by-tag dom 'thead))
1466 (body (or (cdr (assq 'tbody cont)) cont)) 1424 (body (or (dom-child-by-tag dom 'tbody) dom))
1467 (footer (cdr (assq 'tfoot cont))) 1425 (footer (dom-child-by-tag dom 'tfoot))
1468 (bgcolor (cdr (assq :bgcolor cont))) 1426 (bgcolor (dom-attr dom 'bgcolor))
1469 (start (point)) 1427 (start (point))
1470 (shr-stylesheet (nconc (list (cons 'background-color bgcolor)) 1428 (shr-stylesheet (nconc (list (cons 'background-color bgcolor))
1471 shr-stylesheet)) 1429 shr-stylesheet))
@@ -1474,12 +1432,12 @@ The preference is a float determined from `shr-prefer-media-type'."
1474 (nfooter (if footer (shr-max-columns footer)))) 1432 (nfooter (if footer (shr-max-columns footer))))
1475 (if (and (not caption) 1433 (if (and (not caption)
1476 (not header) 1434 (not header)
1477 (not (cdr (assq 'tbody cont))) 1435 (not (dom-child-by-tag dom 'tbody))
1478 (not (cdr (assq 'tr cont))) 1436 (not (dom-child-by-tag dom 'tr))
1479 (not footer)) 1437 (not footer))
1480 ;; The table is totally invalid and just contains random junk. 1438 ;; The table is totally invalid and just contains random junk.
1481 ;; Try to output it anyway. 1439 ;; Try to output it anyway.
1482 (shr-generic cont) 1440 (shr-generic dom)
1483 ;; It's a real table, so render it. 1441 ;; It's a real table, so render it.
1484 (shr-tag-table-1 1442 (shr-tag-table-1
1485 (nconc 1443 (nconc
@@ -1526,19 +1484,10 @@ The preference is a float determined from `shr-prefer-media-type'."
1526 ;; model isn't strong enough to allow us to put the images actually 1484 ;; model isn't strong enough to allow us to put the images actually
1527 ;; into the tables. 1485 ;; into the tables.
1528 (when (zerop shr-table-depth) 1486 (when (zerop shr-table-depth)
1529 (dolist (elem (shr-find-elements cont 'object)) 1487 (dolist (elem (dom-by-tag dom 'object))
1530 (shr-tag-object (cdr elem))) 1488 (shr-tag-object elem))
1531 (dolist (elem (shr-find-elements cont 'img)) 1489 (dolist (elem (dom-by-tag dom 'img))
1532 (shr-tag-img (cdr elem)))))) 1490 (shr-tag-img elem)))))
1533
1534(defun shr-find-elements (cont type)
1535 (let (result)
1536 (dolist (elem cont)
1537 (cond ((eq (car elem) type)
1538 (push elem result))
1539 ((consp (cdr elem))
1540 (setq result (nconc (shr-find-elements (cdr elem) type) result)))))
1541 (nreverse result)))
1542 1491
1543(defun shr-insert-table (table widths) 1492(defun shr-insert-table (table widths)
1544 (let* ((collapse (equal (cdr (assq 'border-collapse shr-stylesheet)) 1493 (let* ((collapse (equal (cdr (assq 'border-collapse shr-stylesheet))
@@ -1621,22 +1570,22 @@ The preference is a float determined from `shr-prefer-media-type'."
1621 (aref widths i)))))))) 1570 (aref widths i))))))))
1622 widths)) 1571 widths))
1623 1572
1624(defun shr-make-table (cont widths &optional fill) 1573(defun shr-make-table (dom widths &optional fill)
1625 (or (cadr (assoc (list cont widths fill) shr-content-cache)) 1574 (or (cadr (assoc (list dom widths fill) shr-content-cache))
1626 (let ((data (shr-make-table-1 cont widths fill))) 1575 (let ((data (shr-make-table-1 dom widths fill)))
1627 (push (list (list cont widths fill) data) 1576 (push (list (list dom widths fill) data)
1628 shr-content-cache) 1577 shr-content-cache)
1629 data))) 1578 data)))
1630 1579
1631(defun shr-make-table-1 (cont widths &optional fill) 1580(defun shr-make-table-1 (dom widths &optional fill)
1632 (let ((trs nil) 1581 (let ((trs nil)
1633 (shr-inhibit-decoration (not fill)) 1582 (shr-inhibit-decoration (not fill))
1634 (rowspans (make-vector (length widths) 0)) 1583 (rowspans (make-vector (length widths) 0))
1635 width colspan) 1584 width colspan)
1636 (dolist (row cont) 1585 (dolist (row (dom-children dom))
1637 (when (eq (car row) 'tr) 1586 (when (eq (dom-tag row) 'tr)
1638 (let ((tds nil) 1587 (let ((tds nil)
1639 (columns (cdr row)) 1588 (columns (dom-children row))
1640 (i 0) 1589 (i 0)
1641 (width-column 0) 1590 (width-column 0)
1642 column) 1591 column)
@@ -1650,12 +1599,12 @@ The preference is a float determined from `shr-prefer-media-type'."
1650 (pop columns) 1599 (pop columns)
1651 (aset rowspans i (1- (aref rowspans i))) 1600 (aset rowspans i (1- (aref rowspans i)))
1652 '(td))) 1601 '(td)))
1653 (when (or (memq (car column) '(td th)) 1602 (when (and (not (stringp column))
1654 (not column)) 1603 (or (memq (dom-tag column) '(td th))
1655 (when (cdr (assq :rowspan (cdr column))) 1604 (not column)))
1605 (when-let (span (dom-attr column 'rowspan))
1656 (aset rowspans i (+ (aref rowspans i) 1606 (aset rowspans i (+ (aref rowspans i)
1657 (1- (string-to-number 1607 (1- (string-to-number span)))))
1658 (cdr (assq :rowspan (cdr column))))))))
1659 ;; Sanity check for invalid column-spans. 1608 ;; Sanity check for invalid column-spans.
1660 (when (>= width-column (length widths)) 1609 (when (>= width-column (length widths))
1661 (setq width-column 0)) 1610 (setq width-column 0))
@@ -1664,7 +1613,7 @@ The preference is a float determined from `shr-prefer-media-type'."
1664 (aref widths width-column) 1613 (aref widths width-column)
1665 10)) 1614 10))
1666 (when (and fill 1615 (when (and fill
1667 (setq colspan (cdr (assq :colspan (cdr column))))) 1616 (setq colspan (dom-attr column colspan)))
1668 (setq colspan (min (string-to-number colspan) 1617 (setq colspan (min (string-to-number colspan)
1669 ;; The colspan may be wrong, so 1618 ;; The colspan may be wrong, so
1670 ;; truncate it to the length of the 1619 ;; truncate it to the length of the
@@ -1679,18 +1628,18 @@ The preference is a float determined from `shr-prefer-media-type'."
1679 (setq width-column (+ width-column (1- colspan)))) 1628 (setq width-column (+ width-column (1- colspan))))
1680 (when (or column 1629 (when (or column
1681 (not fill)) 1630 (not fill))
1682 (push (shr-render-td (cdr column) width fill) 1631 (push (shr-render-td column width fill)
1683 tds)) 1632 tds))
1684 (setq i (1+ i) 1633 (setq i (1+ i)
1685 width-column (1+ width-column)))) 1634 width-column (1+ width-column))))
1686 (push (nreverse tds) trs)))) 1635 (push (nreverse tds) trs))))
1687 (nreverse trs))) 1636 (nreverse trs)))
1688 1637
1689(defun shr-render-td (cont width fill) 1638(defun shr-render-td (dom width fill)
1690 (with-temp-buffer 1639 (with-temp-buffer
1691 (let ((bgcolor (cdr (assq :bgcolor cont))) 1640 (let ((bgcolor (dom-attr dom 'bgcolor))
1692 (fgcolor (cdr (assq :fgcolor cont))) 1641 (fgcolor (dom-attr dom 'fgcolor))
1693 (style (cdr (assq :style cont))) 1642 (style (dom-attr dom 'style))
1694 (shr-stylesheet shr-stylesheet) 1643 (shr-stylesheet shr-stylesheet)
1695 actual-colors) 1644 actual-colors)
1696 (when style 1645 (when style
@@ -1704,7 +1653,7 @@ The preference is a float determined from `shr-prefer-media-type'."
1704 (setq shr-stylesheet (append style shr-stylesheet))) 1653 (setq shr-stylesheet (append style shr-stylesheet)))
1705 (let ((shr-internal-width width) 1654 (let ((shr-internal-width width)
1706 (shr-indentation 0)) 1655 (shr-indentation 0))
1707 (shr-descend (cons 'td cont))) 1656 (shr-descend dom))
1708 ;; Delete padding at the bottom of the TDs. 1657 ;; Delete padding at the bottom of the TDs.
1709 (delete-region 1658 (delete-region
1710 (point) 1659 (point)
@@ -1725,7 +1674,7 @@ The preference is a float determined from `shr-prefer-media-type'."
1725 (if (zerop (buffer-size)) 1674 (if (zerop (buffer-size))
1726 (insert (make-string width ? )) 1675 (insert (make-string width ? ))
1727 ;; Otherwise, fill the buffer. 1676 ;; Otherwise, fill the buffer.
1728 (let ((align (cdr (assq :align cont))) 1677 (let ((align (dom-attr dom 'align))
1729 length) 1678 length)
1730 (while (not (eobp)) 1679 (while (not (eobp))
1731 (end-of-line) 1680 (end-of-line)
@@ -1780,14 +1729,15 @@ The preference is a float determined from `shr-prefer-media-type'."
1780 widths)) 1729 widths))
1781 1730
1782;; Return a summary of the number and shape of the TDs in the table. 1731;; Return a summary of the number and shape of the TDs in the table.
1783(defun shr-column-specs (cont) 1732(defun shr-column-specs (dom)
1784 (let ((columns (make-vector (shr-max-columns cont) 1))) 1733 (let ((columns (make-vector (shr-max-columns dom) 1)))
1785 (dolist (row cont) 1734 (dolist (row (dom-children dom))
1786 (when (eq (car row) 'tr) 1735 (when (eq (dom-tag row) 'tr)
1787 (let ((i 0)) 1736 (let ((i 0))
1788 (dolist (column (cdr row)) 1737 (dolist (column (dom-children row))
1789 (when (memq (car column) '(td th)) 1738 (when (and (not (stringp column))
1790 (let ((width (cdr (assq :width (cdr column))))) 1739 (memq (dom-tag column) '(td th)))
1740 (let ((width (dom-attr column 'width)))
1791 (when (and width 1741 (when (and width
1792 (string-match "\\([0-9]+\\)%" width) 1742 (string-match "\\([0-9]+\\)%" width)
1793 (not (zerop (setq width (string-to-number 1743 (not (zerop (setq width (string-to-number
@@ -1796,19 +1746,20 @@ The preference is a float determined from `shr-prefer-media-type'."
1796 (setq i (1+ i))))))) 1746 (setq i (1+ i)))))))
1797 columns)) 1747 columns))
1798 1748
1799(defun shr-count (cont elem) 1749(defun shr-count (dom elem)
1800 (let ((i 0)) 1750 (let ((i 0))
1801 (dolist (sub cont) 1751 (dolist (sub (dom-children dom))
1802 (when (eq (car sub) elem) 1752 (when (and (not (stringp sub))
1753 (eq (dom-tag sub) elem))
1803 (setq i (1+ i)))) 1754 (setq i (1+ i))))
1804 i)) 1755 i))
1805 1756
1806(defun shr-max-columns (cont) 1757(defun shr-max-columns (dom)
1807 (let ((max 0)) 1758 (let ((max 0))
1808 (dolist (row cont) 1759 (dolist (row (dom-children dom))
1809 (when (eq (car row) 'tr) 1760 (when (eq (dom-tag row) 'tr)
1810 (setq max (max max (+ (shr-count (cdr row) 'td) 1761 (setq max (max max (+ (shr-count row 'td)
1811 (shr-count (cdr row) 'th)))))) 1762 (shr-count row 'th))))))
1812 max)) 1763 max))
1813 1764
1814(provide 'shr) 1765(provide 'shr)