: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."
;;; 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)
(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)))
`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))))
(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.
(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)))))
(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))
(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)))))
(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<")
(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
(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))
(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)
(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)))))
(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))
(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)
(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)
(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))
(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))
(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))
(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.
;; 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))
;; 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))
(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
(> 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)
(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.
(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)
(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)
(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
(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
(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)
(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))
(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))
(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)
projects / emacs.git / commitdiff