X-Git-Url: https://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fshr.el;h=f3c75ccd6a31c5db06e40a4c4bef2092c74accb4;hb=c85ff27626350a909ee39474fecac012fec8cd26;hp=69973fbfb5028b90c476eafe165e66d9f80415ba;hpb=cf53c7ca2ad6094b3419eef41bb7333cd66996f5;p=gnus

diff --git a/lisp/shr.el b/lisp/shr.el
index 69973fbfb..f3c75ccd6 100644
--- a/lisp/shr.el
+++ b/lisp/shr.el
@@ -1,6 +1,6 @@
 ;;; shr.el --- Simple HTML Renderer
 
-;; Copyright (C) 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2010-2011 Free Software Foundation, Inc.
 
 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
 ;; Keywords: html
@@ -32,8 +32,6 @@
 
 (eval-when-compile (require 'cl))
 (require 'browse-url)
-(unless (aref (char-category-set (make-char 'japanese-jisx0208 33 35)) ?>)
-  (load "kinsoku" nil t))
 
 (defgroup shr nil
   "Simple HTML Renderer"
@@ -76,8 +74,12 @@ fit these criteria."
   :type 'character)
 
 (defcustom shr-width fill-column
-  "Frame width to use for rendering."
-  :type 'integer
+  "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."
+  :type '(choice (integer :tag "Fixed width in characters")
+		 (const   :tag "Use the width of the window" nil))
   :group 'shr)
 
 (defvar shr-content-function nil
@@ -96,6 +98,7 @@ cid: URL as the argument.")
 (defvar shr-content-cache nil)
 (defvar shr-kinsoku-shorten nil)
 (defvar shr-table-depth 0)
+(defvar shr-stylesheet nil)
 
 (defvar shr-map
   (let ((map (make-sparse-keymap)))
@@ -114,7 +117,8 @@ cid: URL as the argument.")
 (defun shr-insert-document (dom)
   (setq shr-content-cache nil)
   (let ((shr-state nil)
-	(shr-start nil))
+	(shr-start nil)
+	(shr-width (or shr-width (window-width))))
     (shr-descend (shr-transform-dom dom))))
 
 (defun shr-copy-url ()
@@ -193,18 +197,21 @@ redirects somewhere else."
 (defun shr-descend (dom)
   (let ((function (intern (concat "shr-tag-" (symbol-name (car dom))) obarray))
 	(style (cdr (assq :style (cdr dom))))
+	(shr-stylesheet shr-stylesheet)
 	(start (point)))
-    (when (and style
-	       (string-match "color" style))
-      (setq style (shr-parse-style style)))
+    (when style
+      (if (string-match "color" style)
+	  (setq shr-stylesheet (nconc (shr-parse-style style)
+				      shr-stylesheet))
+	(setq style nil)))
     (if (fboundp function)
 	(funcall function (cdr dom))
       (shr-generic (cdr dom)))
-    (when (consp style)
-      (shr-insert-background-overlay (cdr (assq 'background-color style))
-                                     start)
-      (shr-insert-foreground-overlay (cdr (assq 'color style))
-                                     start (point)))))
+    ;; If style is set, then this node has set the color.
+    (when style
+      (shr-colorize-region start (point)
+			   (cdr (assq 'color shr-stylesheet))
+			   (cdr (assq 'background-color shr-stylesheet))))))
 
 (defun shr-generic (cont)
   (dolist (sub cont)
@@ -214,6 +221,26 @@ redirects somewhere else."
      ((listp (cdr sub))
       (shr-descend sub)))))
 
+(defmacro shr-char-breakable-p (char)
+  "Return non-nil if a line can be broken before and after CHAR."
+  `(aref fill-find-break-point-function-table ,char))
+(defmacro shr-char-nospace-p (char)
+  "Return non-nil if no space is required before and after CHAR."
+  `(aref fill-nospace-between-words-table ,char))
+
+;; KINSOKU is a Japanese word meaning a rule that should not be violated.
+;; In Emacs, it is a term used for characters, e.g. punctuation marks,
+;; parentheses, and so on, that should not be placed in the beginning
+;; of a line or the end of a line.
+(defmacro shr-char-kinsoku-bol-p (char)
+  "Return non-nil if a line ought not to begin with CHAR."
+  `(aref (char-category-set ,char) ?>))
+(defmacro shr-char-kinsoku-eol-p (char)
+  "Return non-nil if a line ought not to end with CHAR."
+  `(aref (char-category-set ,char) ?<))
+(unless (shr-char-kinsoku-bol-p (make-char 'japanese-jisx0208 33 35))
+  (load "kinsoku" nil t))
+
 (defun shr-insert (text)
   (when (and (eq shr-state 'image)
 	     (not (string-match "\\`[ \t\n]+\\'" text)))
@@ -231,24 +258,24 @@ redirects somewhere else."
       (when (and (bolp)
 		 (> shr-indentation 0))
 	(shr-indent))
-      ;; 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)))
       ;; 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 (eq (preceding-char) ? )
+	(when (and (> (current-column) shr-indentation)
+		   (eq (preceding-char) ? )
 		   (or (= (line-beginning-position) (1- (point)))
-		       (and (aref fill-find-break-point-function-table
-				  (setq prev (char-after (- (point) 2))))
-			    (aref (char-category-set prev) ?>))
-		       (and (aref fill-nospace-between-words-table prev)
-			    (aref fill-nospace-between-words-table
-				  (aref elem 0)))))
+		       (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)
       (let (found)
 	(while (and (> (current-column) shr-width)
@@ -273,67 +300,88 @@ redirects somewhere else."
 (defun shr-find-fill-point ()
   (when (> (move-to-column shr-width) shr-width)
     (backward-char 1))
-  (let (failed)
-    (while (not
-	    (or (setq failed (= (current-column) shr-indentation))
-		(eq (preceding-char) ? )
-		(eq (following-char) ? )
-		(aref fill-find-break-point-function-table (preceding-char))
-		(aref (char-category-set (preceding-char)) ?>)))
+  (let ((bp (point))
+	failed)
+    (while (not (or (setq failed (= (current-column) shr-indentation))
+		    (eq (preceding-char) ? )
+		    (eq (following-char) ? )
+		    (shr-char-breakable-p (preceding-char))
+		    (shr-char-breakable-p (following-char))
+		    (if (eq (preceding-char) ?')
+			(not (memq (char-after (- (point) 2))
+				   (list nil ?\n ? )))
+		      (and (shr-char-kinsoku-bol-p (preceding-char))
+			   (shr-char-breakable-p (following-char))
+			   (not (shr-char-kinsoku-bol-p (following-char)))))
+		    (shr-char-kinsoku-eol-p (following-char))))
       (backward-char 1))
+    (if (and (not (or failed (eolp)))
+	     (eq (preceding-char) ?'))
+	(while (not (or (setq failed (eolp))
+			(eq (following-char) ? )
+			(shr-char-breakable-p (following-char))
+			(shr-char-kinsoku-eol-p (following-char))))
+	  (forward-char 1)))
     (if failed
 	;; There's no breakable point, so we give it up.
-	(progn
-	  (end-of-line)
-	  (while (aref fill-find-break-point-function-table (preceding-char))
-	    (backward-char 1))
-	  nil)
+	(let (found)
+	  (goto-char bp)
+	  (unless shr-kinsoku-shorten
+	    (while (and (setq found (re-search-forward
+				     "\\(\\c>\\)\\| \\|\\c<\\|\\c|"
+				     (line-end-position) 'move))
+			(eq (preceding-char) ?')))
+	    (if (and found (not (match-beginning 1)))
+		(goto-char (match-beginning 0)))))
       (or
        (eolp)
-       (progn
-	 ;; Don't put kinsoku-bol characters at the beginning of a line,
-	 ;; or kinsoku-eol characters at the end of a line.
-	 (cond
-	  (shr-kinsoku-shorten
-	   (while (and
-		   (not (memq (preceding-char) (list ?\C-@ ?\n ? )))
-		   (not (or (aref (char-category-set (preceding-char)) ?>)
-			    (aref (char-category-set (following-char)) ?<)))
-		   (or (aref (char-category-set (preceding-char)) ?<)
-		       (aref (char-category-set (following-char)) ?>)))
-	     (backward-char 1)))
-	  ((aref (char-category-set (preceding-char)) ?<)
-	   (let ((count 3))
-	     (while (progn
-		      (backward-char 1)
-		      (and
-		       (> (setq count (1- count)) 0)
-		       (not (memq (preceding-char) (list ?\C-@ ?\n ? )))
-		       (or (aref (char-category-set (preceding-char)) ?<)
-			   (aref (char-category-set (following-char)) ?>))))))
-	   (if (and (setq failed (= (current-column) shr-indentation))
-		    (re-search-forward "\\c|" (line-end-position) 'move))
+       ;; Don't put kinsoku-bol characters at the beginning of a line,
+       ;; or kinsoku-eol characters at the end of a line.
+       (cond
+	(shr-kinsoku-shorten
+	 (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))
+	   ;; 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-width))
+		       (progn
+			 (setq bp (point))
+			 (shr-char-kinsoku-eol-p (following-char)))))
+	   (goto-char bp)))
+	((shr-char-kinsoku-eol-p (preceding-char))
+	 (if (shr-char-kinsoku-eol-p (following-char))
+	     ;; There are consecutive kinsoku-eol characters.
+	     (setq failed t)
+	   (let ((count 4))
+	     (while
+		 (progn
+		   (backward-char 1)
+		   (and (> (setq count (1- count)) 0)
+			(not (memq (preceding-char) (list ?\C-@ ?\n ? )))
+			(or (shr-char-kinsoku-eol-p (preceding-char))
+			    (shr-char-kinsoku-bol-p (following-char)))))))
+	   (if (setq failed (= (current-column) shr-indentation))
 	       ;; There's no breakable point that doesn't violate kinsoku,
-	       ;; so we look for the second best position.
-	       (let (bp)
-		 (while (and (<= (current-column) shr-width)
-			     (progn
-			       (setq bp (point))
-			       (not (eolp)))
-			     (aref fill-find-break-point-function-table
-				   (following-char)))
-		   (forward-char 1))
-		 (goto-char (or bp (line-end-position))))))
-	  (t
+	       ;; so we go to the second best position.
+	       (if (looking-at "\\(\\c<+\\)\\c<")
+		   (goto-char (match-end 1))
+		 (forward-char 1)))))
+	(t
+	 (if (shr-char-kinsoku-bol-p (preceding-char))
+	     ;; There are consecutive kinsoku-bol characters.
+	     (setq failed t)
 	   (let ((count 4))
 	     (while (and (>= (setq count (1- count)) 0)
-			 (aref (char-category-set (following-char)) ?>)
-			 (aref fill-find-break-point-function-table
-			       (following-char)))
-	       (forward-char 1)))))
-	 (when (eq (following-char) ? )
-	   (forward-char 1))
-	 (not failed))))))
+			 (shr-char-kinsoku-bol-p (following-char))
+			 (shr-char-breakable-p (following-char)))
+	       (forward-char 1))))))
+       (when (eq (following-char) ? )
+	 (forward-char 1))))
+    (not failed)))
 
 (defun shr-ensure-newline ()
   (unless (zerop (current-column))
@@ -414,11 +462,12 @@ redirects somewhere else."
 	      (search-forward "\r\n\r\n" nil t))
       (let ((data (buffer-substring (point) (point-max))))
         (with-current-buffer buffer
-          (let ((alt (buffer-substring start end))
-		(inhibit-read-only t))
-	    (delete-region start end)
-	    (goto-char start)
-	    (shr-put-image data alt))))))
+	  (save-excursion
+	    (let ((alt (buffer-substring start end))
+		  (inhibit-read-only t))
+	      (delete-region start end)
+	      (goto-char start)
+	      (shr-put-image data alt)))))))
   (kill-buffer (current-buffer)))
 
 (defun shr-put-image (data alt)
@@ -459,6 +508,9 @@ redirects somewhere else."
 		     (create-image data 'imagemagick t
 				   :width window-width)
 		     image)))
+      (when (and (fboundp 'create-animated-image)
+		 (eq (image-type data nil t) 'gif))
+	(setq image (create-animated-image data 'gif t)))
       image)))
 
 ;; url-cache-extract autoloads url-cache.
@@ -482,7 +534,7 @@ Return a string with image data."
   "Return a function to display an image.
 CONTENT-FUNCTION is a function to retrieve an image for a cid url that
 is an argument.  The function to be returned takes three arguments URL,
-START, and END."
+START, and END.  Note that START and END should be merkers."
   `(lambda (url start end)
      (when url
        (if (string-match "\\`cid:" url)
@@ -492,9 +544,8 @@ START, and END."
 		 (when image
 		   (goto-char start)
 		   (shr-put-image image
-				  (prog1
-				      (buffer-substring-no-properties start end)
-				    (delete-region start end))))))
+				  (buffer-substring-no-properties start end))
+		   (delete-region (point) end))))
 	 (url-retrieve url 'shr-image-fetched
 		       (list (current-buffer) start end)
 		       t)))))
@@ -506,10 +557,10 @@ START, and END."
 
 (autoload 'widget-convert-button "wid-edit")
 
-(defun shr-urlify (start url)
+(defun shr-urlify (start url &optional title)
   (widget-convert-button
    'url-link start (point)
-   :help-echo url
+   :help-echo (if title (format "%s (%s)" url title) url)
    :keymap shr-map
    url)
   (put-text-property start (point) 'shr-url url))
@@ -543,41 +594,123 @@ ones, in case fg and bg are nil."
               (t
                (shr-color-visible bg fg)))))))
 
-(defun shr-get-background (pos)
-  "Return background color at POS."
-  (dolist (overlay (overlays-in pos (1+ pos)))
-    (let ((background (plist-get (overlay-get overlay 'face)
-                                 :background)))
-      (when background
-        (return background)))))
-
-(defun shr-insert-foreground-overlay (fg start end)
-  (when fg
-    (let ((bg (shr-get-background start)))
-      (let ((new-colors (shr-color-check fg bg)))
-        (when new-colors
-          (overlay-put (make-overlay start end) 'face
-                       (list :foreground (cadr new-colors))))))))
-
-(defun shr-insert-background-overlay (bg start)
-  "Insert an overlay with background color BG at START.
-The overlay has rear-advance set to t, so it will be used when
-text will be inserted at start."
-  (when bg
-    (let ((new-colors (shr-color-check nil bg)))
+(defun shr-colorize-region (start end fg &optional bg)
+  (when (or fg bg)
+    (let ((new-colors (shr-color-check fg bg)))
       (when new-colors
-        (overlay-put (make-overlay start start nil nil t) 'face
-                     (list :background (car new-colors)))))))
+	(when fg
+	  (shr-put-color start end :foreground (cadr new-colors)))
+	(when bg
+	  (shr-put-color start end :background (car new-colors)))))))
+
+;; Put a color in the region, but avoid putting colors on on blank
+;; text at the start of the line, and the newline at the end, to avoid
+;; ugliness.  Also, don't overwrite any existing color information,
+;; since this can be called recursively, and we want the "inner" color
+;; to win.
+(defun shr-put-color (start end type color)
+  (save-excursion
+    (goto-char start)
+    (while (< (point) end)
+      (when (and (bolp)
+		 (not (eq type :background)))
+	(skip-chars-forward " "))
+      (when (> (line-end-position) (point))
+	(shr-put-color-1 (point) (min (line-end-position) end) type color))
+      (if (< (line-end-position) end)
+	  (forward-line 1)
+	(goto-char end)))
+    (when (and (eq type :background)
+	       (= shr-table-depth 0))
+      (shr-expand-newlines start end color))))
+
+(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-natural-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))
+    (if (null overlays)
+	width
+      (dolist (overlay overlays)
+	(setq previous-width
+	      (+ previous-width
+		 (length (plist-get (overlay-properties overlay)
+				    'before-string)))))
+      (+ width previous-width))))
+
+(defun shr-put-color-1 (start end type color)
+  (let* ((old-props (get-text-property start 'face))
+	 (do-put (not (memq type old-props)))
+	 change)
+    (while (< start end)
+      (setq change (next-single-property-change start 'face nil end))
+      (when do-put
+	(put-text-property start change 'face
+			   (nconc (list type color) old-props)))
+      (setq old-props (get-text-property change 'face))
+      (setq do-put (not (memq type old-props)))
+      (setq start change))
+    (when (and do-put
+	       (> end start))
+      (put-text-property start end 'face
+			 (nconc (list type color old-props))))))
 
 ;;; Tag-specific rendering rules.
 
 (defun shr-tag-body (cont)
-  (let ((start (point))
-        (fgcolor (cdr (assq :fgcolor cont)))
-        (bgcolor (cdr (assq :bgcolor cont))))
-    (shr-insert-background-overlay bgcolor start)
+  (let* ((start (point))
+	 (fgcolor (cdr (assq :fgcolor cont)))
+	 (bgcolor (cdr (assq :bgcolor cont)))
+	 (shr-stylesheet (list (cons 'color fgcolor)
+			       (cons 'background-color bgcolor))))
     (shr-generic cont)
-    (shr-insert-foreground-overlay fgcolor start (point))))
+    (shr-colorize-region start (point) fgcolor bgcolor)))
+
+(defun shr-tag-style (cont)
+  )
+
+(defun shr-tag-script (cont)
+  )
+
+(defun shr-tag-label (cont)
+  (shr-generic cont)
+  (shr-ensure-paragraph))
 
 (defun shr-tag-p (cont)
   (shr-ensure-paragraph)
@@ -631,10 +764,11 @@ text will be inserted at start."
 
 (defun shr-tag-a (cont)
   (let ((url (cdr (assq :href cont)))
+        (title (cdr (assq :title cont)))
 	(start (point))
 	shr-start)
     (shr-generic cont)
-    (shr-urlify (or shr-start start) url)))
+    (shr-urlify (or shr-start start) url title)))
 
 (defun shr-tag-object (cont)
   (let ((start (point))
@@ -777,10 +911,14 @@ text will be inserted at start."
   (shr-heading cont 'bold 'underline))
 
 (defun shr-tag-font (cont)
-  (let ((start (point))
-        (color (cdr (assq :color cont))))
+  (let* ((start (point))
+         (color (cdr (assq :color cont)))
+         (shr-stylesheet (nconc (list (cons 'color color))
+				shr-stylesheet)))
     (shr-generic cont)
-    (shr-insert-foreground-overlay color start (point))))
+    (when color
+      (shr-colorize-region start (point) color
+			   (cdr (assq 'background-color shr-stylesheet))))))
 
 ;;; Table rendering algorithm.
 
@@ -829,10 +967,12 @@ text will be inserted at start."
 	 (body (or (cdr (assq 'tbody cont)) cont))
 	 (footer (cdr (assq 'tfoot cont)))
          (bgcolor (cdr (assq :bgcolor cont)))
+	 (start (point))
+	 (shr-stylesheet (nconc (list (cons 'background-color bgcolor))
+				shr-stylesheet))
 	 (nheader (if header (shr-max-columns header)))
 	 (nbody (if body (shr-max-columns body)))
 	 (nfooter (if footer (shr-max-columns footer))))
-    (shr-insert-background-overlay bgcolor (point))
     (shr-tag-table-1
      (nconc
       (if caption `((tr (td ,@caption))))
@@ -870,7 +1010,10 @@ text will be inserted at start."
 		       `((tr (td (table (tbody ,@footer))))))))
 	  (if caption
 	      `((tr (td (table (tbody ,@body)))))
-	    body)))))))
+	    body)))))
+    (when bgcolor
+      (shr-colorize-region start (point) (cdr (assq 'color shr-stylesheet))
+			   bgcolor))))
 
 (defun shr-find-elements (cont type)
   (let (result)
@@ -975,48 +1118,74 @@ text will be inserted at start."
     (nreverse trs)))
 
 (defun shr-render-td (cont width fill)
-  (let ((background (shr-get-background (point))))
-    (with-temp-buffer
+  (with-temp-buffer
+    (let ((bgcolor (cdr (assq :bgcolor cont)))
+	  (fgcolor (cdr (assq :fgcolor cont)))
+	  (style (cdr (assq :style cont)))
+	  (shr-stylesheet shr-stylesheet)
+	  overlays)
+      (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 ((cache (cdr (assoc (cons width cont) shr-content-cache))))
-        (if cache
-            (insert cache)
-          (shr-insert-background-overlay (or (cdr (assq :bgcolor cont))
-                                             background)
-                                         (point))
-          (let ((shr-width width)
-                (shr-indentation 0))
-            (shr-generic cont))
-          (delete-region
-           (point)
-           (+ (point)
-              (skip-chars-backward " \t\n")))
-          (push (cons (cons width cont) (buffer-string))
-                shr-content-cache)))
+	(if cache
+	    (progn
+	      (insert (car cache))
+	      (let ((end (length (car cache))))
+		(dolist (overlay (cadr cache))
+		  (let ((new-overlay
+			 (make-overlay (1+ (- end (nth 0 overlay)))
+				       (1+ (- end (nth 1 overlay)))))
+			(properties (nth 2 overlay)))
+		    (while properties
+		      (overlay-put new-overlay
+				   (pop properties) (pop properties)))))))
+	  (let ((shr-width width)
+		(shr-indentation 0))
+	    (shr-descend (cons 'td cont)))
+	  (delete-region
+	   (point)
+	   (+ (point)
+	      (skip-chars-backward " \t\n")))
+	  (push (list (cons width cont) (buffer-string)
+		      (shr-overlays-in-region (point-min) (point-max)))
+		shr-content-cache)))
       (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.
-            (while (not (eobp))
-              (end-of-line)
-              (when (> (- width (current-column)) 0)
-                (insert (make-string (- width (current-column)) ? )))
-              (forward-line 1))))
-        (if fill
-            (list max
-                  (count-lines (point-min) (point-max))
-                  (split-string (buffer-string) "\n")
-                  (shr-collect-overlays))
-          (list max
-                (shr-natural-width)))))))
+	(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.
+	    (while (not (eobp))
+	      (end-of-line)
+	      (when (> (- width (current-column)) 0)
+		(insert (make-string (- width (current-column)) ? )))
+	      (forward-line 1))))
+	(when style
+	  (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")
+		  (shr-collect-overlays))
+	  (list max
+		(shr-natural-width)))))))
 
 (defun shr-natural-width ()
   (goto-char (point-min))