[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Emacs-diffs] shr-fontified f00ab0c 1/2: Allow rendering using fixed-wid
|
From: |
Lars Ingebrigtsen |
|
Subject: |
[Emacs-diffs] shr-fontified f00ab0c 1/2: Allow rendering using fixed-width fonts |
|
Date: |
Sat, 07 Feb 2015 11:35:33 +0000 |
branch: shr-fontified
commit f00ab0c65313f51585b75e2ace39537ba73a2323
Author: Lars Magne Ingebrigtsen <address@hidden>
Commit: Lars Magne Ingebrigtsen <address@hidden>
Allow rendering using fixed-width fonts
(shr-use-fonts): New variable used throughout.
---
lisp/ChangeLog | 1 +
lisp/net/shr.el | 212 ++++++++++++++++++++++++++++++++++---------------------
2 files changed, 132 insertions(+), 81 deletions(-)
diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index ea5e500..0e209b8 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -3,6 +3,7 @@
* net/shr.el (shr-tag-table-1): Add further caching when computing
natural and sketch widths.
(shr-insert-table-ruler): Compute the separator pixel width only once.
+ (shr-use-fonts): New variable used throughout.
2015-02-06 Lars Ingebrigtsen <address@hidden>
diff --git a/lisp/net/shr.el b/lisp/net/shr.el
index b401db8..84ee737 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."
@@ -152,6 +158,7 @@ cid: URL as the argument.")
(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-map
(let ((map (make-sparse-keymap)))
@@ -215,8 +222,10 @@ DOM should be a parse tree as generated by
(shr-font-cache (make-hash-table :test 'eq))
(shr-fill-cache (make-hash-table :test 'equal))
(shr-internal-width (or shr-width
- (- (window-pixel-width)
- (* (frame-fringe-width) 2)))))
+ (if (not shr-use-fonts)
+ (- (window-width) 2)
+ (- (window-pixel-width)
+ (* (frame-fringe-width) 2))))))
(shr-descend dom)
(shr-remove-trailing-whitespace start (point))
(when shr-warning
@@ -458,11 +467,13 @@ size, and full-buffer size."
(load "kinsoku" nil t))
(defun shr-pixel-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)))))
+ (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-string-pixel-width (string)
(with-temp-buffer
@@ -501,7 +512,8 @@ size, and full-buffer size."
(when bolp
(put-text-property start (1+ start)
'shr-indentation shr-indentation))
- (put-text-property start (point) 'face 'variable-pitch))))))
+ (when shr-use-fonts
+ (put-text-property start (point) 'face 'variable-pitch)))))))
(defun shr-fold-lines (start end)
(if (<= shr-internal-width 0)
@@ -517,22 +529,26 @@ size, and full-buffer size."
(goto-char (point-max)))))
(defun shr-goto-pixel-column (pixels)
- (vertical-motion (cons (/ pixels (frame-char-width)) 0))
- ;; Vertical-motion goes to the char before or on the pixel, so
- ;; advance one char.
- (unless (eolp)
- (forward-char 1)))
+ (if (not shr-use-fonts)
+ (move-to-column pixels)
+ (vertical-motion (cons (/ pixels (frame-char-width)) 0))
+ ;; Vertical-motion goes to the char before or on the pixel, so
+ ;; advance one char.
+ (unless (eolp)
+ (forward-char 1))))
-(defun shr-vertical-motion (spec)
- (vertical-motion spec))
+(defun shr-vertical-motion (column)
+ (if (not shr-use-fonts)
+ (move-to-column column)
+ (vertical-motion
+ (cons (/ shr-internal-width (frame-char-width)) 0))))
(defun shr-fold-line ()
- (let ((indentation (get-text-property (point) 'shr-indentation))
- (spec (cons (/ shr-internal-width (frame-char-width)) 0)))
+ (let ((indentation (get-text-property (point) 'shr-indentation)))
(put-text-property (point) (1+ (point)) 'shr-indentation nil)
(when (> indentation 0)
(insert (make-string indentation ?\s)))
- (shr-vertical-motion spec)
+ (shr-vertical-motion shr-internal-width)
(unless (eolp)
(forward-char 1))
(while (not (eolp))
@@ -542,7 +558,7 @@ size, and full-buffer size."
(when (= (preceding-char) ?\s)
(delete-char -1))
(insert "\n")
- (shr-vertical-motion spec)
+ (shr-vertical-motion shr-internal-width)
(unless (eolp)
(forward-char 1)))))
@@ -1151,9 +1167,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)
@@ -1411,7 +1428,8 @@ The preference is a float determined from
`shr-prefer-media-type'."
(shr-generic dom))
(defun shr-tag-h1 (dom)
- (shr-heading dom '(variable-pitch (:height 1.5 :weight bold))))
+ (shr-heading dom (and shr-use-fonts
+ '(variable-pitch (:height 1.5 :weight bold)))))
(defun shr-tag-h2 (dom)
(shr-heading dom 'bold))
@@ -1464,18 +1482,18 @@ The preference is a float determined from
`shr-prefer-media-type'."
(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 (or (dom-attr dom 'shr-suggested-widths)
- (shr-make-table dom suggested-widths nil
- 'shr-suggested-widths)))
;; Compute the "natural" width by setting each column to 5000
;; characters and see how wide they really render.
(natural (or (dom-attr dom 'shr-natural-widths)
(shr-make-table
dom (make-vector (length columns) 5000)
nil 'shr-natural-widths)))
+ ;; 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 (or (dom-attr dom 'shr-suggested-widths)
+ (shr-make-table dom suggested-widths nil
+ 'shr-suggested-widths)))
(sketch-widths (shr-table-widths sketch natural suggested-widths)))
;; This probably won't work very well.
(when (> (+ (loop for width across sketch-widths
@@ -1613,15 +1631,20 @@ The preference is a float determined from
`shr-prefer-media-type'."
(dotimes (i (nth 3 column))
(if (> column-number (1- (length widths)))
(setq align (+ align 20))
- (setq align (+ align 20 (aref widths column-number))))
+ (setq align (+ align
+ (aref widths column-number)
+ (* 2 shr-table-separator-pixel-width))))
(setq column-number (1+ column-number)))
- (let ((lines (nth 2 column)))
+ (let ((lines (nth 2 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 (,align))
+ 'display `(space :align-to (,pixel-align))
'shr-table-indent shr-table-id)
shr-table-vertical-line)
(shr-colorize-region
@@ -1633,7 +1656,7 @@ The preference is a float determined from
`shr-prefer-media-type'."
(end-of-line)
(let ((start (point)))
(insert (propertize " "
- 'display `(space :align-to (,align))
+ 'display `(space :align-to (,pixel-align))
'shr-table-indent shr-table-id)
shr-table-vertical-line)
(shr-colorize-region
@@ -1652,8 +1675,10 @@ The preference is a float determined from
`shr-prefer-media-type'."
start 'shr-table-id nil end))
end)
(goto-char start)
- (let ((id (get-text-property (point) 'shr-table-id))
- (base (shr-pixel-column)))
+ (let* ((shr-use-fonts t)
+ (id (get-text-property (point) 'shr-table-id))
+ (base (shr-pixel-column))
+ elem)
(save-excursion
(while (setq elem (text-property-any (point) end 'shr-table-indent id))
(goto-char elem)
@@ -1803,54 +1828,79 @@ The preference is a float determined from
`shr-prefer-media-type'."
(nreverse trs)))
(defun shr-pixel-buffer-width ()
- (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))))))
+ (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)
- (with-temp-buffer
- (let ((bgcolor (dom-attr dom 'bgcolor))
- (fgcolor (dom-attr dom 'fgcolor))
- (style (dom-attr dom 'style))
- (shr-stylesheet shr-stylesheet)
- (max-width 0))
- (when style
- (setq style (and (string-match "color" style)
- (shr-parse-style style))))
- (when bgcolor
- (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-internal-width width)
- (shr-indentation 0))
- (shr-descend dom))
- (let ((shr-internal-width width))
- (unless (= shr-internal-width 5000)
- (shr-fold-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)
- (progn
- (skip-chars-backward " \t\n")
- (end-of-line)
- (point)))
- (goto-char (point-min))
- (if fill
- (list max-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)))
- max-width))))
+ (let ((cache (intern (format "shr-td-cache-%s-%s" width fill))))
+ (or (dom-attr dom cache)
+ (let ((natural (dom-attr dom 'shr-td-cache-natural)))
+ (and (not fill)
+ natural
+ (>= width natural)
+ natural))
+ (with-temp-buffer
+ (let ((bgcolor (dom-attr dom 'bgcolor))
+ (fgcolor (dom-attr dom 'fgcolor))
+ (style (dom-attr dom 'style))
+ (shr-stylesheet shr-stylesheet)
+ (max-width 0))
+ (when style
+ (setq style (and (string-match "color" style)
+ (shr-parse-style style))))
+ (when bgcolor
+ (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-internal-width width)
+ (shr-indentation 0))
+ (shr-descend dom))
+ (let ((shr-internal-width width))
+ (unless (= shr-internal-width 5000)
+ (shr-fold-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)
+ (progn
+ (skip-chars-backward " \t\n")
+ (end-of-line)
+ (point)))
+ (goto-char (point-min))
+ (let ((result
+ (if fill
+ (list max-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)))
+ max-width)))
+ (when (and (>= width 5000)
+ (not fill))
+ (dom-set-attribute dom 'shr-td-cache-natural result ))
+ (when (eq cache 'shr-td-cache-2486-nil)
+ (debug))
+ (dom-set-attribute dom cache result)
+ result))))))
(defun shr-buffer-width ()
(goto-char (point-min))