diff options
| author | Lars Magne Ingebrigtsen | 2014-11-26 19:41:13 +0100 |
|---|---|---|
| committer | Lars Magne Ingebrigtsen | 2014-11-26 19:42:29 +0100 |
| commit | d9ba097fe4c17ed77e730c627f85ee0ed94da294 (patch) | |
| tree | 9c9409293ea88edde98bda1668468734045bcae7 | |
| parent | 115178cd46b10383a12bd865739d0d55eea20251 (diff) | |
| download | emacs-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.el | 240 | ||||
| -rw-r--r-- | lisp/net/shr.el | 483 |
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 | |||
| 550 | the like." | 549 | the 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. |
| 1205 | The preference is a float determined from `shr-prefer-media-type'." | 1165 | The 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) |