diff options
Diffstat (limited to 'lisp/net/shr.el')
| -rw-r--r-- | lisp/net/shr.el | 1663 |
1 files changed, 1045 insertions, 618 deletions
diff --git a/lisp/net/shr.el b/lisp/net/shr.el index 9cac618b159..58deaea6f53 100644 --- a/lisp/net/shr.el +++ b/lisp/net/shr.el @@ -1,6 +1,6 @@ ;;; shr.el --- Simple HTML Renderer -;; Copyright (C) 2010-2013 Free Software Foundation, Inc. +;; Copyright (C) 2010-2015 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> ;; Keywords: html @@ -33,11 +33,13 @@ (eval-when-compile (require 'cl)) (eval-when-compile (require 'url)) ;For url-filename's setf handler. (require 'browse-url) +(require 'subr-x) +(require 'dom) (defgroup shr nil "Simple HTML Renderer" - :version "24.1" - :group 'hypermedia) + :version "25.1" + :group 'web) (defcustom shr-max-image-proportion 0.9 "How big pictures displayed are in relation to the window they're in. @@ -55,6 +57,12 @@ fit these criteria." :group 'shr :type '(choice (const nil) regexp)) +(defcustom shr-use-fonts t + "If non-nil, use proportional fonts for text." + :version "25.1" + :group 'shr + :type 'boolean) + (defcustom shr-table-horizontal-line nil "Character used to draw horizontal table lines. If nil, don't draw horizontal table lines." @@ -76,11 +84,12 @@ If nil, don't draw horizontal table lines." :group 'shr :type 'character) -(defcustom shr-width fill-column +(defcustom shr-width nil "Frame width to use for rendering. May either be an integer specifying a fixed width in characters, or nil, meaning that the full width of the window should be used." + :version "25.1" :type '(choice (integer :tag "Fixed width in characters") (const :tag "Use the width of the window" nil)) :group 'shr) @@ -90,6 +99,7 @@ used." Alternative suggestions are: - \" \" - \" \"" + :version "24.4" :type 'string :group 'shr) @@ -99,6 +109,12 @@ Alternative suggestions are: :group 'shr :type 'function) +(defcustom shr-image-animate t + "Non nil means that images that can be animated will be." + :version "24.4" + :group 'shr + :type 'boolean) + (defvar shr-content-function nil "If bound, this should be a function that will return the content. This is used for cid: URLs, and the function is called with the @@ -116,32 +132,39 @@ cid: URL as the argument.") "Font for link elements." :group 'shr) +(defvar shr-inhibit-images nil + "If non-nil, inhibit loading images.") + ;;; Internal variables. (defvar shr-folding-mode nil) -(defvar shr-state nil) (defvar shr-start nil) (defvar shr-indentation 0) -(defvar shr-inhibit-images nil) +(defvar shr-internal-width nil) (defvar shr-list-mode nil) (defvar shr-content-cache nil) (defvar shr-kinsoku-shorten nil) (defvar shr-table-depth 0) (defvar shr-stylesheet nil) (defvar shr-base nil) +(defvar shr-depth 0) +(defvar shr-warning nil) (defvar shr-ignore-cache nil) (defvar shr-external-rendering-functions nil) (defvar shr-target-id nil) -(defvar shr-inhibit-decoration nil) (defvar shr-table-separator-length 1) +(defvar shr-table-separator-pixel-width 0) +(defvar shr-table-id nil) +(defvar shr-current-font nil) +(defvar shr-internal-bullet nil) (defvar shr-map (let ((map (make-sparse-keymap))) (define-key map "a" 'shr-show-alt-text) (define-key map "i" 'shr-browse-image) (define-key map "z" 'shr-zoom-image) - (define-key map [tab] 'shr-next-link) - (define-key map [backtab] 'shr-previous-link) + (define-key map [?\t] 'shr-next-link) + (define-key map [?\M-\t] 'shr-previous-link) (define-key map [follow-link] 'mouse-face) (define-key map [mouse-2] 'shr-browse-url) (define-key map "I" 'shr-insert-image) @@ -154,7 +177,7 @@ cid: URL as the argument.") ;; Public functions and commands. (declare-function libxml-parse-html-region "xml.c" - (start end &optional base-url)) + (start end &optional base-url discard-comments)) (defun shr-render-buffer (buffer) "Display the HTML rendering of the current buffer." @@ -168,6 +191,7 @@ cid: URL as the argument.") (libxml-parse-html-region (point-min) (point-max)))) (goto-char (point-min))) +;;;###autoload (defun shr-render-region (begin end &optional buffer) "Display the HTML rendering of the region between BEGIN and END." (interactive "r") @@ -179,13 +203,6 @@ cid: URL as the argument.") (goto-char begin) (shr-insert-document dom)))) -(defun shr-visit-file (file) - "Parse FILE as an HTML document, and render it in a new buffer." - (interactive "fHTML file name: ") - (with-temp-buffer - (insert-file-contents file) - (shr-render-buffer (current-buffer)))) - ;;;###autoload (defun shr-insert-document (dom) "Render the parsed document DOM into the current buffer. @@ -193,13 +210,46 @@ DOM should be a parse tree as generated by `libxml-parse-html-region' or similar." (setq shr-content-cache nil) (let ((start (point)) - (shr-state nil) (shr-start nil) (shr-base nil) - (shr-preliminary-table-render 0) - (shr-width (or shr-width (1- (window-width))))) - (shr-descend (shr-transform-dom dom)) - (shr-remove-trailing-whitespace start (point)))) + (shr-depth 0) + (shr-table-id 0) + (shr-warning nil) + (shr-table-separator-pixel-width (shr-string-pixel-width "-")) + (shr-internal-bullet (cons shr-bullet + (shr-string-pixel-width shr-bullet))) + (shr-internal-width (or (and shr-width + (if (not shr-use-fonts) + shr-width + (* shr-width (frame-char-width)))) + ;; We need to adjust the available + ;; width for when the user disables + ;; the fringes, which will cause the + ;; display engine usurp one column for + ;; the continuation glyph. + (if (not shr-use-fonts) + (- (window-body-width) 1 + (if (and (null shr-width) + (or (zerop + (fringe-columns 'right)) + (zerop + (fringe-columns 'left)))) + 0 + 1)) + (- (window-body-width nil t) + (* 2 (frame-char-width)) + (if (and (null shr-width) + (or (zerop + (fringe-columns 'right)) + (zerop + (fringe-columns 'left)))) + (* (frame-char-width) 2) + 0)))))) + (shr-descend dom) + (shr-fill-lines start (point)) + (shr-remove-trailing-whitespace start (point)) + (when shr-warning + (message "%s" shr-warning)))) (defun shr-remove-trailing-whitespace (start end) (let ((width (window-width))) @@ -214,12 +264,16 @@ DOM should be a parse tree as generated by (overlay-put overlay 'before-string nil)))) (forward-line 1))))) -(defun shr-copy-url () +(defun shr-copy-url (&optional image-url) "Copy the URL under point to the kill ring. +If IMAGE-URL (the prefix) is non-nil, or there is no link under +point, but there is an image under point then copy the URL of the +image under point instead. If called twice, then try to fetch the URL and see whether it redirects somewhere else." - (interactive) - (let ((url (get-text-property (point) 'shr-url))) + (interactive "P") + (let ((url (or (get-text-property (point) 'shr-url) + (get-text-property (point) 'image-url)))) (cond ((not url) (message "No URL under point")) @@ -242,16 +296,17 @@ redirects somewhere else." ;; Copy the URL to the kill ring. (t (with-temp-buffer - (insert url) + (insert (url-encode-url url)) (copy-region-as-kill (point-min) (point-max)) - (message "Copied %s" url)))))) + (message "Copied %s" (buffer-string))))))) (defun shr-next-link () "Skip to the next link." (interactive) (let ((skip (text-property-any (point) (point-max) 'help-echo nil))) - (if (not (setq skip (text-property-not-all skip (point-max) - 'help-echo nil))) + (if (or (eobp) + (not (setq skip (text-property-not-all skip (point-max) + 'help-echo nil)))) (message "No next link") (goto-char skip) (message "%s" (get-text-property (point) 'help-echo))))) @@ -286,7 +341,7 @@ redirects somewhere else." (let ((text (get-text-property (point) 'shr-alt))) (if (not text) (message "No image under point") - (message "%s" text)))) + (message "%s" (shr-fill-text text))))) (defun shr-browse-image (&optional copy-url) "Browse the image under point. @@ -353,184 +408,274 @@ size, and full-buffer size." ;;; Utility functions. -(defun shr-transform-dom (dom) - (let ((result (list (pop dom)))) - (dolist (arg (pop dom)) - (push (cons (intern (concat ":" (symbol-name (car arg))) obarray) - (cdr arg)) - result)) - (dolist (sub dom) - (if (stringp sub) - (push (cons 'text sub) result) - (push (shr-transform-dom sub) result))) - (nreverse result))) +(defsubst shr-generic (dom) + (dolist (sub (dom-children dom)) + (if (stringp sub) + (shr-insert sub) + (shr-descend sub)))) (defun shr-descend (dom) (let ((function (or ;; Allow other packages to override (or provide) rendering ;; of elements. - (cdr (assq (car dom) shr-external-rendering-functions)) - (intern (concat "shr-tag-" (symbol-name (car dom))) obarray))) - (style (cdr (assq :style (cdr dom)))) + (cdr (assq (dom-tag dom) shr-external-rendering-functions)) + (intern (concat "shr-tag-" (symbol-name (dom-tag dom))) obarray))) + (style (dom-attr dom 'style)) (shr-stylesheet shr-stylesheet) + (shr-depth (1+ shr-depth)) (start (point))) - (when style - (if (string-match "color\\|display\\|border-collapse" style) - (setq shr-stylesheet (nconc (shr-parse-style style) - shr-stylesheet)) - (setq style nil))) - ;; If we have a display:none, then just ignore this part of the - ;; DOM. - (unless (equal (cdr (assq 'display shr-stylesheet)) "none") - (if (fboundp function) - (funcall function (cdr dom)) - (shr-generic (cdr dom))) - (when (and shr-target-id - (equal (cdr (assq :id (cdr dom))) shr-target-id)) - (put-text-property start (1+ start) 'shr-target-id shr-target-id)) - ;; If style is set, then this node has set the color. + ;; shr uses about 12 frames per nested node. + (if (> shr-depth (/ max-specpdl-size 12)) + (setq shr-warning "Too deeply nested to render properly; consider increasing `max-specpdl-size'") (when style - (shr-colorize-region start (point) - (cdr (assq 'color shr-stylesheet)) - (cdr (assq 'background-color shr-stylesheet))))))) - -(defun shr-generic (cont) - (dolist (sub cont) - (cond - ((eq (car sub) 'text) - (shr-insert (cdr sub))) - ((listp (cdr sub)) - (shr-descend sub))))) - -(defmacro shr-char-breakable-p (char) + (if (string-match "color\\|display\\|border-collapse" style) + (setq shr-stylesheet (nconc (shr-parse-style style) + shr-stylesheet)) + (setq style nil))) + ;; If we have a display:none, then just ignore this part of the DOM. + (unless (equal (cdr (assq 'display shr-stylesheet)) "none") + (if (fboundp function) + (funcall function dom) + (shr-generic dom)) + (when (and shr-target-id + (equal (dom-attr dom 'id) shr-target-id)) + ;; If the element was empty, we don't have anything to put the + ;; anchor on. So just insert a dummy character. + (when (= start (point)) + (insert "*")) + (put-text-property start (1+ start) 'shr-target-id shr-target-id)) + ;; If style is set, then this node has set the color. + (when style + (shr-colorize-region + start (point) + (cdr (assq 'color shr-stylesheet)) + (cdr (assq 'background-color shr-stylesheet)))))))) + +(defun shr-fill-text (text) + (if (zerop (length text)) + text + (with-temp-buffer + (let ((shr-indentation 0) + (shr-start nil) + (shr-internal-width (- (window-body-width nil t) + (* 2 (frame-char-width)) + ;; Adjust the window width for when + ;; the user disables the fringes, + ;; which causes the display engine + ;; to usurp one column for the + ;; continuation glyph. + (if (and (null shr-width) + (or (zerop (fringe-columns 'right)) + (zerop (fringe-columns 'left)))) + (* (frame-char-width) 2) + 0)))) + (shr-insert text) + (buffer-string))))) + +(define-inline shr-char-breakable-p (char) "Return non-nil if a line can be broken before and after CHAR." - `(aref fill-find-break-point-function-table ,char)) -(defmacro shr-char-nospace-p (char) + (inline-quote (aref fill-find-break-point-function-table ,char))) +(define-inline shr-char-nospace-p (char) "Return non-nil if no space is required before and after CHAR." - `(aref fill-nospace-between-words-table ,char)) + (inline-quote (aref fill-nospace-between-words-table ,char))) ;; KINSOKU is a Japanese word meaning a rule that should not be violated. ;; In Emacs, it is a term used for characters, e.g. punctuation marks, ;; parentheses, and so on, that should not be placed in the beginning ;; of a line or the end of a line. -(defmacro shr-char-kinsoku-bol-p (char) +(define-inline shr-char-kinsoku-bol-p (char) "Return non-nil if a line ought not to begin with CHAR." - `(aref (char-category-set ,char) ?>)) -(defmacro shr-char-kinsoku-eol-p (char) + (inline-letevals (char) + (inline-quote (and (not (eq ,char ?')) + (aref (char-category-set ,char) ?>))))) +(define-inline shr-char-kinsoku-eol-p (char) "Return non-nil if a line ought not to end with CHAR." - `(aref (char-category-set ,char) ?<)) + (inline-quote (aref (char-category-set ,char) ?<))) (unless (shr-char-kinsoku-bol-p (make-char 'japanese-jisx0208 33 35)) (load "kinsoku" nil t)) +(defun shr-pixel-column () + (if (not shr-use-fonts) + (current-column) + (if (not (get-buffer-window (current-buffer))) + (save-window-excursion + (set-window-buffer nil (current-buffer)) + (car (window-text-pixel-size nil (line-beginning-position) (point)))) + (car (window-text-pixel-size nil (line-beginning-position) (point)))))) + +(defun shr-pixel-region () + (- (shr-pixel-column) + (save-excursion + (goto-char (mark)) + (shr-pixel-column)))) + +(defun shr-string-pixel-width (string) + (if (not shr-use-fonts) + (length string) + (with-temp-buffer + (insert string) + (shr-pixel-column)))) + (defun shr-insert (text) - (when (and (eq shr-state 'image) - (not (bolp)) - (not (string-match "\\`[ \t\n]+\\'" text))) - (insert "\n") - (setq shr-state nil)) + (when (and (not (bolp)) + (get-text-property (1- (point)) 'image-url)) + (insert "\n")) (cond ((eq shr-folding-mode 'none) - (insert text)) + (let ((start (point))) + (insert text) + (save-restriction + (narrow-to-region start (point)) + ;; Remove soft hyphens. + (goto-char (point-min)) + (while (search-forward "" nil t) + (replace-match "" t t)) + (goto-char (point-max))))) (t - (when (and (string-match "\\`[ \t\n ]" text) - (not (bolp)) - (not (eq (char-after (1- (point))) ? ))) - (insert " ")) - (dolist (elem (split-string text "[ \f\t\n\r\v ]+" t)) - (when (and (bolp) - (> shr-indentation 0)) - (shr-indent)) - ;; No space is needed behind a wide character categorized as - ;; kinsoku-bol, between characters both categorized as nospace, - ;; or at the beginning of a line. - (let (prev) - (when (and (> (current-column) shr-indentation) - (eq (preceding-char) ? ) - (or (= (line-beginning-position) (1- (point))) - (and (shr-char-breakable-p - (setq prev (char-after (- (point) 2)))) - (shr-char-kinsoku-bol-p prev)) - (and (shr-char-nospace-p prev) - (shr-char-nospace-p (aref elem 0))))) - (delete-char -1))) - ;; The shr-start is a special variable that is used to pass - ;; upwards the first point in the buffer where the text really - ;; starts. - (unless shr-start - (setq shr-start (point))) - (insert elem) - (setq shr-state nil) - (let (found) - (while (and (> (current-column) shr-width) - (progn - (setq found (shr-find-fill-point)) - (not (eolp)))) - (when (eq (preceding-char) ? ) - (delete-char -1)) - (insert "\n") - (unless found - ;; No space is needed at the beginning of a line. - (when (eq (following-char) ? ) - (delete-char 1))) - (when (> shr-indentation 0) - (shr-indent)) - (end-of-line)) - (insert " "))) - (unless (string-match "[ \t\r\n ]\\'" text) - (delete-char -1))))) - -(defun shr-find-fill-point () - (when (> (move-to-column shr-width) shr-width) - (backward-char 1)) + (let ((font-start (point))) + (when (and (string-match "\\`[ \t\n\r ]" text) + (not (bolp)) + (not (eq (char-after (1- (point))) ? ))) + (insert " ")) + (let ((start (point)) + (bolp (bolp))) + (insert text) + (save-restriction + (narrow-to-region start (point)) + (goto-char start) + (when (looking-at "[ \t\n\r ]+") + (replace-match "" t t)) + (while (re-search-forward "[ \t\n\r ]+" nil t) + (replace-match " " t t)) + ;; Remove soft hyphens. + (goto-char (point-min)) + (while (search-forward "" nil t) + (replace-match "" t t)) + (goto-char (point-max))) + ;; We may have removed everything we inserted if if was just + ;; spaces. + (unless (= font-start (point)) + ;; Mark all lines that should possibly be folded afterwards. + (when bolp + (shr-mark-fill start)) + (when shr-use-fonts + (put-text-property font-start (point) + 'face + (or shr-current-font 'variable-pitch))))))))) + +(defun shr-fill-lines (start end) + (if (<= shr-internal-width 0) + nil + (save-restriction + (narrow-to-region start end) + (goto-char start) + (when (get-text-property (point) 'shr-indentation) + (shr-fill-line)) + (while (setq start (next-single-property-change start 'shr-indentation)) + (goto-char start) + (when (bolp) + (shr-fill-line))) + (goto-char (point-max))))) + +(defun shr-vertical-motion (column) + (if (not shr-use-fonts) + (move-to-column column) + (unless (eolp) + (forward-char 1)) + (vertical-motion (cons (/ column (frame-char-width)) 0)) + (unless (eolp) + (forward-char 1)))) + +(defun shr-fill-line () + (let ((shr-indentation (get-text-property (point) 'shr-indentation)) + (continuation (get-text-property + (point) 'shr-continuation-indentation)) + start) + (put-text-property (point) (1+ (point)) 'shr-indentation nil) + (let ((face (get-text-property (point) 'face)) + (background-start (point))) + (shr-indent) + (when face + (put-text-property background-start (point) 'face + `,(shr-face-background face)))) + (setq start (point)) + (setq shr-indentation (or continuation shr-indentation)) + (shr-vertical-motion shr-internal-width) + (when (looking-at " $") + (delete-region (point) (line-end-position))) + (while (not (eolp)) + ;; We have to do some folding. First find the first + ;; previous point suitable for folding. + (if (or (not (shr-find-fill-point (line-beginning-position))) + (= (point) start)) + ;; We had unbreakable text (for this width), so just go to + ;; the first space and carry on. + (progn + (beginning-of-line) + (skip-chars-forward " ") + (search-forward " " (line-end-position) 'move))) + ;; Success; continue. + (when (= (preceding-char) ?\s) + (delete-char -1)) + (let ((face (get-text-property (point) 'face)) + (background-start (point))) + (insert "\n") + (shr-indent) + (when face + (put-text-property background-start (point) 'face + `,(shr-face-background face)))) + (setq start (point)) + (shr-vertical-motion shr-internal-width) + (when (looking-at " $") + (delete-region (point) (line-end-position)))))) + +(defun shr-find-fill-point (start) (let ((bp (point)) + (end (point)) failed) - (while (not (or (setq failed (= (current-column) shr-indentation)) + (while (not (or (setq failed (<= (point) start)) (eq (preceding-char) ? ) (eq (following-char) ? ) (shr-char-breakable-p (preceding-char)) (shr-char-breakable-p (following-char)) - (if (eq (preceding-char) ?') - (not (memq (char-after (- (point) 2)) - (list nil ?\n ? ))) - (and (shr-char-kinsoku-bol-p (preceding-char)) - (shr-char-breakable-p (following-char)) - (not (shr-char-kinsoku-bol-p (following-char))))) - (shr-char-kinsoku-eol-p (following-char)))) + (and (shr-char-kinsoku-bol-p (preceding-char)) + (shr-char-breakable-p (following-char)) + (not (shr-char-kinsoku-bol-p (following-char)))) + (shr-char-kinsoku-eol-p (following-char)) + (bolp))) (backward-char 1)) - (if (and (not (or failed (eolp))) - (eq (preceding-char) ?')) - (while (not (or (setq failed (eolp)) - (eq (following-char) ? ) - (shr-char-breakable-p (following-char)) - (shr-char-kinsoku-eol-p (following-char)))) - (forward-char 1))) (if failed ;; There's no breakable point, so we give it up. (let (found) (goto-char bp) - (unless shr-kinsoku-shorten - (while (and (setq found (re-search-forward - "\\(\\c>\\)\\| \\|\\c<\\|\\c|" - (line-end-position) 'move)) - (eq (preceding-char) ?'))) - (if (and found (not (match-beginning 1))) + ;; Don't overflow the window edge, even if + ;; shr-kinsoku-shorten is nil. + (unless (or shr-kinsoku-shorten (null shr-width)) + (while (setq found (re-search-forward + "\\(\\c>\\)\\| \\|\\c<\\|\\c|" + (line-end-position) 'move))) + (if (and found + (not (match-beginning 1))) (goto-char (match-beginning 0))))) (or (eolp) ;; Don't put kinsoku-bol characters at the beginning of a line, ;; or kinsoku-eol characters at the end of a line. (cond - (shr-kinsoku-shorten + ;; Don't overflow the window edge, even if shr-kinsoku-shorten + ;; is nil. + ((or shr-kinsoku-shorten (null shr-width)) (while (and (not (memq (preceding-char) (list ?\C-@ ?\n ? ))) - (shr-char-kinsoku-eol-p (preceding-char))) + (or (shr-char-kinsoku-eol-p (preceding-char)) + (shr-char-kinsoku-bol-p (following-char)))) (backward-char 1)) - (when (setq failed (= (current-column) shr-indentation)) + (when (setq failed (<= (point) start)) ;; There's no breakable point that doesn't violate kinsoku, ;; so we look for the second best position. (while (and (progn (forward-char 1) - (<= (current-column) shr-width)) + (<= (point) end)) (progn (setq bp (point)) (shr-char-kinsoku-eol-p (following-char))))) @@ -545,12 +690,12 @@ size, and full-buffer size." (not (memq (preceding-char) (list ?\C-@ ?\n ? ))) (or (shr-char-kinsoku-eol-p (preceding-char)) (shr-char-kinsoku-bol-p (following-char))))))) - (if (setq failed (= (current-column) shr-indentation)) - ;; There's no breakable point that doesn't violate kinsoku, - ;; so we go to the second best position. - (if (looking-at "\\(\\c<+\\)\\c<") - (goto-char (match-end 1)) - (forward-char 1)))) + (when (setq failed (<= (point) start)) + ;; There's no breakable point that doesn't violate kinsoku, + ;; so we go to the second best position. + (if (looking-at "\\(\\c<+\\)\\c<") + (goto-char (match-end 1)) + (forward-char 1)))) ((shr-char-kinsoku-bol-p (following-char)) ;; Find forward the point where kinsoku-bol characters end. (let ((count 4)) @@ -567,6 +712,8 @@ size, and full-buffer size." ;; Always chop off anchors. (when (string-match "#.*" url) (setq url (substring url 0 (match-beginning 0)))) + ;; NB: <base href="" > URI may itself be relative to the document s URI + (setq url (shr-expand-url url)) (let* ((parsed (url-generic-parse-url url)) (local (url-filename parsed))) (setf (url-filename parsed) "") @@ -582,19 +729,27 @@ size, and full-buffer size." (url-type parsed) url))) +(autoload 'url-expand-file-name "url-expand") + +;; FIXME This needs some tests writing. +;; Does it even need to exist, given that url-expand-file-name does? (defun shr-expand-url (url &optional base) (setq base (if base + ;; shr-parse-base should never call this with non-nil base! (shr-parse-base base) ;; Bound by the parser. shr-base)) (when (zerop (length url)) (setq url nil)) + ;; Strip leading whitespace + (and url (string-match "\\`\\s-+" url) + (setq url (substring url (match-end 0)))) (cond ((or (not url) (not base) (string-match "\\`[a-z]*:" url)) - ;; Absolute URL. - (or url (car base))) + ;; Absolute or empty URI + (or url (nth 3 base))) ((eq (aref url 0) ?/) (if (and (> (length url) 1) (eq (aref url 1) ?/)) @@ -607,7 +762,7 @@ size, and full-buffer size." (concat (nth 3 base) url)) (t ;; Totally relative. - (concat (car base) (cadr base) url)))) + (url-expand-file-name url (concat (car base) (cadr base)))))) (defun shr-ensure-newline () (unless (zerop (current-column)) @@ -615,48 +770,61 @@ size, and full-buffer size." (defun shr-ensure-paragraph () (unless (bobp) - (if (<= (current-column) shr-indentation) - (unless (save-excursion - (forward-line -1) - (looking-at " *$")) - (insert "\n")) - (if (save-excursion - (beginning-of-line) - ;; If the current line is totally blank, and doesn't even - ;; have any face properties set, then delete the blank - ;; space. - (and (looking-at " *$") - (not (get-text-property (point) 'face)) - (not (= (next-single-property-change (point) 'face nil - (line-end-position)) - (line-end-position))))) - (delete-region (match-beginning 0) (match-end 0)) - (insert "\n\n"))))) + (let ((prefix (get-text-property (line-beginning-position) + 'shr-prefix-length))) + (cond + ((and (bolp) + (save-excursion + (forward-line -1) + (looking-at " *$"))) + ;; We're already at a new paragraph; do nothing. + ) + ((and prefix + (= prefix (- (point) (line-beginning-position)))) + ;; Do nothing; we're at the start of a <li>. + ) + ((save-excursion + (beginning-of-line) + ;; If the current line is totally blank, and doesn't even + ;; have any face properties set, then delete the blank + ;; space. + (and (looking-at " *$") + (not (get-text-property (point) 'face)) + (not (= (next-single-property-change (point) 'face nil + (line-end-position)) + (line-end-position))))) + (delete-region (match-beginning 0) (match-end 0))) + (t + (insert "\n\n")))))) (defun shr-indent () (when (> shr-indentation 0) - (insert (make-string shr-indentation ? )))) - -(defun shr-fontize-cont (cont &rest types) - (let (shr-start) - (shr-generic cont) + (insert + (if (not shr-use-fonts) + (make-string shr-indentation ?\s) + (propertize " " + 'display + `(space :width (,shr-indentation))))))) + +(defun shr-fontize-dom (dom &rest types) + (let ((start (point))) + (shr-generic dom) (dolist (type types) - (shr-add-font (or shr-start (point)) (point) type)))) + (shr-add-font start (point) type)))) ;; Add face to the region, but avoid putting the font properties on ;; blank text at the start of the line, and the newline at the end, to ;; avoid ugliness. (defun shr-add-font (start end type) - (unless shr-inhibit-decoration - (save-excursion - (goto-char start) - (while (< (point) end) - (when (bolp) - (skip-chars-forward " ")) - (add-face-text-property (point) (min (line-end-position) end) type t) - (if (< (line-end-position) end) - (forward-line 1) - (goto-char end)))))) + (save-excursion + (goto-char start) + (while (< (point) end) + (when (bolp) + (skip-chars-forward " ")) + (add-face-text-property (point) (min (line-end-position) end) type t) + (if (< (line-end-position) end) + (forward-line 1) + (goto-char end))))) (defun shr-mouse-browse-url (ev) "Browse the URL under the mouse cursor." @@ -732,6 +900,10 @@ If EXTERNAL, browse the URL using `shr-external-browser'." (setq payload (base64-decode-string payload))) payload))) +;; Behind display-graphic-p test. +(declare-function image-size "image.c" (spec &optional pixels frame)) +(declare-function image-animate "image" (image &optional index limit)) + (defun shr-put-image (spec alt &optional flags) "Insert image SPEC with a string ALT. Return image. SPEC is either an image data blob, or a list where the first @@ -748,12 +920,14 @@ element is the data blob and the second element is the content-type." ((eq size 'original) (create-image data nil t :ascent 100 :format content-type)) + ((eq content-type 'image/svg+xml) + (create-image data 'svg t :ascent 100)) ((eq size 'full) (ignore-errors - (shr-rescale-image data t content-type))) + (shr-rescale-image data content-type))) (t (ignore-errors - (shr-rescale-image data nil content-type)))))) + (shr-rescale-image data content-type)))))) (when image ;; When inserting big-ish pictures, put them at the ;; beginning of the line. @@ -764,22 +938,22 @@ element is the data blob and the second element is the content-type." (insert-sliced-image image (or alt "*") nil 20 1) (insert-image image (or alt "*"))) (put-text-property start (point) 'image-size size) - (when (cond ((fboundp 'image-multi-frame-p) + (when (and shr-image-animate + (cond ((fboundp 'image-multi-frame-p) ;; Only animate multi-frame things that specify a ;; delay; eg animated gifs as opposed to ;; multi-page tiffs. FIXME? - (cdr (image-multi-frame-p image))) - ((fboundp 'image-animated-p) - (image-animated-p image))) - (image-animate image nil 60))) + (cdr (image-multi-frame-p image))) + ((fboundp 'image-animated-p) + (image-animated-p image)))) + (image-animate image nil 60))) image) (insert alt))) -(defun shr-rescale-image (data &optional force content-type) - "Rescale DATA, if too big, to fit the current buffer. -If FORCE, rescale the image anyway." - (if (or (not (fboundp 'imagemagick-types)) - (not (get-buffer-window (current-buffer)))) +(defun shr-rescale-image (data &optional content-type) + "Rescale DATA, if too big, to fit the current buffer." + (if (not (and (fboundp 'imagemagick-types) + (get-buffer-window (current-buffer)))) (create-image data nil t :ascent 100) (let ((edges (window-inside-pixel-edges (get-buffer-window (current-buffer))))) @@ -809,15 +983,28 @@ Return a string with image data." (search-forward "\r\n\r\n" nil t)) (shr-parse-image-data))))) +(declare-function libxml-parse-xml-region "xml.c" + (start end &optional base-url discard-comments)) + (defun shr-parse-image-data () - (list - (buffer-substring (point) (point-max)) - (save-excursion - (save-restriction - (narrow-to-region (point-min) (point)) - (let ((content-type (mail-fetch-field "content-type"))) - (and content-type - (intern content-type obarray))))))) + (let ((data (buffer-substring (point) (point-max))) + (content-type + (save-excursion + (save-restriction + (narrow-to-region (point-min) (point)) + (let ((content-type (mail-fetch-field "content-type"))) + (and content-type + ;; Remove any comments in the type string. + (intern (replace-regexp-in-string ";.*" "" content-type) + obarray))))))) + ;; SVG images may contain references to further images that we may + ;; want to block. So special-case these by parsing the XML data + ;; and remove the blocked bits. + (when (eq content-type 'image/svg+xml) + (setq data + (shr-dom-to-xml + (libxml-parse-xml-region (point) (point-max))))) + (list data content-type))) (defun shr-image-displayer (content-function) "Return a function to display an image. @@ -839,18 +1026,22 @@ START, and END. Note that START and END should be markers." (list (current-buffer) start end) t t))))) -(defun shr-heading (cont &rest types) +(defun shr-heading (dom &rest types) (shr-ensure-paragraph) - (apply #'shr-fontize-cont cont types) + (apply #'shr-fontize-dom dom types) (shr-ensure-paragraph)) (defun shr-urlify (start url &optional title) - (when (and title (string-match "ctx" title)) (debug)) (shr-add-font start (point) 'shr-link) (add-text-properties start (point) (list 'shr-url url - 'help-echo (if title (format "%s (%s)" url title) url) + 'help-echo (let ((iri (or (ignore-errors + (decode-coding-string + (url-unhex-string url) + 'utf-8 t)) + url))) + (if title (format "%s (%s)" iri title) iri)) 'follow-link t 'mouse-face 'highlight 'keymap shr-map))) @@ -885,8 +1076,7 @@ ones, in case fg and bg are nil." (shr-color-visible bg fg))))))) (defun shr-colorize-region (start end fg &optional bg) - (when (and (not shr-inhibit-decoration) - (or fg bg)) + (when (and (or fg bg) (>= (display-color-cells) 88)) (let ((new-colors (shr-color-check fg bg))) (when new-colors (when fg @@ -899,44 +1089,6 @@ ones, in case fg and bg are nil." t))) new-colors))) -(defun shr-expand-newlines (start end color) - (save-restriction - ;; Skip past all white space at the start and ends. - (goto-char start) - (skip-chars-forward " \t\n") - (beginning-of-line) - (setq start (point)) - (goto-char end) - (skip-chars-backward " \t\n") - (forward-line 1) - (setq end (point)) - (narrow-to-region start end) - (let ((width (shr-buffer-width)) - column) - (goto-char (point-min)) - (while (not (eobp)) - (end-of-line) - (when (and (< (setq column (current-column)) width) - (< (setq column (shr-previous-newline-padding-width column)) - width)) - (let ((overlay (make-overlay (point) (1+ (point))))) - (overlay-put overlay 'before-string - (concat - (mapconcat - (lambda (overlay) - (let ((string (plist-get - (overlay-properties overlay) - 'before-string))) - (if (not string) - "" - (overlay-put overlay 'before-string "") - string))) - (overlays-at (point)) - "") - (propertize (make-string (- width column) ? ) - 'face (list :background color)))))) - (forward-line 1))))) - (defun shr-previous-newline-padding-width (width) (let ((overlays (overlays-at (point))) (previous-width 0)) @@ -951,97 +1103,108 @@ ones, in case fg and bg are nil." ;;; Tag-specific rendering rules. -(defun shr-tag-body (cont) +(defun shr-tag-body (dom) (let* ((start (point)) - (fgcolor (cdr (or (assq :fgcolor cont) - (assq :text cont)))) - (bgcolor (cdr (assq :bgcolor cont))) + (fgcolor (or (dom-attr dom 'fgcolor) (dom-attr dom 'text))) + (bgcolor (dom-attr dom 'bgcolor)) (shr-stylesheet (list (cons 'color fgcolor) (cons 'background-color bgcolor)))) - (shr-generic cont) + (shr-generic dom) (shr-colorize-region start (point) fgcolor bgcolor))) -(defun shr-tag-style (cont) +(defun shr-tag-style (_dom) ) -(defun shr-tag-script (cont) +(defun shr-tag-script (_dom) ) -(defun shr-tag-comment (cont) +(defun shr-tag-comment (_dom) ) (defun shr-dom-to-xml (dom) + (with-temp-buffer + (shr-dom-print dom) + (buffer-string))) + +(defun shr-dom-print (dom) "Convert DOM into a string containing the xml representation." - (let ((arg " ") - (text "")) - (dolist (sub (cdr dom)) + (insert (format "<%s" (dom-tag dom))) + (dolist (attr (dom-attributes dom)) + ;; Ignore attributes that start with a colon because they are + ;; private elements. + (unless (= (aref (format "%s" (car attr)) 0) ?:) + (insert (format " %s=\"%s\"" (car attr) (cdr attr))))) + (insert ">") + (let (url) + (dolist (elem (dom-children dom)) (cond - ((listp (cdr sub)) - (setq text (concat text (shr-dom-to-xml sub)))) - ((eq (car sub) 'text) - (setq text (concat text (cdr sub)))) - (t - (setq arg (concat arg (format "%s=\"%s\" " - (substring (symbol-name (car sub)) 1) - (cdr sub))))))) - (format "<%s%s>%s</%s>" - (car dom) - (substring arg 0 (1- (length arg))) - text - (car dom)))) - -(defun shr-tag-svg (cont) - (when (image-type-available-p 'svg) - (funcall shr-put-image-function - (shr-dom-to-xml (cons 'svg cont)) - "SVG Image"))) - -(defun shr-tag-sup (cont) + ((stringp elem) + (insert elem)) + ((eq (dom-tag elem) 'comment) + ) + ((or (not (eq (dom-tag elem) 'image)) + ;; Filter out blocked elements inside the SVG image. + (not (setq url (dom-attr elem ':xlink:href))) + (not shr-blocked-images) + (not (string-match shr-blocked-images url))) + (insert " ") + (shr-dom-print elem))))) + (insert (format "</%s>" (dom-tag dom)))) + +(defun shr-tag-svg (dom) + (when (and (image-type-available-p 'svg) + (not shr-inhibit-images)) + (funcall shr-put-image-function (list (shr-dom-to-xml dom) 'image/svg+xml) + "SVG Image"))) + +(defun shr-tag-sup (dom) (let ((start (point))) - (shr-generic cont) + (shr-generic dom) (put-text-property start (point) 'display '(raise 0.5)))) -(defun shr-tag-sub (cont) +(defun shr-tag-sub (dom) (let ((start (point))) - (shr-generic cont) + (shr-generic dom) (put-text-property start (point) 'display '(raise -0.5)))) -(defun shr-tag-label (cont) - (shr-generic cont) +(defun shr-tag-label (dom) + (shr-generic dom) (shr-ensure-paragraph)) -(defun shr-tag-p (cont) +(defun shr-tag-p (dom) (shr-ensure-paragraph) - (shr-indent) - (shr-generic cont) + (shr-generic dom) (shr-ensure-paragraph)) -(defun shr-tag-div (cont) +(defun shr-tag-div (dom) (shr-ensure-newline) - (shr-indent) - (shr-generic cont) + (shr-generic dom) (shr-ensure-newline)) -(defun shr-tag-s (cont) - (shr-fontize-cont cont 'shr-strike-through)) +(defun shr-tag-s (dom) + (shr-fontize-dom dom 'shr-strike-through)) -(defun shr-tag-del (cont) - (shr-fontize-cont cont 'shr-strike-through)) +(defun shr-tag-del (dom) + (shr-fontize-dom dom 'shr-strike-through)) -(defun shr-tag-b (cont) - (shr-fontize-cont cont 'bold)) +(defun shr-tag-b (dom) + (shr-fontize-dom dom 'bold)) -(defun shr-tag-i (cont) - (shr-fontize-cont cont 'italic)) +(defun shr-tag-i (dom) + (shr-fontize-dom dom 'italic)) -(defun shr-tag-em (cont) - (shr-fontize-cont cont 'italic)) +(defun shr-tag-em (dom) + (shr-fontize-dom dom 'italic)) -(defun shr-tag-strong (cont) - (shr-fontize-cont cont 'bold)) +(defun shr-tag-strong (dom) + (shr-fontize-dom dom 'bold)) -(defun shr-tag-u (cont) - (shr-fontize-cont cont 'underline)) +(defun shr-tag-u (dom) + (shr-fontize-dom dom 'underline)) + +(defun shr-tag-tt (dom) + (let ((shr-current-font 'default)) + (shr-generic dom))) (defun shr-parse-style (style) (when style @@ -1058,63 +1221,145 @@ ones, in case fg and bg are nil." (value (replace-regexp-in-string "^ +\\| +$" "" (cadr elem)))) (when (string-match " *!important\\'" value) (setq value (substring value 0 (match-beginning 0)))) - (push (cons (intern name obarray) - value) - plist))))) + (unless (equal value "inherit") + (push (cons (intern name obarray) + value) + plist)))))) plist))) -(defun shr-tag-base (cont) - (let ((base (cdr (assq :href cont)))) - (when base - (setq shr-base (shr-parse-base base)))) - (shr-generic cont)) +(defun shr-tag-base (dom) + (when-let (base (dom-attr dom 'href)) + (setq shr-base (shr-parse-base base))) + (shr-generic dom)) -(defun shr-tag-a (cont) - (let ((url (cdr (assq :href cont))) - (title (cdr (assq :title cont))) +(defun shr-tag-a (dom) + (let ((url (dom-attr dom 'href)) + (title (dom-attr dom 'title)) (start (point)) shr-start) - (shr-generic cont) - (when (and url - (not shr-inhibit-decoration)) + (shr-generic dom) + (when (and shr-target-id + (equal (dom-attr dom 'name) shr-target-id)) + ;; We have a zero-length <a name="foo"> element, so just + ;; insert... something. + (when (= start (point)) + (shr-ensure-newline) + (insert " ")) + (put-text-property start (1+ start) 'shr-target-id shr-target-id)) + (when url (shr-urlify (or shr-start start) (shr-expand-url url) title)))) -(defun shr-tag-object (cont) - (let ((start (point)) - url) - (dolist (elem cont) - (when (eq (car elem) 'embed) - (setq url (or url (cdr (assq :src (cdr elem)))))) - (when (and (eq (car elem) 'param) - (equal (cdr (assq :name (cdr elem))) "movie")) - (setq url (or url (cdr (assq :value (cdr elem))))))) - (when url - (shr-insert " [multimedia] ") - (shr-urlify start (shr-expand-url url))) - (shr-generic cont))) +(defun shr-tag-object (dom) + (unless shr-inhibit-images + (let ((start (point)) + url multimedia image) + (when-let (type (dom-attr dom 'type)) + (when (string-match "\\`image/svg" type) + (setq url (dom-attr dom 'data) + image t))) + (dolist (child (dom-non-text-children dom)) + (cond + ((eq (dom-tag child) 'embed) + (setq url (or url (dom-attr child 'src)) + multimedia t)) + ((and (eq (dom-tag child) 'param) + (equal (dom-attr child 'name) "movie")) + (setq url (or url (dom-attr child 'value)) + multimedia t)))) + (when url + (cond + (image + (shr-tag-img dom url) + (setq dom nil)) + (multimedia + (shr-insert " [multimedia] ") + (shr-urlify start (shr-expand-url url))))) + (when dom + (shr-generic dom))))) + +(defcustom shr-prefer-media-type-alist '(("webm" . 1.0) + ("ogv" . 1.0) + ("ogg" . 1.0) + ("opus" . 1.0) + ("flac" . 0.9) + ("wav" . 0.5)) + "Preferences for media types. +The key element should be a regexp matched against the type of the source or +url if no type is specified. The value should be a float in the range 0.0 to +1.0. Media elements with higher value are preferred." + :version "24.4" + :group 'shr + :type '(alist :key-type regexp :value-type float)) + +(defun shr--get-media-pref (elem) + "Determine the preference for ELEM. +The preference is a float determined from `shr-prefer-media-type'." + (let ((type (dom-attr elem 'type)) + (p 0.0)) + (unless type + (setq type (dom-attr elem 'src))) + (when type + (dolist (pref shr-prefer-media-type-alist) + (when (and + (> (cdr pref) p) + (string-match-p (car pref) type)) + (setq p (cdr pref))))) + p)) + +(defun shr--extract-best-source (dom &optional url pref) + "Extract the best `:src' property from <source> blocks in DOM." + (setq pref (or pref -1.0)) + (let (new-pref) + (dolist (elem (dom-non-text-children dom)) + (when (and (eq (dom-tag elem) 'source) + (< pref + (setq new-pref + (shr--get-media-pref elem)))) + (setq pref new-pref + url (dom-attr elem 'src)) + ;; libxml's html parser isn't HTML5 compliant and non terminated + ;; source tags might end up as children. So recursion it is... + (dolist (child (dom-non-text-children elem)) + (when (eq (dom-tag child) 'source) + (let ((ret (shr--extract-best-source (list child) url pref))) + (when (< pref (cdr ret)) + (setq url (car ret) + pref (cdr ret))))))))) + (cons url pref)) + +(defun shr-tag-video (dom) + (let ((image (dom-attr dom 'poster)) + (url (dom-attr dom 'src)) + (start (point))) + (unless url + (setq url (car (shr--extract-best-source dom)))) + (if image + (shr-tag-img nil image) + (shr-insert " [video] ")) + (shr-urlify start (shr-expand-url url)))) -(defun shr-tag-video (cont) - (let ((image (cdr (assq :poster cont))) - (url (cdr (assq :src cont))) - (start (point))) - (shr-tag-img nil image) +(defun shr-tag-audio (dom) + (let ((url (dom-attr dom 'src)) + (start (point))) + (unless url + (setq url (car (shr--extract-best-source dom)))) + (shr-insert " [audio] ") (shr-urlify start (shr-expand-url url)))) -(defun shr-tag-img (cont &optional url) +(defun shr-tag-img (dom &optional url) (when (or url - (and cont - (cdr (assq :src cont)))) - (when (and (> (current-column) 0) - (not (eq shr-state 'image))) + (and dom + (> (length (dom-attr dom 'src)) 0))) + (when (> (current-column) 0) (insert "\n")) - (let ((alt (cdr (assq :alt cont))) - (url (shr-expand-url (or url (cdr (assq :src cont)))))) + (let ((alt (dom-attr dom 'alt)) + (url (shr-expand-url (or url (dom-attr dom 'src))))) (let ((start (point-marker))) (when (zerop (length alt)) (setq alt "*")) (cond - ((or (member (cdr (assq :height cont)) '("0" "1")) - (member (cdr (assq :width cont)) '("0" "1"))) + ((or (member (dom-attr dom 'height) '("0" "1")) + (member (dom-attr dom 'width) '("0" "1"))) ;; Ignore zero-sized or single-pixel images. ) ((and (not shr-inhibit-images) @@ -1135,10 +1380,9 @@ ones, in case fg and bg are nil." (and shr-blocked-images (string-match shr-blocked-images url))) (setq shr-start (point)) - (let ((shr-state 'space)) - (if (> (string-width alt) 8) - (shr-insert (truncate-string-to-width alt 8)) - (shr-insert alt)))) + (if (> (string-width alt) 8) + (shr-insert (truncate-string-to-width alt 8)) + (shr-insert alt))) ((and (not shr-ignore-cache) (url-is-cached (shr-encode-url url))) (funcall shr-put-image-function (shr-get-image-data url) alt)) @@ -1159,108 +1403,131 @@ ones, in case fg and bg are nil." (put-text-property start (point) 'image-url url) (put-text-property start (point) 'image-displayer (shr-image-displayer shr-content-function)) - (put-text-property start (point) 'help-echo alt)) - (setq shr-state 'image))))) + (put-text-property start (point) 'help-echo + (shr-fill-text + (or (dom-attr dom 'title) alt)))))))) -(defun shr-tag-pre (cont) - (let ((shr-folding-mode 'none)) +(defun shr-tag-pre (dom) + (let ((shr-folding-mode 'none) + (shr-current-font 'default)) (shr-ensure-newline) - (shr-indent) - (shr-generic cont) + (shr-generic dom) (shr-ensure-newline))) -(defun shr-tag-blockquote (cont) +(defun shr-tag-blockquote (dom) (shr-ensure-paragraph) - (shr-indent) - (let ((shr-indentation (+ shr-indentation 4))) - (shr-generic cont)) - (shr-ensure-paragraph)) + (let ((start (point)) + (shr-indentation (+ shr-indentation + (* 4 shr-table-separator-pixel-width)))) + (shr-generic dom) + (shr-ensure-paragraph) + (shr-mark-fill start))) -(defun shr-tag-dl (cont) +(defun shr-tag-dl (dom) (shr-ensure-paragraph) - (shr-generic cont) + (shr-generic dom) (shr-ensure-paragraph)) -(defun shr-tag-dt (cont) +(defun shr-tag-dt (dom) (shr-ensure-newline) - (shr-generic cont) + (shr-generic dom) (shr-ensure-newline)) -(defun shr-tag-dd (cont) +(defun shr-tag-dd (dom) (shr-ensure-newline) - (let ((shr-indentation (+ shr-indentation 4))) - (shr-generic cont))) + (let ((shr-indentation (+ shr-indentation + (* 4 shr-table-separator-pixel-width)))) + (shr-generic dom))) -(defun shr-tag-ul (cont) +(defun shr-tag-ul (dom) (shr-ensure-paragraph) (let ((shr-list-mode 'ul)) - (shr-generic cont)) + (shr-generic dom)) (shr-ensure-paragraph)) -(defun shr-tag-ol (cont) +(defun shr-tag-ol (dom) (shr-ensure-paragraph) (let ((shr-list-mode 1)) - (shr-generic cont)) + (shr-generic dom)) (shr-ensure-paragraph)) -(defun shr-tag-li (cont) +(defun shr-tag-li (dom) (shr-ensure-newline) - (shr-indent) - (let* ((bullet - (if (numberp shr-list-mode) - (prog1 - (format "%d " shr-list-mode) - (setq shr-list-mode (1+ shr-list-mode))) - shr-bullet)) - (shr-indentation (+ shr-indentation (length bullet)))) - (insert bullet) - (shr-generic cont))) - -(defun shr-tag-br (cont) + (let ((start (point))) + (let* ((bullet + (if (numberp shr-list-mode) + (prog1 + (format "%d " shr-list-mode) + (setq shr-list-mode (1+ shr-list-mode))) + (car shr-internal-bullet))) + (width (if (numberp shr-list-mode) + (shr-string-pixel-width bullet) + (cdr shr-internal-bullet)))) + (insert bullet) + (shr-mark-fill start) + (let ((shr-indentation (+ shr-indentation width))) + (put-text-property start (1+ start) + 'shr-continuation-indentation shr-indentation) + (put-text-property start (1+ start) 'shr-prefix-length (length bullet)) + (shr-generic dom))))) + +(defun shr-mark-fill (start) + ;; We may not have inserted any text to fill. + (unless (= start (point)) + (put-text-property start (1+ start) + 'shr-indentation shr-indentation))) + +(defun shr-tag-br (dom) (when (and (not (bobp)) ;; Only add a newline if we break the current line, or ;; the previous line isn't a blank line. (or (not (bolp)) (and (> (- (point) 2) (point-min)) (not (= (char-after (- (point) 2)) ?\n))))) - (insert "\n") - (shr-indent)) - (shr-generic cont)) + (insert "\n")) + (shr-generic dom)) -(defun shr-tag-span (cont) - (shr-generic cont)) +(defun shr-tag-span (dom) + (shr-generic dom)) -(defun shr-tag-h1 (cont) - (shr-heading cont 'bold 'underline)) +(defun shr-tag-h1 (dom) + (shr-heading dom (if shr-use-fonts + '(variable-pitch (:height 1.3 :weight bold)) + 'bold))) -(defun shr-tag-h2 (cont) - (shr-heading cont 'bold)) +(defun shr-tag-h2 (dom) + (shr-heading dom 'bold)) -(defun shr-tag-h3 (cont) - (shr-heading cont 'italic)) +(defun shr-tag-h3 (dom) + (shr-heading dom 'italic)) -(defun shr-tag-h4 (cont) - (shr-heading cont)) +(defun shr-tag-h4 (dom) + (shr-heading dom)) -(defun shr-tag-h5 (cont) - (shr-heading cont)) +(defun shr-tag-h5 (dom) + (shr-heading dom)) -(defun shr-tag-h6 (cont) - (shr-heading cont)) +(defun shr-tag-h6 (dom) + (shr-heading dom)) -(defun shr-tag-hr (cont) +(defun shr-tag-hr (_dom) (shr-ensure-newline) - (insert (make-string shr-width shr-hr-line) "\n")) + (insert (make-string (if (not shr-use-fonts) + shr-internal-width + (1+ (/ shr-internal-width + shr-table-separator-pixel-width))) + shr-hr-line) + "\n")) -(defun shr-tag-title (cont) - (shr-heading cont 'bold 'underline)) +(defun shr-tag-title (dom) + (shr-heading dom 'bold 'underline)) -(defun shr-tag-font (cont) +(defun shr-tag-font (dom) (let* ((start (point)) - (color (cdr (assq :color cont))) + (color (dom-attr dom 'color)) (shr-stylesheet (nconc (list (cons 'color color)) shr-stylesheet))) - (shr-generic cont) + (shr-generic dom) (when color (shr-colorize-region start (point) color (cdr (assq 'background-color shr-stylesheet)))))) @@ -1275,40 +1542,43 @@ ones, in case fg and bg are nil." ;; main buffer). Now we know how much space each TD really takes, so ;; we then render everything again with the new widths, and finally ;; insert all these boxes into the main buffer. -(defun shr-tag-table-1 (cont) - (setq cont (or (cdr (assq 'tbody cont)) - cont)) +(defun shr-tag-table-1 (dom) + (setq dom (or (dom-child-by-tag dom 'tbody) dom)) (let* ((shr-inhibit-images t) (shr-table-depth (1+ shr-table-depth)) (shr-kinsoku-shorten t) ;; Find all suggested widths. - (columns (shr-column-specs cont)) - ;; Compute how many characters wide each TD should be. + (columns (shr-column-specs dom)) + ;; Compute how many pixels wide each TD should be. (suggested-widths (shr-pro-rate-columns columns)) ;; Do a "test rendering" to see how big each TD is (this can ;; be smaller (if there's little text) or bigger (if there's ;; unbreakable text). - (sketch (shr-make-table cont suggested-widths)) - ;; Compute the "natural" width by setting each column to 500 - ;; characters and see how wide they really render. - (natural (shr-make-table cont (make-vector (length columns) 500))) + (elems (or (dom-attr dom 'shr-suggested-widths) + (shr-make-table dom suggested-widths nil + 'shr-suggested-widths))) + (sketch (loop for line in elems + collect (mapcar #'car line))) + (natural (loop for line in elems + collect (mapcar #'cdr line))) (sketch-widths (shr-table-widths sketch natural suggested-widths))) ;; This probably won't work very well. (when (> (+ (loop for width across sketch-widths summing (1+ width)) - shr-indentation 1) + shr-indentation shr-table-separator-pixel-width) (frame-width)) (setq truncate-lines t)) ;; Then render the table again with these new "hard" widths. - (shr-insert-table (shr-make-table cont sketch-widths t) sketch-widths))) + (shr-insert-table (shr-make-table dom sketch-widths t) sketch-widths))) -(defun shr-tag-table (cont) +(defun shr-tag-table (dom) (shr-ensure-paragraph) - (let* ((caption (cdr (assq 'caption cont))) - (header (cdr (assq 'thead cont))) - (body (or (cdr (assq 'tbody cont)) cont)) - (footer (cdr (assq 'tfoot cont))) - (bgcolor (cdr (assq :bgcolor cont))) + (let* ((caption (dom-children (dom-child-by-tag dom 'caption))) + (header (dom-non-text-children (dom-child-by-tag dom 'thead))) + (body (dom-non-text-children (or (dom-child-by-tag dom 'tbody) + dom))) + (footer (dom-non-text-children (dom-child-by-tag dom 'tfoot))) + (bgcolor (dom-attr dom 'bgcolor)) (start (point)) (shr-stylesheet (nconc (list (cons 'background-color bgcolor)) shr-stylesheet)) @@ -1317,51 +1587,78 @@ ones, in case fg and bg are nil." (nfooter (if footer (shr-max-columns footer)))) (if (and (not caption) (not header) - (not (cdr (assq 'tbody cont))) - (not (cdr (assq 'tr cont))) + (not (dom-child-by-tag dom 'tbody)) + (not (dom-child-by-tag dom 'tr)) (not footer)) ;; The table is totally invalid and just contains random junk. ;; Try to output it anyway. - (shr-generic cont) + (shr-generic dom) ;; It's a real table, so render it. - (shr-tag-table-1 - (nconc - (if caption `((tr (td ,@caption)))) - (if header - (if footer - ;; hader + body + footer - (if (= nheader nbody) - (if (= nbody nfooter) - `((tr (td (table (tbody ,@header ,@body ,@footer))))) - (nconc `((tr (td (table (tbody ,@header ,@body))))) - (if (= nfooter 1) - footer - `((tr (td (table (tbody ,@footer)))))))) - (nconc `((tr (td (table (tbody ,@header))))) - (if (= nbody nfooter) - `((tr (td (table (tbody ,@body ,@footer))))) - (nconc `((tr (td (table (tbody ,@body))))) - (if (= nfooter 1) - footer - `((tr (td (table (tbody ,@footer)))))))))) - ;; header + body - (if (= nheader nbody) - `((tr (td (table (tbody ,@header ,@body))))) - (if (= nheader 1) - `(,@header (tr (td (table (tbody ,@body))))) - `((tr (td (table (tbody ,@header)))) - (tr (td (table (tbody ,@body)))))))) - (if footer - ;; body + footer - (if (= nbody nfooter) - `((tr (td (table (tbody ,@body ,@footer))))) - (nconc `((tr (td (table (tbody ,@body))))) - (if (= nfooter 1) - footer - `((tr (td (table (tbody ,@footer)))))))) - (if caption - `((tr (td (table (tbody ,@body))))) - body)))))) + (if (dom-attr dom 'shr-fixed-table) + (shr-tag-table-1 dom) + ;; Only fix up the table once. + (let ((table + (nconc + (list 'table nil) + (if caption `((tr nil (td nil ,@caption)))) + (cond + (header + (if footer + ;; header + body + footer + (if (= nheader nbody) + (if (= nbody nfooter) + `((tr nil (td nil (table nil + (tbody nil ,@header + ,@body ,@footer))))) + (nconc `((tr nil (td nil (table nil + (tbody nil ,@header + ,@body))))) + (if (= nfooter 1) + footer + `((tr nil (td nil (table + nil (tbody + nil ,@footer)))))))) + (nconc `((tr nil (td nil (table nil (tbody + nil ,@header))))) + (if (= nbody nfooter) + `((tr nil (td nil (table + nil (tbody nil ,@body + ,@footer))))) + (nconc `((tr nil (td nil (table + nil (tbody nil + ,@body))))) + (if (= nfooter 1) + footer + `((tr nil (td nil (table + nil + (tbody + nil + ,@footer)))))))))) + ;; header + body + (if (= nheader nbody) + `((tr nil (td nil (table nil (tbody nil ,@header + ,@body))))) + (if (= nheader 1) + `(,@header (tr nil (td nil (table + nil (tbody nil ,@body))))) + `((tr nil (td nil (table nil (tbody nil ,@header)))) + (tr nil (td nil (table nil (tbody nil ,@body))))))))) + (footer + ;; body + footer + (if (= nbody nfooter) + `((tr nil (td nil (table + nil (tbody nil ,@body ,@footer))))) + (nconc `((tr nil (td nil (table nil (tbody nil ,@body))))) + (if (= nfooter 1) + footer + `((tr nil (td nil (table + nil (tbody nil ,@footer))))))))) + (caption + `((tr nil (td nil (table nil (tbody nil ,@body)))))) + (body))))) + (dom-set-attribute table 'shr-fixed-table t) + (setcdr dom (cdr table)) + (shr-tag-table-1 dom)))) (when bgcolor (shr-colorize-region start (point) (cdr (assq 'color shr-stylesheet)) bgcolor)) @@ -1369,54 +1666,113 @@ ones, in case fg and bg are nil." ;; model isn't strong enough to allow us to put the images actually ;; into the tables. (when (zerop shr-table-depth) - (dolist (elem (shr-find-elements cont 'img)) - (shr-tag-img (cdr elem)))))) - -(defun shr-find-elements (cont type) - (let (result) - (dolist (elem cont) - (cond ((eq (car elem) type) - (push elem result)) - ((consp (cdr elem)) - (setq result (nconc (shr-find-elements (cdr elem) type) result))))) - (nreverse result))) + (save-excursion + (shr-expand-alignments start (point))) + (dolist (elem (dom-by-tag dom 'object)) + (shr-tag-object elem)) + (dolist (elem (dom-by-tag dom 'img)) + (shr-tag-img elem))))) (defun shr-insert-table (table widths) (let* ((collapse (equal (cdr (assq 'border-collapse shr-stylesheet)) "collapse")) (shr-table-separator-length (if collapse 0 1)) - (shr-table-vertical-line (if collapse "" shr-table-vertical-line))) + (shr-table-vertical-line (if collapse "" shr-table-vertical-line)) + (start (point))) + (setq shr-table-id (1+ shr-table-id)) (unless collapse (shr-insert-table-ruler widths)) (dolist (row table) (let ((start (point)) + (align 0) + (column-number 0) (height (let ((max 0)) (dolist (column row) - (setq max (max max (cadr column)))) + (setq max (max max (nth 2 column)))) max))) - (dotimes (i height) + (dotimes (i (max height 1)) (shr-indent) (insert shr-table-vertical-line "\n")) (dolist (column row) - (goto-char start) - (let ((lines (nth 2 column))) - (dolist (line lines) - (end-of-line) - (insert line shr-table-vertical-line) - (forward-line 1)) - ;; Add blank lines at padding at the bottom of the TD, - ;; possibly. - (dotimes (i (- height (length lines))) - (end-of-line) - (let ((start (point))) - (insert (make-string (string-width (car lines)) ? ) - shr-table-vertical-line) - (when (nth 4 column) - (shr-add-font start (1- (point)) - (list :background (nth 4 column))))) - (forward-line 1))))) + (when (> (nth 2 column) -1) + (goto-char start) + ;; Sum up all the widths from the column. (There may be + ;; more than one if this is a "colspan" column.) + (dotimes (i (nth 4 column)) + ;; The colspan directive may be wrong and there may not be + ;; that number of columns. + (when (<= column-number (1- (length widths))) + (setq align (+ align + (aref widths column-number) + (* 2 shr-table-separator-pixel-width)))) + (setq column-number (1+ column-number))) + (let ((lines (nth 3 column)) + (pixel-align (if (not shr-use-fonts) + (* align (frame-char-width)) + align))) + (dolist (line lines) + (end-of-line) + (let ((start (point))) + (insert + line + (propertize " " + 'display `(space :align-to (,pixel-align)) + 'face (and (> (length line) 0) + (shr-face-background + (get-text-property + (1- (length line)) 'face line))) + 'shr-table-indent shr-table-id) + shr-table-vertical-line) + (shr-colorize-region + start (1- (point)) (nth 5 column) (nth 6 column))) + (forward-line 1)) + ;; Add blank lines at padding at the bottom of the TD, + ;; possibly. + (dotimes (i (- height (length lines))) + (end-of-line) + (let ((start (point))) + (insert (propertize " " + 'display `(space :align-to (,pixel-align)) + 'shr-table-indent shr-table-id) + shr-table-vertical-line) + (shr-colorize-region + start (1- (point)) (nth 5 column) (nth 6 column))) + (forward-line 1)))))) (unless collapse - (shr-insert-table-ruler widths))))) + (shr-insert-table-ruler widths))) + (unless (= start (point)) + (put-text-property start (1+ start) 'shr-table-id shr-table-id)))) + +(defun shr-face-background (face) + (and (consp face) + (let ((background nil)) + (dolist (elem face) + (when (and (consp elem) + (eq (car elem) :background)) + (setq background (cadr elem)))) + (and background + (list :background background))))) + +(defun shr-expand-alignments (start end) + (while (< (setq start (next-single-property-change + start 'shr-table-id nil end)) + end) + (goto-char start) + (let* ((shr-use-fonts t) + (id (get-text-property (point) 'shr-table-id)) + (base (shr-pixel-column)) + elem) + (when id + (save-excursion + (while (setq elem (text-property-any + (point) end 'shr-table-indent id)) + (goto-char elem) + (let ((align (get-text-property (point) 'display))) + (put-text-property (point) (1+ (point)) 'display + `(space :align-to (,(+ (car (nth 2 align)) + base))))) + (forward-char 1))))) + (setq start (1+ start)))) (defun shr-insert-table-ruler (widths) (when shr-table-horizontal-line @@ -1424,9 +1780,17 @@ ones, in case fg and bg are nil." (> shr-indentation 0)) (shr-indent)) (insert shr-table-corner) - (dotimes (i (length widths)) - (insert (make-string (aref widths i) shr-table-horizontal-line) - shr-table-corner)) + (let ((total-width 0)) + (dotimes (i (length widths)) + (setq total-width (+ total-width (aref widths i) + (* shr-table-separator-pixel-width 2))) + (insert (make-string (1+ (/ (aref widths i) + shr-table-separator-pixel-width)) + shr-table-horizontal-line) + (propertize " " + 'display `(space :align-to (,total-width)) + 'shr-table-indent shr-table-id) + shr-table-corner))) (insert "\n"))) (defun shr-table-widths (table natural-table suggested-widths) @@ -1444,7 +1808,8 @@ ones, in case fg and bg are nil." (aset natural-widths i (max (aref natural-widths i) column)) (setq i (1+ i))))) (let ((extra (- (apply '+ (append suggested-widths nil)) - (apply '+ (append widths nil)))) + (apply '+ (append widths nil)) + (* shr-table-separator-pixel-width (1+ (length widths))))) (expanded-columns 0)) ;; We have extra, unused space, so divide this space amongst the ;; columns. @@ -1462,22 +1827,25 @@ ones, in case fg and bg are nil." (aref widths i)))))))) widths)) -(defun shr-make-table (cont widths &optional fill) - (or (cadr (assoc (list cont widths fill) shr-content-cache)) - (let ((data (shr-make-table-1 cont widths fill))) - (push (list (list cont widths fill) data) +(defun shr-make-table (dom widths &optional fill storage-attribute) + (or (cadr (assoc (list dom widths fill) shr-content-cache)) + (let ((data (shr-make-table-1 dom widths fill))) + (push (list (list dom widths fill) data) shr-content-cache) + (when storage-attribute + (dom-set-attribute dom storage-attribute data)) data))) -(defun shr-make-table-1 (cont widths &optional fill) +(defun shr-make-table-1 (dom widths &optional fill) (let ((trs nil) - (shr-inhibit-decoration (not fill)) (rowspans (make-vector (length widths) 0)) + (colspan-remaining 0) + colspan-width colspan-count width colspan) - (dolist (row cont) - (when (eq (car row) 'tr) + (dolist (row (dom-non-text-children dom)) + (when (eq (dom-tag row) 'tr) (let ((tds nil) - (columns (cdr row)) + (columns (dom-non-text-children row)) (i 0) (width-column 0) column) @@ -1491,61 +1859,137 @@ ones, in case fg and bg are nil." (pop columns) (aset rowspans i (1- (aref rowspans i))) '(td))) - (when (or (memq (car column) '(td th)) - (not column)) - (when (cdr (assq :rowspan (cdr column))) + (when (and (not (stringp column)) + (or (memq (dom-tag column) '(td th)) + (not column))) + (when-let (span (dom-attr column 'rowspan)) (aset rowspans i (+ (aref rowspans i) - (1- (string-to-number - (cdr (assq :rowspan (cdr column)))))))) + (1- (string-to-number span))))) ;; Sanity check for invalid column-spans. (when (>= width-column (length widths)) (setq width-column 0)) (setq width (if column (aref widths width-column) - 10)) - (when (and fill - (setq colspan (cdr (assq :colspan (cdr column))))) + (* 10 shr-table-separator-pixel-width))) + (when (setq colspan (dom-attr column 'colspan)) (setq colspan (min (string-to-number colspan) ;; The colspan may be wrong, so ;; truncate it to the length of the ;; remaining columns. (- (length widths) i))) (dotimes (j (1- colspan)) - (if (> (+ i 1 j) (1- (length widths))) - (setq width (aref widths (1- (length widths)))) - (setq width (+ width - shr-table-separator-length - (aref widths (+ i 1 j)))))) - (setq width-column (+ width-column (1- colspan)))) - (when (or column - (not fill)) - (push (shr-render-td (cdr column) width fill) - tds)) + (setq width + (if (> (+ i 1 j) (1- (length widths))) + ;; If we have a colspan spec that's longer + ;; than the table is wide, just use the last + ;; width as the width. + (aref widths (1- (length widths))) + ;; Sum up the widths of the columns we're + ;; spanning. + (+ width + shr-table-separator-length + (aref widths (+ i 1 j)))))) + (setq width-column (+ width-column (1- colspan)) + colspan-count colspan + colspan-remaining colspan)) + (when column + (let ((data (shr-render-td column width fill))) + (if (and (not fill) + (> colspan-remaining 0)) + (progn + (setq colspan-width (car data)) + (let ((this-width (/ colspan-width colspan-count))) + (push (cons this-width (cadr data)) tds) + (setq colspan-remaining (1- colspan-remaining)))) + (if (not fill) + (push (cons (car data) (cadr data)) tds) + (push data tds))))) + (when (and colspan + (> colspan 1)) + (dotimes (c (1- colspan)) + (setq i (1+ i)) + (push + (if fill + (list 0 0 -1 nil 1 nil nil) + '(0 . 0)) + tds))) (setq i (1+ i) width-column (1+ width-column)))) (push (nreverse tds) trs)))) (nreverse trs))) -(defun shr-render-td (cont width fill) +(defun shr-pixel-buffer-width () + (if (not shr-use-fonts) + (save-excursion + (goto-char (point-min)) + (let ((max 0)) + (while (not (eobp)) + (end-of-line) + (setq max (max max (current-column))) + (forward-line 1)) + max)) + (if (get-buffer-window) + (car (window-text-pixel-size nil (point-min) (point-max))) + (save-window-excursion + (set-window-buffer nil (current-buffer)) + (car (window-text-pixel-size nil (point-min) (point-max))))))) + +(defun shr-render-td (dom width fill) + (let ((cache (intern (format "shr-td-cache-%s-%s" width fill)))) + (or (dom-attr dom cache) + (and fill + (let (result) + (dolist (attr (dom-attributes dom)) + (let ((name (symbol-name (car attr)))) + (when (string-match "shr-td-cache-\\([0-9]+\\)-nil" name) + (let ((cache-width (string-to-number + (match-string 1 name)))) + (when (and (>= cache-width width) + (<= (car (cdr attr)) width)) + (setq result (cdr attr))))))) + result)) + (let ((result (shr-render-td-1 dom width fill))) + (dom-set-attribute dom cache result) + result)))) + +(defun shr-render-td-1 (dom width fill) (with-temp-buffer - (let ((bgcolor (cdr (assq :bgcolor cont))) - (fgcolor (cdr (assq :fgcolor cont))) - (style (cdr (assq :style cont))) + (let ((bgcolor (dom-attr dom 'bgcolor)) + (fgcolor (dom-attr dom 'fgcolor)) + (style (dom-attr dom 'style)) (shr-stylesheet shr-stylesheet) - actual-colors) + (max-width 0) + natural-width) (when style (setq style (and (string-match "color" style) (shr-parse-style style)))) (when bgcolor - (setq style (nconc (list (cons 'background-color bgcolor)) style))) + (setq style (nconc (list (cons 'background-color bgcolor)) + style))) (when fgcolor (setq style (nconc (list (cons 'color fgcolor)) style))) (when style (setq shr-stylesheet (append style shr-stylesheet))) - (let ((shr-width width) + (let ((shr-internal-width width) (shr-indentation 0)) - (shr-descend (cons 'td cont))) + (shr-descend dom)) + (save-window-excursion + (set-window-buffer nil (current-buffer)) + (unless fill + (setq natural-width + (or (dom-attr dom 'shr-td-cache-natural) + (let ((natural (max (shr-pixel-buffer-width) + (shr-dom-max-natural-width dom 0)))) + (dom-set-attribute dom 'shr-td-cache-natural natural) + natural)))) + (if (and natural-width + (<= natural-width width)) + (setq max-width natural-width) + (let ((shr-internal-width width)) + (shr-fill-lines (point-min) (point-max)) + (setq max-width (shr-pixel-buffer-width))))) + (goto-char (point-max)) ;; Delete padding at the bottom of the TDs. (delete-region (point) @@ -1554,48 +1998,31 @@ ones, in case fg and bg are nil." (end-of-line) (point))) (goto-char (point-min)) - (let ((max 0)) - (while (not (eobp)) - (end-of-line) - (setq max (max max (current-column))) - (forward-line 1)) - (when fill - (goto-char (point-min)) - ;; If the buffer is totally empty, then put a single blank - ;; line here. - (if (zerop (buffer-size)) - (insert (make-string width ? )) - ;; Otherwise, fill the buffer. - (let ((align (cdr (assq :align cont))) - length) - (while (not (eobp)) - (end-of-line) - (setq length (- width (current-column))) - (when (> length 0) - (cond - ((equal align "right") - (beginning-of-line) - (insert (make-string length ? ))) - ((equal align "center") - (insert (make-string (/ length 2) ? )) - (beginning-of-line) - (insert (make-string (- length (/ length 2)) ? ))) - (t - (insert (make-string length ? ))))) - (forward-line 1)))) - (when style - (setq actual-colors - (shr-colorize-region - (point-min) (point-max) - (cdr (assq 'color shr-stylesheet)) - (cdr (assq 'background-color shr-stylesheet)))))) - (if fill - (list max - (count-lines (point-min) (point-max)) - (split-string (buffer-string) "\n") - nil - (car actual-colors)) - max))))) + (list max-width + natural-width + (count-lines (point-min) (point-max)) + (split-string (buffer-string) "\n") + (if (dom-attr dom 'colspan) + (string-to-number (dom-attr dom 'colspan)) + 1) + (cdr (assq 'color shr-stylesheet)) + (cdr (assq 'background-color shr-stylesheet)))))) + +(defun shr-dom-max-natural-width (dom max) + (if (eq (dom-tag dom) 'table) + (max max (or + (loop for line in (dom-attr dom 'shr-suggested-widths) + maximize (+ + shr-table-separator-length + (loop for elem in line + summing + (+ (cdr elem) + (* 2 shr-table-separator-length))))) + 0)) + (dolist (child (dom-children dom)) + (unless (stringp child) + (setq max (max (shr-dom-max-natural-width child max))))) + max)) (defun shr-buffer-width () (goto-char (point-min)) @@ -1615,19 +2042,21 @@ ones, in case fg and bg are nil." (dotimes (i (length columns)) (aset widths i (max (truncate (* (aref columns i) total-percentage - (- shr-width (1+ (length columns))))) + (- shr-internal-width + (* (1+ (length columns)) + shr-table-separator-pixel-width)))) 10))) widths)) ;; Return a summary of the number and shape of the TDs in the table. -(defun shr-column-specs (cont) - (let ((columns (make-vector (shr-max-columns cont) 1))) - (dolist (row cont) - (when (eq (car row) 'tr) +(defun shr-column-specs (dom) + (let ((columns (make-vector (shr-max-columns dom) 1))) + (dolist (row (dom-non-text-children dom)) + (when (eq (dom-tag row) 'tr) (let ((i 0)) - (dolist (column (cdr row)) - (when (memq (car column) '(td th)) - (let ((width (cdr (assq :width (cdr column))))) + (dolist (column (dom-non-text-children row)) + (when (memq (dom-tag column) '(td th)) + (let ((width (dom-attr column 'width))) (when (and width (string-match "\\([0-9]+\\)%" width) (not (zerop (setq width (string-to-number @@ -1636,25 +2065,23 @@ ones, in case fg and bg are nil." (setq i (1+ i))))))) columns)) -(defun shr-count (cont elem) +(defun shr-count (dom elem) (let ((i 0)) - (dolist (sub cont) - (when (eq (car sub) elem) + (dolist (sub (dom-children dom)) + (when (and (not (stringp sub)) + (eq (dom-tag sub) elem)) (setq i (1+ i)))) i)) -(defun shr-max-columns (cont) +(defun shr-max-columns (dom) (let ((max 0)) - (dolist (row cont) - (when (eq (car row) 'tr) - (setq max (max max (+ (shr-count (cdr row) 'td) - (shr-count (cdr row) 'th)))))) + (dolist (row (dom-children dom)) + (when (and (not (stringp row)) + (eq (dom-tag row) 'tr)) + (setq max (max max (+ (shr-count row 'td) + (shr-count row 'th)))))) max)) (provide 'shr) -;; Local Variables: -;; coding: utf-8 -;; End: - ;;; shr.el ends here |