X-Git-Url: http://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fshr.el;h=2dc85281ed473f99a00a668996df656af4f5b5e2;hp=36e93338cb1b3f7cc575ef7b2cfb33a4c80bbe7c;hb=7231ea9d8f2c660dccf4e78bffa9b19eba3a8839;hpb=122b19bc5dc0ba2469b840f786c7682867681d7e

diff --git a/lisp/shr.el b/lisp/shr.el
index 36e93338c..2dc85281e 100644
--- a/lisp/shr.el
+++ b/lisp/shr.el
@@ -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"
@@ -55,18 +53,23 @@ fit these criteria."
   :group 'shr
   :type 'regexp)
 
-(defcustom shr-table-line ?-
-  "Character used to draw table line."
+(defcustom shr-table-horizontal-line ?-
+  "Character used to draw horizontal table lines."
+  :group 'shr
+  :type 'character)
+
+(defcustom shr-table-vertical-line ?|
+  "Character used to draw vertical table lines."
   :group 'shr
   :type 'character)
 
 (defcustom shr-table-corner ?+
-  "Character used to draw table corner."
+  "Character used to draw table corners."
   :group 'shr
   :type 'character)
 
 (defcustom shr-hr-line ?-
-  "Character used to draw hr line."
+  "Character used to draw hr lines."
   :group 'shr
   :type 'character)
 
@@ -90,6 +93,8 @@ cid: URL as the argument.")
 (defvar shr-list-mode nil)
 (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)))
@@ -153,7 +158,7 @@ redirects somewhere else."
 (defun shr-browse-image ()
   "Browse the image under point."
   (interactive)
-  (let ((url (get-text-property (point) 'shr-image)))
+  (let ((url (get-text-property (point) 'image-url)))
     (if (not url)
 	(message "No image under point")
       (message "Browsing %s..." url)
@@ -162,7 +167,7 @@ redirects somewhere else."
 (defun shr-insert-image ()
   "Insert the image under point into the buffer."
   (interactive)
-  (let ((url (get-text-property (point) 'shr-image)))
+  (let ((url (get-text-property (point) 'image-url)))
     (if (not url)
 	(message "No image under point")
       (message "Inserting %s..." url)
@@ -180,24 +185,57 @@ redirects somewhere else."
 	    result))
     (dolist (sub dom)
       (if (stringp sub)
-	  (push (cons :text sub) result)
+	  (push (cons 'text sub) result)
 	(push (shr-transform-dom sub) result)))
     (nreverse result)))
 
 (defun shr-descend (dom)
-  (let ((function (intern (concat "shr-tag-" (symbol-name (car dom))) obarray)))
+  (let ((function (intern (concat "shr-tag-" (symbol-name (car dom))) obarray))
+	(style (cdr (assq :style (cdr dom))))
+	(shr-stylesheet shr-stylesheet)
+	(start (point)))
+    (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)))))
+      (shr-generic (cdr dom)))
+    ;; 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)
     (cond
-     ((eq (car sub) :text)
+     ((eq (car sub) 'text)
       (shr-insert (cdr sub)))
      ((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)))
@@ -226,70 +264,118 @@ redirects somewhere else."
       (let (prev)
 	(when (and (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)))
       (insert elem)
-      (while (> (current-column) shr-width)
-	(unless (prog1
-		    (shr-find-fill-point)
-		  (when (eq (preceding-char) ? )
-		    (delete-char -1))
-		  (insert "\n"))
-	  (put-text-property (1- (point)) (point) 'shr-break t)
-	  ;; 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))
-      (insert " "))
+      (let (found)
+	(while (and (> (current-column) shr-width)
+		    (progn
+		      (setq found (shr-find-fill-point))
+		      (not (eolp))))
+	  (when (eq (preceding-char) ? )
+	    (delete-char -1))
+	  (insert "\n")
+	  (unless found
+	    (put-text-property (1- (point)) (point) 'shr-break t)
+	    ;; 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))
+	(insert " ")))
     (unless (string-match "[ \t\n]\\'" text)
       (delete-char -1)))))
 
 (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))))
+  (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)
-      (or (eolp)
-	  ;; Don't put kinsoku-bol characters at the beginning of a line,
-	  ;; or kinsoku-eol characters at the end of a line,
-	  (let ((count 4))
-	    (if (or shr-kinsoku-shorten
-		    (and (aref (char-category-set (preceding-char)) ?<)
-			 (progn
-			   (setq count (1- count))
-			   (backward-char 1)
-			   t)))
-		(while (and
-			(>= (setq count (1- count)) 0)
+	(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)
+       ;; 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 (aref (char-category-set (preceding-char)) ?<)
-			    (aref (char-category-set (following-char)) ?>)))
-		  (backward-char 1))
-	      (while (and (>= (setq count (1- count)) 0)
-			  (aref (char-category-set (following-char)) ?>))
-		(forward-char 1)))
-	    (when (eq (following-char) ? )
-	      (forward-char 1))
-	    t)))))
+			(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 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)
+			 (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))
@@ -337,9 +423,13 @@ redirects somewhere else."
   "Browse the URL under point."
   (interactive)
   (let ((url (get-text-property (point) 'shr-url)))
-    (if (not url)
-	(message "No link under point")
-      (browse-url url))))
+    (cond
+     ((not url)
+      (message "No link under point"))
+     ((string-match "^mailto:" url)
+      (browse-url-mailto url))
+     (t
+      (browse-url url)))))
 
 (defun shr-save-contents (directory)
   "Save the contents from URL in a file."
@@ -369,16 +459,22 @@ redirects somewhere else."
           (let ((alt (buffer-substring start end))
 		(inhibit-read-only t))
 	    (delete-region start end)
-	    (shr-put-image data start alt))))))
+	    (goto-char start)
+	    (shr-put-image data alt))))))
   (kill-buffer (current-buffer)))
 
-(defun shr-put-image (data point alt)
-  (if (not (display-graphic-p))
-      (insert alt)
-    (let ((image (ignore-errors
-		   (shr-rescale-image data))))
-      (when image
-	(put-image image point alt)))))
+(defun shr-put-image (data alt)
+  (if (display-graphic-p)
+      (let ((image (ignore-errors
+                     (shr-rescale-image data))))
+        (when image
+	  ;; When inserting big-ish pictures, put them at the
+	  ;; beginning of the line.
+	  (when (and (> (current-column) 0)
+		     (> (car (image-size image t)) 400))
+	    (insert "\n"))
+	  (insert-image image (or alt "*"))))
+    (insert alt)))
 
 (defun shr-rescale-image (data)
   (if (or (not (fboundp 'imagemagick-types))
@@ -407,6 +503,11 @@ redirects somewhere else."
 		     image)))
       image)))
 
+;; url-cache-extract autoloads url-cache.
+(declare-function url-cache-create-filename "url-cache" (url))
+(autoload 'mm-disable-multibyte "mm-util")
+(autoload 'browse-url-mailto "browse-url")
+
 (defun shr-get-image-data (url)
   "Get image data for URL.
 Return a string with image data."
@@ -419,15 +520,37 @@ Return a string with image data."
 		(search-forward "\r\n\r\n" nil t))
 	(buffer-substring (point) (point-max))))))
 
+(defun shr-image-displayer (content-function)
+  "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.  Note that START and END should be merkers."
+  `(lambda (url start end)
+     (when url
+       (if (string-match "\\`cid:" url)
+	   ,(when content-function
+	      `(let ((image (funcall ,content-function
+				     (substring url (match-end 0)))))
+		 (when image
+		   (goto-char start)
+		   (shr-put-image image
+				  (buffer-substring-no-properties start end))
+		   (delete-region (point) end))))
+	 (url-retrieve url 'shr-image-fetched
+		       (list (current-buffer) start end)
+		       t)))))
+
 (defun shr-heading (cont &rest types)
   (shr-ensure-paragraph)
   (apply #'shr-fontize-cont cont types)
   (shr-ensure-paragraph))
 
-(defun shr-urlify (start url)
+(autoload 'widget-convert-button "wid-edit")
+
+(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))
@@ -436,14 +559,103 @@ Return a string with image data."
   "Encode URL."
   (browse-url-url-encode-chars url "[)$ ]"))
 
+(autoload 'shr-color-visible "shr-color")
+(autoload 'shr-color->hexadecimal "shr-color")
+
+(defun shr-color-check (fg bg)
+  "Check that FG is visible on BG.
+Returns (fg bg) with corrected values.
+Returns nil if the colors that would be used are the default
+ones, in case fg and bg are nil."
+  (when (or fg bg)
+    (let ((fixed (cond ((null fg) 'fg)
+                       ((null bg) 'bg))))
+      ;; Convert colors to hexadecimal, or set them to default.
+      (let ((fg (or (shr-color->hexadecimal fg)
+                    (frame-parameter nil 'foreground-color)))
+            (bg (or (shr-color->hexadecimal bg)
+                    (frame-parameter nil 'background-color))))
+        (cond ((eq fixed 'bg)
+               ;; Only return the new fg
+               (list nil (cadr (shr-color-visible bg fg t))))
+              ((eq fixed 'fg)
+               ;; Invert args and results and return only the new bg
+               (list (cadr (shr-color-visible fg bg t)) nil))
+              (t
+               (shr-color-visible bg fg)))))))
+
+(defun shr-colorize-region (start end fg &optional bg)
+  (when (or fg bg)
+    (let ((new-colors (shr-color-check fg bg)))
+      (when 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 (bolp)
+	(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)))))
+
+(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-stylesheet (list (cons 'color fgcolor)
+			       (cons 'background-color bgcolor))))
+    (shr-generic cont)
+    (shr-colorize-region start (point) fgcolor bgcolor)))
+
+(defun shr-tag-style (cont)
+  )
+
+(defun shr-tag-script (cont)
+  )
+
 (defun shr-tag-p (cont)
   (shr-ensure-paragraph)
   (shr-indent)
   (shr-generic cont)
   (shr-ensure-paragraph))
 
+(defun shr-tag-div (cont)
+  (shr-ensure-newline)
+  (shr-indent)
+  (shr-generic cont)
+  (shr-ensure-newline))
+
 (defun shr-tag-b (cont)
   (shr-fontize-cont cont 'bold))
 
@@ -462,16 +674,11 @@ Return a string with image data."
 (defun shr-tag-s (cont)
   (shr-fontize-cont cont 'strike-through))
 
-(defun shr-tag-span (cont)
-  (let ((start (point))
-	(color (cdr (assq 'color (shr-parse-style (cdr (assq :style cont)))))))
-    (shr-generic cont)
-    (when color
-      (let ((overlay (make-overlay start (point))))
-	(overlay-put overlay 'face (cons 'foreground-color color))))))
-
 (defun shr-parse-style (style)
   (when style
+    (save-match-data
+      (when (string-match "\n" style)
+        (setq style (replace-match " " t t style))))
     (let ((plist nil))
       (dolist (elem (split-string style ";"))
 	(when elem
@@ -480,6 +687,8 @@ Return a string with image data."
 		     (cadr elem))
 	    (let ((name (replace-regexp-in-string "^ +\\| +$" "" (car elem)))
 		  (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)))))
@@ -487,30 +696,50 @@ Return a string with image data."
 
 (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 ((url (cdr (assq :src (cdr (assq 'embed cont)))))
-	(start (point)))
+  (let ((start (point))
+	url)
+    (dolist (elem cont)
+      (when (eq (car elem) 'embed)
+	(setq url (or url (cdr (assq :src (cdr elem))))))
+      (when (and (eq (car elem) 'param)
+		 (equal (cdr (assq :name (cdr elem))) "movie"))
+	(setq url (or url (cdr (assq :value (cdr elem)))))))
     (when url
       (shr-insert " [multimedia] ")
-      (shr-urlify start url))))
+      (shr-urlify start url))
+    (shr-generic cont)))
+
+(defun shr-tag-video (cont)
+  (let ((image (cdr (assq :poster cont)))
+	(url (cdr (assq :src cont)))
+	(start (point)))
+    (shr-tag-img nil image)
+    (shr-urlify start url)))
 
-(defun shr-tag-img (cont)
-  (when (and cont
-	     (cdr (assq :src cont)))
+(defun shr-tag-img (cont &optional url)
+  (when (or url
+	    (and cont
+		 (cdr (assq :src cont))))
     (when (and (> (current-column) 0)
 	       (not (eq shr-state 'image)))
       (insert "\n"))
     (let ((alt (cdr (assq :alt cont)))
-	  (url (cdr (assq :src cont))))
+	  (url (or url (cdr (assq :src cont)))))
       (let ((start (point-marker)))
 	(when (zerop (length alt))
-	  (setq alt "[img]"))
+	  (setq alt "*"))
 	(cond
+	 ((or (member (cdr (assq :height cont)) '("0" "1"))
+	      (member (cdr (assq :width cont)) '("0" "1")))
+	  ;; Ignore zero-sized or single-pixel images.
+	  )
 	 ((and (not shr-inhibit-images)
 	       (string-match "\\`cid:" url))
 	  (let ((url (substring url (match-end 0)))
@@ -518,27 +747,29 @@ Return a string with image data."
 	    (if (or (not shr-content-function)
 		    (not (setq image (funcall shr-content-function url))))
 		(insert alt)
-	      (shr-put-image image (point) alt))))
+	      (shr-put-image image alt))))
 	 ((or shr-inhibit-images
 	      (and shr-blocked-images
 		   (string-match shr-blocked-images url)))
 	  (setq shr-start (point))
 	  (let ((shr-state 'space))
-	    (if (> (length alt) 8)
-		(shr-insert (substring alt 0 8))
+	    (if (> (string-width alt) 8)
+		(shr-insert (truncate-string-to-width alt 8))
 	      (shr-insert alt))))
 	 ((url-is-cached (shr-encode-url url))
-	  (shr-put-image (shr-get-image-data url) (point) alt))
+	  (shr-put-image (shr-get-image-data url) alt))
 	 (t
 	  (insert alt)
 	  (ignore-errors
 	    (url-retrieve (shr-encode-url url) 'shr-image-fetched
 			  (list (current-buffer) start (point-marker))
 			  t))))
-	(insert " ")
 	(put-text-property start (point) 'keymap shr-map)
 	(put-text-property start (point) 'shr-alt alt)
-	(put-text-property start (point) 'shr-image url)
+	(put-text-property start (point) 'image-url url)
+	(put-text-property start (point) 'image-displayer
+			   (shr-image-displayer shr-content-function))
+	(put-text-property start (point) 'help-echo alt)
 	(setq shr-state 'image)))))
 
 (defun shr-tag-pre (cont)
@@ -608,6 +839,19 @@ Return a string with image data."
   (shr-ensure-newline)
   (insert (make-string shr-width shr-hr-line) "\n"))
 
+(defun shr-tag-title (cont)
+  (shr-heading cont 'bold 'underline))
+
+(defun shr-tag-font (cont)
+  (let* ((start (point))
+         (color (cdr (assq :color cont)))
+         (shr-stylesheet (nconc (list (cons 'color color))
+				shr-stylesheet)))
+    (shr-generic cont)
+    (when color
+      (shr-colorize-region start (point) color
+			   (cdr (assq 'background-color shr-stylesheet))))))
+
 ;;; Table rendering algorithm.
 
 ;; Table rendering is the only complicated thing here.  We do this by
@@ -622,6 +866,7 @@ Return a string with image data."
   (setq cont (or (cdr (assq 'tbody cont))
 		 cont))
   (let* ((shr-inhibit-images t)
+	 (shr-table-depth (1+ shr-table-depth))
 	 (shr-kinsoku-shorten t)
 	 ;; Find all suggested widths.
 	 (columns (shr-column-specs cont))
@@ -643,8 +888,9 @@ Return a string with image data."
   ;; Finally, insert all the images after the table.  The Emacs buffer
   ;; model isn't strong enough to allow us to put the images actually
   ;; into the tables.
-  (dolist (elem (shr-find-elements cont 'img))
-    (shr-tag-img (cdr elem))))
+  (when (zerop shr-table-depth)
+    (dolist (elem (shr-find-elements cont 'img))
+      (shr-tag-img (cdr elem)))))
 
 (defun shr-tag-table (cont)
   (shr-ensure-paragraph)
@@ -652,6 +898,10 @@ Return a string with image data."
 	 (header (cdr (assq 'thead cont)))
 	 (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))))
@@ -692,7 +942,10 @@ Return a string with image data."
 		       `((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)
@@ -713,7 +966,7 @@ Return a string with image data."
 		    max)))
       (dotimes (i height)
 	(shr-indent)
-	(insert "|\n"))
+	(insert shr-table-vertical-line "\n"))
       (dolist (column row)
 	(goto-char start)
 	(let ((lines (nth 2 column))
@@ -722,7 +975,7 @@ Return a string with image data."
 	  (dolist (line lines)
 	    (setq overlay-line (pop overlay-lines))
 	    (end-of-line)
-	    (insert line "|")
+	    (insert line shr-table-vertical-line)
 	    (dolist (overlay overlay-line)
 	      (let ((o (make-overlay (- (point) (nth 0 overlay) 1)
 				     (- (point) (nth 1 overlay) 1)))
@@ -734,7 +987,8 @@ Return a string with image data."
 	  ;; possibly.
 	  (dotimes (i (- height (length lines)))
 	    (end-of-line)
-	    (insert (make-string (string-width (car lines)) ? ) "|")
+	    (insert (make-string (string-width (car lines)) ? )
+		    shr-table-vertical-line)
 	    (forward-line 1)))))
     (shr-insert-table-ruler widths)))
 
@@ -744,7 +998,8 @@ Return a string with image data."
     (shr-indent))
   (insert shr-table-corner)
   (dotimes (i (length widths))
-    (insert (make-string (aref widths i) shr-table-line) shr-table-corner))
+    (insert (make-string (aref widths i) shr-table-horizontal-line)
+	    shr-table-corner))
   (insert "\n"))
 
 (defun shr-table-widths (table suggested-widths)
@@ -796,43 +1051,73 @@ Return a string with image data."
 
 (defun shr-render-td (cont width fill)
   (with-temp-buffer
-    (let ((cache (cdr (assoc (cons width cont) shr-content-cache))))
-      (if cache
-	  (insert cache)
-	(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)))
-    (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
+    (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
+	    (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))))
+	(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
-		(count-lines (point-min) (point-max))
-		(split-string (buffer-string) "\n")
-		(shr-collect-overlays))
-	(list max
-	      (shr-natural-width))))))
+		(shr-natural-width)))))))
 
 (defun shr-natural-width ()
   (goto-char (point-min))