Allow using variable-width fonts in eww
* lisp/gnus/mm-decode.el (mm-shr): Only pass the fill column when not using fonts, because limiting the width to what's appropriate for followups doesn't really help when not using proportional fonts. * lisp/net/shr.el (shr-use-fonts): New variable. (shr-fill-text): Rename from "fold". (shr-pixel-column, shr-pixel-region, shr-string-pixel-width): New functions. (shr-insert): Just insert, don't fill the text. Filling is now done afterwards per display unit. (shr-fill-lines, shr-fill-line): New functions to fill text on a per-unit base. (shr-find-fill-point): Take a "beginning" parameter. (shr-indent): Indent using the :width display parameter when using fonts. (shr-parse-style): Ignore "inherit" values, since we already do that. (shr-tag-img): Remove the insertion states. (shr-tag-blockquote): New-style filling. (shr-tag-dd): Ditto. (shr-tag-li): Ditto. (shr-mark-fill): New function to mark lines that need filling. (shr-tag-h1): Use a larger font. (shr-tag-table-1): Get the natural and suggested widths in one rendering. (shr-tag-table): Create the "fixed" version of the table only once so that we can cache data in the table. (shr-insert-table): Get colspan calculations right by having zero-width columns after colspan ones. (shr-expand-alignments): New function to make :align-to specs work right when rendered in one buffer and displayed in another one. (shr-insert-table-ruler): Use :align-to to get the widths right. (shr-make-table): Cache more. (shr-make-table-1): Use the new <td> data layout. (shr-pixel-buffer-width): New function. (shr-render-td): Add a caching layer. (shr-dom-max-natural-width): New function.
This commit is contained in:
Lars Magne Ingebrigtsen
parent
880415a6a6
commit
656caef350
5 changed files with 512 additions and 263 deletions
699
lisp/net/shr.el
699
lisp/net/shr.el
|
|
@ -57,6 +57,12 @@ fit these criteria."
|
|||
:group 'shr
|
||||
:type '(choice (const nil) regexp))
|
||||
|
||||
(defcustom shr-use-fonts nil
|
||||
"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."
|
||||
|
|
@ -132,10 +138,9 @@ cid: URL as the argument.")
|
|||
;;; Internal variables.
|
||||
|
||||
(defvar shr-folding-mode nil)
|
||||
(defvar shr-state nil)
|
||||
(defvar shr-start nil)
|
||||
(defvar shr-indentation 0)
|
||||
(defvar shr-internal-width (or shr-width (1- (window-width))))
|
||||
(defvar shr-internal-width nil)
|
||||
(defvar shr-list-mode nil)
|
||||
(defvar shr-content-cache nil)
|
||||
(defvar shr-kinsoku-shorten nil)
|
||||
|
|
@ -149,6 +154,9 @@ cid: URL as the argument.")
|
|||
(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-map
|
||||
(let ((map (make-sparse-keymap)))
|
||||
|
|
@ -202,13 +210,22 @@ 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-depth 0)
|
||||
(shr-table-id 0)
|
||||
(shr-warning nil)
|
||||
(shr-internal-width (or shr-width (1- (window-width)))))
|
||||
(shr-table-separator-pixel-width (shr-string-pixel-width "-"))
|
||||
(shr-internal-width (or (and shr-width
|
||||
(if (not shr-use-fonts)
|
||||
shr-width
|
||||
(* shr-width (frame-char-width))))
|
||||
(if (not shr-use-fonts)
|
||||
(- (window-width) 2)
|
||||
(- (window-pixel-width)
|
||||
(* (frame-fringe-width) 2))))))
|
||||
(shr-descend dom)
|
||||
(shr-fill-lines start (point))
|
||||
(shr-remove-trailing-whitespace start (point))
|
||||
(when shr-warning
|
||||
(message "%s" shr-warning))))
|
||||
|
|
@ -303,7 +320,7 @@ redirects somewhere else."
|
|||
(let ((text (get-text-property (point) 'shr-alt)))
|
||||
(if (not text)
|
||||
(message "No image under point")
|
||||
(message "%s" (shr-fold-text text)))))
|
||||
(message "%s" (shr-fill-text text)))))
|
||||
|
||||
(defun shr-browse-image (&optional copy-url)
|
||||
"Browse the image under point.
|
||||
|
|
@ -414,14 +431,14 @@ size, and full-buffer size."
|
|||
(cdr (assq 'color shr-stylesheet))
|
||||
(cdr (assq 'background-color shr-stylesheet))))))))
|
||||
|
||||
(defun shr-fold-text (text)
|
||||
(defun shr-fill-text (text)
|
||||
(if (zerop (length text))
|
||||
text
|
||||
(with-temp-buffer
|
||||
(let ((shr-indentation 0)
|
||||
(shr-state nil)
|
||||
(shr-start nil)
|
||||
(shr-internal-width (window-width)))
|
||||
(shr-internal-width (- (window-pixel-width)
|
||||
(* (frame-fringe-width) 2))))
|
||||
(shr-insert text)
|
||||
(buffer-string)))))
|
||||
|
||||
|
|
@ -447,76 +464,123 @@ size, and full-buffer size."
|
|||
(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))
|
||||
(t
|
||||
(when (and (string-match "\\`[ \t\n ]" text)
|
||||
(when (and (string-match "\\`[ \t\n\r ]" 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-internal-width)
|
||||
(> shr-internal-width 0)
|
||||
(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))
|
||||
(if (<= (current-column) shr-internal-width)
|
||||
(insert " ")
|
||||
;; In case we couldn't get a valid break point (because of a
|
||||
;; word that's longer than `shr-internal-width'), just break anyway.
|
||||
(insert "\n")
|
||||
(when (> shr-indentation 0)
|
||||
(shr-indent)))))
|
||||
(unless (string-match "[ \t\r\n ]\\'" text)
|
||||
(delete-char -1)))))
|
||||
(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))
|
||||
(goto-char (point-max)))
|
||||
;; We may have removed everything we inserted if if was just
|
||||
;; spaces.
|
||||
(unless (= start (point))
|
||||
;; Mark all lines that should possibly be folded afterwards.
|
||||
(when bolp
|
||||
(shr-mark-fill start))
|
||||
(when shr-use-fonts
|
||||
(add-face-text-property start (point)
|
||||
(or shr-current-font 'variable-pitch)
|
||||
t)))))))
|
||||
|
||||
(defun shr-find-fill-point ()
|
||||
(when (> (move-to-column shr-internal-width) shr-internal-width)
|
||||
(backward-char 1))
|
||||
(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)
|
||||
(shr-indent)
|
||||
(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))
|
||||
(insert "\n")
|
||||
(shr-indent)
|
||||
(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))
|
||||
|
|
@ -547,12 +611,12 @@ size, and full-buffer size."
|
|||
(while (and (not (memq (preceding-char) (list ?\C-@ ?\n ? )))
|
||||
(shr-char-kinsoku-eol-p (preceding-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-internal-width))
|
||||
(<= (point) end))
|
||||
(progn
|
||||
(setq bp (point))
|
||||
(shr-char-kinsoku-eol-p (following-char)))))
|
||||
|
|
@ -567,7 +631,7 @@ 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)))))))
|
||||
(when (setq failed (<= (current-column) shr-indentation))
|
||||
(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<")
|
||||
|
|
@ -664,13 +728,18 @@ size, and full-buffer size."
|
|||
|
||||
(defun shr-indent ()
|
||||
(when (> shr-indentation 0)
|
||||
(insert (make-string shr-indentation ? ))))
|
||||
(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 (shr-start)
|
||||
(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
|
||||
|
|
@ -1070,13 +1139,11 @@ ones, in case fg and bg are nil."
|
|||
|
||||
(defun shr-tag-p (dom)
|
||||
(shr-ensure-paragraph)
|
||||
(shr-indent)
|
||||
(shr-generic dom)
|
||||
(shr-ensure-paragraph))
|
||||
|
||||
(defun shr-tag-div (dom)
|
||||
(shr-ensure-newline)
|
||||
(shr-indent)
|
||||
(shr-generic dom)
|
||||
(shr-ensure-newline))
|
||||
|
||||
|
|
@ -1116,9 +1183,10 @@ 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 (dom)
|
||||
|
|
@ -1245,8 +1313,7 @@ The preference is a float determined from `shr-prefer-media-type'."
|
|||
(when (or url
|
||||
(and dom
|
||||
(> (length (dom-attr dom 'src)) 0)))
|
||||
(when (and (> (current-column) 0)
|
||||
(not (eq shr-state 'image)))
|
||||
(when (> (current-column) 0)
|
||||
(insert "\n"))
|
||||
(let ((alt (dom-attr dom 'alt))
|
||||
(url (shr-expand-url (or url (dom-attr dom 'src)))))
|
||||
|
|
@ -1276,10 +1343,9 @@ The preference is a float determined from `shr-prefer-media-type'."
|
|||
(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))
|
||||
|
|
@ -1301,22 +1367,24 @@ The preference is a float determined from `shr-prefer-media-type'."
|
|||
(put-text-property start (point) 'image-displayer
|
||||
(shr-image-displayer shr-content-function))
|
||||
(put-text-property start (point) 'help-echo
|
||||
(shr-fold-text (or (dom-attr dom 'title) alt))))
|
||||
(setq shr-state 'image)))))
|
||||
(shr-fill-text
|
||||
(or (dom-attr dom 'title) alt))))))))
|
||||
|
||||
(defun shr-tag-pre (dom)
|
||||
(let ((shr-folding-mode 'none))
|
||||
(let ((shr-folding-mode 'none)
|
||||
(shr-current-font 'default))
|
||||
(shr-ensure-newline)
|
||||
(shr-indent)
|
||||
(shr-generic dom)
|
||||
(shr-ensure-newline)))
|
||||
|
||||
(defun shr-tag-blockquote (dom)
|
||||
(shr-ensure-paragraph)
|
||||
(shr-indent)
|
||||
(let ((shr-indentation (+ shr-indentation 4)))
|
||||
(shr-generic dom))
|
||||
(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 (dom)
|
||||
(shr-ensure-paragraph)
|
||||
|
|
@ -1330,7 +1398,8 @@ The preference is a float determined from `shr-prefer-media-type'."
|
|||
|
||||
(defun shr-tag-dd (dom)
|
||||
(shr-ensure-newline)
|
||||
(let ((shr-indentation (+ shr-indentation 4)))
|
||||
(let ((shr-indentation (+ shr-indentation
|
||||
(* 4 shr-table-separator-pixel-width))))
|
||||
(shr-generic dom)))
|
||||
|
||||
(defun shr-tag-ul (dom)
|
||||
|
|
@ -1347,16 +1416,26 @@ The preference is a float determined from `shr-prefer-media-type'."
|
|||
|
||||
(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 dom)))
|
||||
(let ((start (point)))
|
||||
(let* ((bullet
|
||||
(if (numberp shr-list-mode)
|
||||
(prog1
|
||||
(format "%d " shr-list-mode)
|
||||
(setq shr-list-mode (1+ shr-list-mode)))
|
||||
shr-bullet)))
|
||||
(insert bullet)
|
||||
(shr-mark-fill start)
|
||||
(let ((shr-indentation (+ shr-indentation
|
||||
(shr-string-pixel-width bullet))))
|
||||
(put-text-property start (1+ start)
|
||||
'shr-continuation-indentation shr-indentation)
|
||||
(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))
|
||||
|
|
@ -1365,15 +1444,14 @@ The preference is a float determined from `shr-prefer-media-type'."
|
|||
(or (not (bolp))
|
||||
(and (> (- (point) 2) (point-min))
|
||||
(not (= (char-after (- (point) 2)) ?\n)))))
|
||||
(insert "\n")
|
||||
(shr-indent))
|
||||
(insert "\n"))
|
||||
(shr-generic dom))
|
||||
|
||||
(defun shr-tag-span (dom)
|
||||
(shr-generic dom))
|
||||
|
||||
(defun shr-tag-h1 (dom)
|
||||
(shr-heading dom 'bold 'underline))
|
||||
(shr-heading dom '(variable-pitch (:height 1.3 :weight bold))))
|
||||
|
||||
(defun shr-tag-h2 (dom)
|
||||
(shr-heading dom 'bold))
|
||||
|
|
@ -1392,7 +1470,8 @@ The preference is a float determined from `shr-prefer-media-type'."
|
|||
|
||||
(defun shr-tag-hr (_dom)
|
||||
(shr-ensure-newline)
|
||||
(insert (make-string shr-internal-width shr-hr-line) "\n"))
|
||||
;; FIXME: Should try to make a line of the required pixel size.
|
||||
(insert (make-string (window-width) shr-hr-line) "\n"))
|
||||
|
||||
(defun shr-tag-title (dom)
|
||||
(shr-heading dom 'bold 'underline))
|
||||
|
|
@ -1424,20 +1503,23 @@ The preference is a float determined from `shr-prefer-media-type'."
|
|||
(shr-kinsoku-shorten t)
|
||||
;; Find all suggested widths.
|
||||
(columns (shr-column-specs dom))
|
||||
;; Compute how many characters wide each TD should be.
|
||||
;; 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 dom suggested-widths))
|
||||
;; Compute the "natural" width by setting each column to 500
|
||||
;; characters and see how wide they really render.
|
||||
(natural (shr-make-table dom (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.
|
||||
|
|
@ -1466,64 +1548,71 @@ The preference is a float determined from `shr-prefer-media-type'."
|
|||
;; Try to output it anyway.
|
||||
(shr-generic dom)
|
||||
;; It's a real table, so render it.
|
||||
(shr-tag-table-1
|
||||
(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
|
||||
(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))))))))))
|
||||
;; 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)))))
|
||||
(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))
|
||||
|
|
@ -1531,6 +1620,8 @@ The preference is a float determined from `shr-prefer-media-type'."
|
|||
;; model isn't strong enough to allow us to put the images actually
|
||||
;; into the tables.
|
||||
(when (zerop shr-table-depth)
|
||||
(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))
|
||||
|
|
@ -1540,38 +1631,87 @@ The preference is a float determined from `shr-prefer-media-type'."
|
|||
(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))
|
||||
'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-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
|
||||
|
|
@ -1579,9 +1719,17 @@ The preference is a float determined from `shr-prefer-media-type'."
|
|||
(> 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)
|
||||
|
|
@ -1599,7 +1747,8 @@ The preference is a float determined from `shr-prefer-media-type'."
|
|||
(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 (length widths))))
|
||||
(expanded-columns 0))
|
||||
;; We have extra, unused space, so divide this space amongst the
|
||||
;; columns.
|
||||
|
|
@ -1617,11 +1766,13 @@ The preference is a float determined from `shr-prefer-media-type'."
|
|||
(aref widths i))))))))
|
||||
widths))
|
||||
|
||||
(defun shr-make-table (dom widths &optional fill)
|
||||
(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 (dom widths &optional fill)
|
||||
|
|
@ -1634,7 +1785,7 @@ The preference is a float determined from `shr-prefer-media-type'."
|
|||
(dolist (row (dom-non-text-children dom))
|
||||
(when (eq (dom-tag row) 'tr)
|
||||
(let ((tds nil)
|
||||
(columns (dom-children row))
|
||||
(columns (dom-non-text-children row))
|
||||
(i 0)
|
||||
(width-column 0)
|
||||
column)
|
||||
|
|
@ -1660,7 +1811,7 @@ The preference is a float determined from `shr-prefer-media-type'."
|
|||
(setq width
|
||||
(if column
|
||||
(aref widths width-column)
|
||||
10))
|
||||
(* 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
|
||||
|
|
@ -1682,35 +1833,80 @@ The preference is a float determined from `shr-prefer-media-type'."
|
|||
(setq width-column (+ width-column (1- colspan))
|
||||
colspan-count colspan
|
||||
colspan-remaining colspan))
|
||||
(when (or column
|
||||
(not fill))
|
||||
(when column
|
||||
(let ((data (shr-render-td column width fill)))
|
||||
(if (and (not fill)
|
||||
(> colspan-remaining 0))
|
||||
(progn
|
||||
(when (= colspan-count colspan-remaining)
|
||||
(setq colspan-width data))
|
||||
(setq colspan-width (car data))
|
||||
(let ((this-width (/ colspan-width colspan-count)))
|
||||
(push this-width tds)
|
||||
(push (cons this-width (cadr data)) tds)
|
||||
(setq colspan-remaining (1- colspan-remaining))))
|
||||
(push data tds))))
|
||||
(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-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 (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
|
||||
|
|
@ -1718,6 +1914,22 @@ The preference is a float determined from `shr-prefer-media-type'."
|
|||
(let ((shr-internal-width width)
|
||||
(shr-indentation 0))
|
||||
(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)
|
||||
|
|
@ -1726,48 +1938,31 @@ The preference is a float determined from `shr-prefer-media-type'."
|
|||
(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 (dom-attr dom 'align))
|
||||
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))
|
||||
|
|
@ -1788,7 +1983,8 @@ The preference is a float determined from `shr-prefer-media-type'."
|
|||
(aset widths i (max (truncate (* (aref columns i)
|
||||
total-percentage
|
||||
(- shr-internal-width
|
||||
(1+ (length columns)))))
|
||||
(* (1+ (length columns))
|
||||
shr-table-separator-pixel-width))))
|
||||
10)))
|
||||
widths))
|
||||
|
||||
|
|
@ -1798,9 +1994,8 @@ The preference is a float determined from `shr-prefer-media-type'."
|
|||
(dolist (row (dom-non-text-children dom))
|
||||
(when (eq (dom-tag row) 'tr)
|
||||
(let ((i 0))
|
||||
(dolist (column (dom-children row))
|
||||
(when (and (not (stringp column))
|
||||
(memq (dom-tag column) '(td th)))
|
||||
(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)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue