X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/ef8892db3cdf679231cf71613f14589fc3702a80..f15c8583198c3d6c26ca0c0a5b6fb019f98d6c3c:/lisp/net/shr.el

diff --git a/lisp/net/shr.el b/lisp/net/shr.el
index 695b91dcb1..9d88d1ff44 100644
--- a/lisp/net/shr.el
+++ b/lisp/net/shr.el
@@ -1,6 +1,6 @@
 ;;; shr.el --- Simple HTML Renderer
 
-;; Copyright (C) 2010-2014 Free Software Foundation, Inc.
+;; Copyright (C) 2010-2015 Free Software Foundation, Inc.
 
 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
 ;; Keywords: html
@@ -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."
@@ -78,11 +84,12 @@ If nil, don't draw horizontal table lines."
   :group 'shr
   :type 'character)
 
-(defcustom shr-width fill-column
+(defcustom shr-width nil
   "Frame width to use for rendering.
 May either be an integer specifying a fixed width in characters,
 or nil, meaning that the full width of the window should be
 used."
+  :version "25.1"
   :type '(choice (integer :tag "Fixed width in characters")
 		 (const   :tag "Use the width of the window" nil))
   :group 'shr)
@@ -131,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)
@@ -148,6 +154,10 @@ 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-internal-bullet nil)
 
 (defvar shr-map
   (let ((map (make-sparse-keymap)))
@@ -201,13 +211,24 @@ 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-bullet (cons shr-bullet
+				   (shr-string-pixel-width shr-bullet)))
+	(shr-internal-width (or (and shr-width
+				     (if (not shr-use-fonts)
+					 shr-width
+				       (* shr-width (frame-char-width))))
+				(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))))
@@ -265,8 +286,9 @@ redirects somewhere else."
   "Skip to the next link."
   (interactive)
   (let ((skip (text-property-any (point) (point-max) 'help-echo nil)))
-    (if (not (setq skip (text-property-not-all skip (point-max)
-					       'help-echo nil)))
+    (if (or (eobp)
+	    (not (setq skip (text-property-not-all skip (point-max)
+						   'help-echo nil))))
 	(message "No next link")
       (goto-char skip)
       (message "%s" (get-text-property (point) 'help-echo)))))
@@ -301,7 +323,7 @@ redirects somewhere else."
   (let ((text (get-text-property (point) 'shr-alt)))
     (if (not text)
 	(message "No image under point")
-      (message "%s" text))))
+      (message "%s" (shr-fill-text text)))))
 
 (defun shr-browse-image (&optional copy-url)
   "Browse the image under point.
@@ -412,6 +434,17 @@ size, and full-buffer size."
 	   (cdr (assq 'color shr-stylesheet))
 	   (cdr (assq 'background-color shr-stylesheet))))))))
 
+(defun shr-fill-text (text)
+  (if (zerop (length text))
+      text
+    (with-temp-buffer
+      (let ((shr-indentation 0)
+	    (shr-start nil)
+	    (shr-internal-width (- (window-pixel-width)
+				   (* (frame-fringe-width) 2))))
+	(shr-insert text)
+	(buffer-string)))))
+
 (define-inline shr-char-breakable-p (char)
   "Return non-nil if a line can be broken before and after CHAR."
   (inline-quote (aref fill-find-break-point-function-table ,char)))
@@ -434,76 +467,146 @@ 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))
+    (let ((start (point)))
+      (insert text)
+      (save-restriction
+	(narrow-to-region start (point))
+	;; Remove soft hyphens.
+	(goto-char (point-min))
+	(while (search-forward "­" nil t)
+	  (replace-match "" t t))
+	(goto-char (point-max)))))
    (t
-    (when (and (string-match "\\`[ \t\n ]" text)
-	       (not (bolp))
-	       (not (eq (char-after (1- (point))) ? )))
-      (insert " "))
-    (dolist (elem (split-string text "[ \f\t\n\r\v ]+" t))
-      (when (and (bolp)
-		 (> shr-indentation 0))
-	(shr-indent))
-      ;; No space is needed behind a wide character categorized as
-      ;; kinsoku-bol, between characters both categorized as nospace,
-      ;; or at the beginning of a line.
-      (let (prev)
-	(when (and (> (current-column) shr-indentation)
-		   (eq (preceding-char) ? )
-		   (or (= (line-beginning-position) (1- (point)))
-		       (and (shr-char-breakable-p
-			     (setq prev (char-after (- (point) 2))))
-			    (shr-char-kinsoku-bol-p prev))
-		       (and (shr-char-nospace-p prev)
-			    (shr-char-nospace-p (aref elem 0)))))
-	  (delete-char -1)))
-      ;; The shr-start is a special variable that is used to pass
-      ;; upwards the first point in the buffer where the text really
-      ;; starts.
-      (unless shr-start
-	(setq shr-start (point)))
-      (insert elem)
-      (setq shr-state nil)
-      (let (found)
-	(while (and (> (current-column) shr-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 ((font-start (point)))
+      (when (and (string-match "\\`[ \t\n\r ]" text)
+		 (not (bolp))
+		 (not (eq (char-after (1- (point))) ? )))
+	(insert " "))
+      (let ((start (point))
+	    (bolp (bolp)))
+	(insert text)
+	(save-restriction
+	  (narrow-to-region start (point))
+	  (goto-char start)
+	  (when (looking-at "[ \t\n\r ]+")
+	    (replace-match "" t t))
+	  (while (re-search-forward "[ \t\n\r ]+" nil t)
+	    (replace-match " " t t))
+	  ;; Remove soft hyphens.
+	  (goto-char (point-min))
+	  (while (search-forward "­" nil t)
+	    (replace-match "" t t))
+	  (goto-char (point-max)))
+	;; We may have removed everything we inserted if if was just
+	;; spaces.
+	(unless (= font-start (point))
+	  ;; Mark all lines that should possibly be folded afterwards.
+	  (when bolp
+	    (shr-mark-fill start))
+	  (when shr-use-fonts
+	    (put-text-property font-start (point)
+			       'face
+			       (or shr-current-font 'variable-pitch)))))))))
+
+(defun shr-fill-lines (start end)
+  (if (<= shr-internal-width 0)
+      nil
+    (save-restriction
+      (narrow-to-region start end)
+      (goto-char start)
+      (when (get-text-property (point) 'shr-indentation)
+	(shr-fill-line))
+      (while (setq start (next-single-property-change start 'shr-indentation))
+	(goto-char start)
+	(when (bolp)
+	  (shr-fill-line)))
+      (goto-char (point-max)))))
+
+(defun shr-vertical-motion (column)
+  (if (not shr-use-fonts)
+      (move-to-column column)
+    (unless (eolp)
+      (forward-char 1))
+    (vertical-motion (cons (/ column (frame-char-width)) 0))
+    (unless (eolp)
+      (forward-char 1))))
+
+(defun shr-fill-line ()
+  (let ((shr-indentation (get-text-property (point) 'shr-indentation))
+	(continuation (get-text-property
+		       (point) 'shr-continuation-indentation))
+	start)
+    (put-text-property (point) (1+ (point)) 'shr-indentation nil)
+    (let ((face (get-text-property (point) 'face))
+	  (background-start (point)))
+      (shr-indent)
+      (when face
+	(put-text-property background-start (point) 'face
+			   `,(shr-face-background face))))
+    (setq start (point))
+    (setq shr-indentation (or continuation shr-indentation))
+    (shr-vertical-motion shr-internal-width)
+    (when (looking-at " $")
+      (delete-region (point) (line-end-position)))
+    (while (not (eolp))
+      ;; We have to do some folding.  First find the first
+      ;; previous point suitable for folding.
+      (if (or (not (shr-find-fill-point (line-beginning-position)))
+	      (= (point) start))
+	  ;; We had unbreakable text (for this width), so just go to
+	  ;; the first space and carry on.
+	  (progn
+	    (beginning-of-line)
+	    (skip-chars-forward " ")
+	    (search-forward " " (line-end-position) 'move)))
+      ;; Success; continue.
+      (when (= (preceding-char) ?\s)
+	(delete-char -1))
+      (let ((face (get-text-property (point) 'face))
+	    (background-start (point)))
+	(insert "\n")
+	(shr-indent)
+	(when face
+	  (put-text-property background-start (point) 'face
+			     `,(shr-face-background face))))
+      (setq start (point))
+      (shr-vertical-motion shr-internal-width)
+      (when (looking-at " $")
+	(delete-region (point) (line-end-position))))))
+
+(defun shr-find-fill-point (start)
   (let ((bp (point))
+	(end (point))
 	failed)
-    (while (not (or (setq failed (<= (current-column) shr-indentation))
+    (while (not (or (setq failed (<= (point) start))
 		    (eq (preceding-char) ? )
 		    (eq (following-char) ? )
 		    (shr-char-breakable-p (preceding-char))
@@ -534,12 +637,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)))))
@@ -554,7 +657,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<")
@@ -631,33 +734,47 @@ size, and full-buffer size."
 
 (defun shr-ensure-paragraph ()
   (unless (bobp)
-    (if (<= (current-column) shr-indentation)
-	(unless (save-excursion
-		  (forward-line -1)
-		  (looking-at " *$"))
-	  (insert "\n"))
-      (if (save-excursion
-	    (beginning-of-line)
-	    ;; If the current line is totally blank, and doesn't even
-	    ;; have any face properties set, then delete the blank
-	    ;; space.
-	    (and (looking-at " *$")
-		 (not (get-text-property (point) 'face))
-		 (not (= (next-single-property-change (point) 'face nil
-						      (line-end-position))
-			 (line-end-position)))))
-	  (delete-region (match-beginning 0) (match-end 0))
-	(insert "\n\n")))))
+    (let ((prefix (get-text-property (line-beginning-position)
+				     'shr-prefix-length)))
+      (cond
+       ((and (bolp)
+	     (save-excursion
+	       (forward-line -1)
+	       (looking-at " *$")))
+	;; We're already at a new paragraph; do nothing.
+	)
+       ((and prefix
+	     (= prefix (- (point) (line-beginning-position))))
+	;; Do nothing; we're at the start of a <li>.
+	)
+       ((save-excursion
+	  (beginning-of-line)
+	  ;; If the current line is totally blank, and doesn't even
+	  ;; have any face properties set, then delete the blank
+	  ;; space.
+	  (and (looking-at " *$")
+	       (not (get-text-property (point) 'face))
+	       (not (= (next-single-property-change (point) 'face nil
+						    (line-end-position))
+		       (line-end-position)))))
+	(delete-region (match-beginning 0) (match-end 0)))
+       (t
+	(insert "\n\n"))))))
 
 (defun shr-indent ()
   (when (> shr-indentation 0)
-    (insert (make-string shr-indentation ? ))))
+    (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
@@ -881,7 +998,12 @@ START, and END.  Note that START and END should be markers."
   (add-text-properties
    start (point)
    (list 'shr-url url
-	 'help-echo (if title (format "%s (%s)" url title) url)
+	 'help-echo (let ((iri (or (ignore-errors
+				     (decode-coding-string
+				      (url-unhex-string url)
+				      'utf-8 t))
+				   url)))
+		      (if title (format "%s (%s)" iri title) iri))
 	 'follow-link t
 	 'mouse-face 'highlight
 	 'keymap shr-map)))
@@ -930,44 +1052,6 @@ ones, in case fg and bg are nil."
 				  t)))
       new-colors)))
 
-(defun shr-expand-newlines (start end color)
-  (save-restriction
-    ;; Skip past all white space at the start and ends.
-    (goto-char start)
-    (skip-chars-forward " \t\n")
-    (beginning-of-line)
-    (setq start (point))
-    (goto-char end)
-    (skip-chars-backward " \t\n")
-    (forward-line 1)
-    (setq end (point))
-    (narrow-to-region start end)
-    (let ((width (shr-buffer-width))
-	  column)
-      (goto-char (point-min))
-      (while (not (eobp))
-	(end-of-line)
-	(when (and (< (setq column (current-column)) width)
-		   (< (setq column (shr-previous-newline-padding-width column))
-		      width))
-	  (let ((overlay (make-overlay (point) (1+ (point)))))
-	    (overlay-put overlay 'before-string
-			 (concat
-			  (mapconcat
-			   (lambda (overlay)
-			     (let ((string (plist-get
-					    (overlay-properties overlay)
-					    'before-string)))
-			       (if (not string)
-				   ""
-				 (overlay-put overlay 'before-string "")
-				 string)))
-			   (overlays-at (point))
-			   "")
-			  (propertize (make-string (- width column) ? )
-				      'face (list :background color))))))
-	(forward-line 1)))))
-
 (defun shr-previous-newline-padding-width (width)
   (let ((overlays (overlays-at (point)))
 	(previous-width 0))
@@ -1052,13 +1136,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))
 
@@ -1083,6 +1165,10 @@ ones, in case fg and bg are nil."
 (defun shr-tag-u (dom)
   (shr-fontize-dom dom 'underline))
 
+(defun shr-tag-tt (dom)
+  (let ((shr-current-font 'default))
+    (shr-generic dom)))
+
 (defun shr-parse-style (style)
   (when style
     (save-match-data
@@ -1098,9 +1184,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)
@@ -1227,8 +1314,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)))))
@@ -1258,10 +1344,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))
@@ -1283,22 +1368,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
-			     (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)
@@ -1312,7 +1399,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)
@@ -1329,16 +1417,29 @@ 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)))
+	      (car shr-internal-bullet)))
+	   (width (if (numberp shr-list-mode)
+		      (shr-string-pixel-width bullet)
+		    (cdr shr-internal-bullet))))
+      (insert bullet)
+      (shr-mark-fill start)
+      (let ((shr-indentation (+ shr-indentation width)))
+	(put-text-property start (1+ start)
+			   'shr-continuation-indentation shr-indentation)
+	(put-text-property start (1+ start) 'shr-prefix-length (length bullet))
+	(shr-generic dom)))))
+
+(defun shr-mark-fill (start)
+  ;; We may not have inserted any text to fill.
+  (unless (= start (point))
+    (put-text-property start (1+ start)
+		       'shr-indentation shr-indentation)))
 
 (defun shr-tag-br (dom)
   (when (and (not (bobp))
@@ -1347,15 +1448,16 @@ 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 (if shr-use-fonts
+		       '(variable-pitch (:height 1.3 :weight bold))
+		     'bold)))
 
 (defun shr-tag-h2 (dom)
   (shr-heading dom 'bold))
@@ -1374,7 +1476,12 @@ 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"))
+  (insert (make-string (if (not shr-use-fonts)
+			   shr-internal-width
+			 (1+ (/ shr-internal-width
+				shr-table-separator-pixel-width)))
+		       shr-hr-line)
+	  "\n"))
 
 (defun shr-tag-title (dom)
   (shr-heading dom 'bold 'underline))
@@ -1406,20 +1513,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.
@@ -1427,10 +1537,11 @@ The preference is a float determined from `shr-prefer-media-type'."
 
 (defun shr-tag-table (dom)
   (shr-ensure-paragraph)
-  (let* ((caption (dom-child-by-tag dom 'caption))
-	 (header (dom-child-by-tag dom 'thead))
-	 (body (or (dom-child-by-tag dom 'tbody) dom))
-	 (footer (dom-child-by-tag dom 'tfoot))
+  (let* ((caption (dom-children (dom-child-by-tag dom 'caption)))
+	 (header (dom-non-text-children (dom-child-by-tag dom 'thead)))
+	 (body (dom-non-text-children (or (dom-child-by-tag dom 'tbody)
+					  dom)))
+	 (footer (dom-non-text-children (dom-child-by-tag dom 'tfoot)))
          (bgcolor (dom-attr dom 'bgcolor))
 	 (start (point))
 	 (shr-stylesheet (nconc (list (cons 'background-color bgcolor))
@@ -1447,44 +1558,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
-	(if caption `((tr (td ,@caption))))
-	(if header
-	    (if footer
-		;; header + body + footer
-		(if (= nheader nbody)
-		    (if (= nbody nfooter)
-			`((tr (td (table (tbody ,@header ,@body ,@footer)))))
-		      (nconc `((tr (td (table (tbody ,@header ,@body)))))
-			     (if (= nfooter 1)
-				 footer
-			       `((tr (td (table (tbody ,@footer))))))))
-		  (nconc `((tr (td (table (tbody ,@header)))))
-			 (if (= nbody nfooter)
-			     `((tr (td (table (tbody ,@body ,@footer)))))
-			   (nconc `((tr (td (table (tbody ,@body)))))
-				  (if (= nfooter 1)
-				      footer
-				    `((tr (td (table (tbody ,@footer))))))))))
-	      ;; header + body
-	      (if (= nheader nbody)
-		  `((tr (td (table (tbody ,@header ,@body)))))
-		(if (= nheader 1)
-		    `(,@header (tr (td (table (tbody ,@body)))))
-		  `((tr (td (table (tbody ,@header))))
-		    (tr (td (table (tbody ,@body))))))))
-	  (if footer
-	      ;; body + footer
-	      (if (= nbody nfooter)
-		  `((tr (td (table (tbody ,@body ,@footer)))))
-		(nconc `((tr (td (table (tbody ,@body)))))
-		       (if (= nfooter 1)
-			   footer
-			 `((tr (td (table (tbody ,@footer))))))))
-	    (if caption
-		`((tr (td (table (tbody ,@body)))))
-	      body))))))
+      (if (dom-attr dom 'shr-fixed-table)
+	  (shr-tag-table-1 dom)
+	;; Only fix up the table once.
+	(let ((table
+	       (nconc
+		(list 'table nil)
+		(if caption `((tr nil (td nil ,@caption))))
+		(cond
+		 (header
+		  (if footer
+		      ;; header + body + footer
+		      (if (= nheader nbody)
+			  (if (= nbody nfooter)
+			      `((tr nil (td nil (table nil
+						       (tbody nil ,@header
+							      ,@body ,@footer)))))
+			    (nconc `((tr nil (td nil (table nil
+							    (tbody nil ,@header
+								   ,@body)))))
+				   (if (= nfooter 1)
+				       footer
+				     `((tr nil (td nil (table
+							nil (tbody
+							     nil ,@footer))))))))
+			(nconc `((tr nil (td nil (table nil (tbody
+							     nil ,@header)))))
+			       (if (= nbody nfooter)
+				   `((tr nil (td nil (table
+						      nil (tbody nil ,@body
+								 ,@footer)))))
+				 (nconc `((tr nil (td nil (table
+							   nil (tbody nil
+								      ,@body)))))
+					(if (= nfooter 1)
+					    footer
+					  `((tr nil (td nil (table
+							     nil
+							     (tbody
+							      nil
+							      ,@footer))))))))))
+		    ;; header + body
+		    (if (= nheader nbody)
+			`((tr nil (td nil (table nil (tbody nil ,@header
+							    ,@body)))))
+		      (if (= nheader 1)
+			  `(,@header (tr nil (td nil (table
+						      nil (tbody nil ,@body)))))
+			`((tr nil (td nil (table nil (tbody nil ,@header))))
+			  (tr nil (td nil (table nil (tbody nil ,@body)))))))))
+		 (footer
+		  ;; body + footer
+		  (if (= nbody nfooter)
+		      `((tr nil (td nil (table
+					 nil (tbody nil ,@body ,@footer)))))
+		    (nconc `((tr nil (td nil (table nil (tbody nil ,@body)))))
+			   (if (= nfooter 1)
+			       footer
+			     `((tr nil (td nil (table
+						nil (tbody nil ,@footer)))))))))
+		 (caption
+		  `((tr nil (td nil (table nil (tbody nil ,@body))))))
+		 (body)))))
+	  (dom-set-attribute table 'shr-fixed-table t)
+	  (setcdr dom (cdr table))
+	  (shr-tag-table-1 dom))))
     (when bgcolor
       (shr-colorize-region start (point) (cdr (assq 'color shr-stylesheet))
 			   bgcolor))
@@ -1492,6 +1630,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))
@@ -1501,38 +1641,102 @@ 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))
+			       'face (and (> (length line) 0)
+					  (shr-face-background
+					   (get-text-property
+					    (1- (length line)) 'face line)))
+			       'shr-table-indent shr-table-id)
+		   shr-table-vertical-line)
+		  (shr-colorize-region
+		   start (1- (point)) (nth 5 column) (nth 6 column)))
+		(forward-line 1))
+	      ;; Add blank lines at padding at the bottom of the TD,
+	      ;; possibly.
+	      (dotimes (i (- height (length lines)))
+		(end-of-line)
+		(let ((start (point)))
+		  (insert (propertize " "
+				      'display `(space :align-to (,pixel-align))
+				      'shr-table-indent shr-table-id)
+			  shr-table-vertical-line)
+		  (shr-colorize-region
+		   start (1- (point)) (nth 5 column) (nth 6 column)))
+		(forward-line 1))))))
       (unless collapse
-	(shr-insert-table-ruler widths)))))
+	(shr-insert-table-ruler widths)))
+    (unless (= start (point))
+      (put-text-property start (1+ start) 'shr-table-id shr-table-id))))
+
+(defun shr-face-background (face)
+  (and (consp face)
+       (let ((background nil))
+	 (dolist (elem face)
+	   (when (and (consp elem)
+		      (eq (car elem) :background))
+	     (setq background (cadr elem))))
+	 (and background
+	      (list :background background)))))
+
+(defun shr-expand-alignments (start end)
+  (while (< (setq start (next-single-property-change
+			 start 'shr-table-id nil end))
+	    end)
+    (goto-char start)
+    (let* ((shr-use-fonts t)
+	   (id (get-text-property (point) 'shr-table-id))
+	   (base (shr-pixel-column))
+	   elem)
+      (when id
+	(save-excursion
+	  (while (setq elem (text-property-any
+			     (point) end 'shr-table-indent id))
+	    (goto-char elem)
+	    (let ((align (get-text-property (point) 'display)))
+	      (put-text-property (point) (1+ (point)) 'display
+				 `(space :align-to (,(+ (car (nth 2 align))
+							base)))))
+	    (forward-char 1)))))
+    (setq start (1+ start))))
 
 (defun shr-insert-table-ruler (widths)
   (when shr-table-horizontal-line
@@ -1540,9 +1744,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)
@@ -1560,7 +1772,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 (1+ (length widths)))))
 	  (expanded-columns 0))
       ;; We have extra, unused space, so divide this space amongst the
       ;; columns.
@@ -1578,22 +1791,26 @@ 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)
   (let ((trs nil)
 	(shr-inhibit-decoration (not fill))
 	(rowspans (make-vector (length widths) 0))
+	(colspan-remaining 0)
+	colspan-width colspan-count
 	width colspan)
     (dolist (row (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)
@@ -1619,42 +1836,102 @@ The preference is a float determined from `shr-prefer-media-type'."
 	      (setq width
 		    (if column
 			(aref widths width-column)
-		      10))
-	      (when (and fill
-			 (setq colspan (dom-attr column colspan)))
+		      (* 10 shr-table-separator-pixel-width)))
+	      (when (setq colspan (dom-attr column 'colspan))
 		(setq colspan (min (string-to-number colspan)
 				   ;; The colspan may be wrong, so
 				   ;; truncate it to the length of the
 				   ;; remaining columns.
 				   (- (length widths) i)))
 		(dotimes (j (1- colspan))
-		  (if (> (+ i 1 j) (1- (length widths)))
-		      (setq width (aref widths (1- (length widths))))
-		    (setq width (+ width
-				   shr-table-separator-length
-				   (aref widths (+ i 1 j))))))
-		(setq width-column (+ width-column (1- colspan))))
-	      (when (or column
-			(not fill))
-		(push (shr-render-td column width fill)
-		      tds))
+		  (setq width
+			(if (> (+ i 1 j) (1- (length widths)))
+			    ;; If we have a colspan spec that's longer
+			    ;; than the table is wide, just use the last
+			    ;; width as the width.
+			    (aref widths (1- (length widths)))
+			  ;; Sum up the widths of the columns we're
+			  ;; spanning.
+			  (+ width
+			     shr-table-separator-length
+			     (aref widths (+ i 1 j))))))
+		(setq width-column (+ width-column (1- colspan))
+		      colspan-count colspan
+		      colspan-remaining colspan))
+	      (when column
+		(let ((data (shr-render-td column width fill)))
+		  (if (and (not fill)
+			   (> colspan-remaining 0))
+		      (progn
+			(setq colspan-width (car data))
+			(let ((this-width (/ colspan-width colspan-count)))
+			  (push (cons this-width (cadr data)) tds)
+			  (setq colspan-remaining (1- colspan-remaining))))
+		    (if (not fill)
+			(push (cons (car data) (cadr data)) tds)
+		      (push data tds)))))
+	      (when (and colspan
+			 (> colspan 1))
+		(dotimes (c (1- colspan))
+		  (setq i (1+ i))
+		  (push
+		   (if fill
+		       (list 0 0 -1 nil 1 nil nil)
+		     '(0 . 0))
+		   tds)))
 	      (setq i (1+ i)
 		    width-column (1+ width-column))))
 	  (push (nreverse tds) trs))))
     (nreverse trs)))
 
+(defun shr-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
@@ -1662,6 +1939,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)
@@ -1670,48 +1963,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))
@@ -1732,7 +2008,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))
 
@@ -1742,9 +2019,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)