From 656caef3505e11b073d59b9c18d3fd21e199d77c Mon Sep 17 00:00:00 2001 From: Lars Magne Ingebrigtsen Date: Tue, 10 Feb 2015 16:29:05 +1100 Subject: [PATCH] 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 data layout. (shr-pixel-buffer-width): New function. (shr-render-td): Add a caching layer. (shr-dom-max-natural-width): New function. --- lisp/ChangeLog | 35 ++ lisp/gnus/ChangeLog | 12 + lisp/gnus/mm-decode.el | 9 +- lisp/net/eww.el | 20 +- lisp/net/shr.el | 701 ++++++++++++++++++++++++++--------------- 5 files changed, 513 insertions(+), 264 deletions(-) diff --git a/lisp/ChangeLog b/lisp/ChangeLog index f7dcb840bd6..d8cb245cbeb 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,38 @@ +2015-02-10 Lars Ingebrigtsen + + * 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 data layout. + (shr-pixel-buffer-width): New function. + (shr-render-td): Add a caching layer. + (shr-dom-max-natural-width): New function. + 2015-02-10 Fabián Ezequiel Gallina python.el: Improved shell font lock respecting markers. (Bug#19650) diff --git a/lisp/gnus/ChangeLog b/lisp/gnus/ChangeLog index 32d3f08f586..ac7e2acab93 100644 --- a/lisp/gnus/ChangeLog +++ b/lisp/gnus/ChangeLog @@ -1,3 +1,15 @@ +2015-02-10 Lars Ingebrigtsen + + * 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. + +2015-02-09 Lars Ingebrigtsen + + * mm-decode.el (mm-convert-shr-links): Don't overwrite the faces from + shr, beacause that breaks folding. + (mm-shr): Don't shorten the width when using fonts. + 2015-02-05 Teodor Zlatanov * gnus-start.el (gnus-save-newsrc-file-check-timestamp): Remove diff --git a/lisp/gnus/mm-decode.el b/lisp/gnus/mm-decode.el index 311ea7cffff..6c783bbef03 100644 --- a/lisp/gnus/mm-decode.el +++ b/lisp/gnus/mm-decode.el @@ -1815,6 +1815,7 @@ If RECURSIVE, search recursively." (start end &optional base-url)) (declare-function shr-insert-document "shr" (dom)) (defvar shr-blocked-images) +(defvar shr-use-fonts) (defvar gnus-inhibit-images) (autoload 'gnus-blocked-images "gnus-art") @@ -1822,7 +1823,10 @@ If RECURSIVE, search recursively." ;; Require since we bind its variables. (require 'shr) (let ((article-buffer (current-buffer)) - (shr-width fill-column) + (shr-width (if (and (boundp 'shr-use-fonts) + shr-use-fonts) + nil + fill-column)) (shr-content-function (lambda (id) (let ((handle (mm-get-content-id id))) (when handle @@ -1890,12 +1894,15 @@ If RECURSIVE, search recursively." (< start (point-max))) (when (setq start (text-property-not-all start (point-max) 'shr-url nil)) (setq end (next-single-property-change start 'shr-url nil (point-max))) + (setq face (get-text-property start 'face)) (widget-convert-button 'url-link start end :help-echo (get-text-property start 'help-echo) :keymap shr-map (get-text-property start 'shr-url)) (put-text-property start end 'local-map nil) + (dolist (overlay (overlays-at start)) + (overlay-put overlay 'face nil)) (setq start end))))) (defun mm-handle-filename (handle) diff --git a/lisp/net/eww.el b/lisp/net/eww.el index ec7a0baacf6..c401701f255 100644 --- a/lisp/net/eww.el +++ b/lisp/net/eww.el @@ -409,7 +409,6 @@ See the `eww-search-prefix' variable for the search engine used." (form . eww-tag-form) (input . eww-tag-input) (textarea . eww-tag-textarea) - (body . eww-tag-body) (select . eww-tag-select) (link . eww-tag-link) (a . eww-tag-a)))) @@ -495,15 +494,6 @@ See the `eww-search-prefix' variable for the search engine used." (replace-regexp-in-string "[ \t\r\n]+" " " (dom-text dom)))) (eww-update-header-line-format)) -(defun eww-tag-body (dom) - (let* ((start (point)) - (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 dom) - (shr-colorize-region start (point) fgcolor bgcolor))) - (defun eww-display-raw (buffer &optional encode) (let ((data (buffer-substring (point) (point-max)))) (unless (buffer-live-p buffer) @@ -653,6 +643,7 @@ the like." (define-key map "H" 'eww-list-histories) (define-key map "E" 'eww-set-character-encoding) (define-key map "S" 'eww-list-buffers) + (define-key map "F" 'eww-toggle-fonts) (define-key map "b" 'eww-add-bookmark) (define-key map "B" 'eww-list-bookmarks) @@ -1425,6 +1416,15 @@ Differences in #targets are ignored." (eww-reload nil 'utf-8) (eww-reload nil charset))) +(defun eww-toggle-fonts () + "Toggle whether to use monospaced or font-enabled layouts." + (interactive) + (message "Fonts are now %s" + (if (setq shr-use-fonts (not shr-use-fonts)) + "on" + "off")) + (eww-reload)) + ;;; Bookmarks code (defvar eww-bookmarks nil) diff --git a/lisp/net/shr.el b/lisp/net/shr.el index 59c277b01c2..06a75a46bf2 100644 --- a/lisp/net/shr.el +++ b/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))))) - -(defun shr-find-fill-point () - (when (> (move-to-column shr-internal-width) shr-internal-width) - (backward-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-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) -- 2.39.2