X-Git-Url: http://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fshr.el;h=e0b4441e28eebec5f14b3a2bd60347f808073586;hp=da9405a0ccfa58af8389c547bcda24eaa7f025fa;hb=f6234873d0f9a0ee9b26beab123cf4e9d77099c8;hpb=7d4708959ac39d4a28259ff7387583b36f3c88d7

diff --git a/lisp/shr.el b/lisp/shr.el
index da9405a0c..e0b4441e2 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-2012 Free Software Foundation, Inc.
 
 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
 ;; Keywords: html
@@ -53,17 +53,17 @@ fit these criteria."
   :group 'shr
   :type 'regexp)
 
-(defcustom shr-table-horizontal-line ?-
+(defcustom shr-table-horizontal-line ?\s
   "Character used to draw horizontal table lines."
   :group 'shr
   :type 'character)
 
-(defcustom shr-table-vertical-line ?|
+(defcustom shr-table-vertical-line ?\s
   "Character used to draw vertical table lines."
   :group 'shr
   :type 'character)
 
-(defcustom shr-table-corner ?+
+(defcustom shr-table-corner ?\s
   "Character used to draw table corners."
   :group 'shr
   :type 'character)
@@ -74,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
@@ -83,6 +87,18 @@ fit these criteria."
 This is used for cid: URLs, and the function is called with the
 cid: URL as the argument.")
 
+(defvar shr-put-image-function 'shr-put-image
+  "Function called to put image and alt string.")
+
+(defface shr-strike-through '((t (:strike-through t)))
+  "Font for <s> elements."
+  :group 'shr)
+
+(defface shr-link
+  '((t (:inherit link)))
+  "Font for link elements."
+  :group 'shr)
+
 ;;; Internal variables.
 
 (defvar shr-folding-mode nil)
@@ -95,11 +111,14 @@ cid: URL as the argument.")
 (defvar shr-kinsoku-shorten nil)
 (defvar shr-table-depth 0)
 (defvar shr-stylesheet nil)
+(defvar shr-base nil)
+(defvar shr-ignore-cache nil)
 
 (defvar shr-map
   (let ((map (make-sparse-keymap)))
     (define-key map "a" 'shr-show-alt-text)
     (define-key map "i" 'shr-browse-image)
+    (define-key map "z" 'shr-zoom-image)
     (define-key map "I" 'shr-insert-image)
     (define-key map "u" 'shr-copy-url)
     (define-key map "v" 'shr-browse-url)
@@ -109,12 +128,42 @@ cid: URL as the argument.")
 
 ;; Public functions and commands.
 
+(defun shr-visit-file (file)
+  "Parse FILE as an HTML document, and render it in a new buffer."
+  (interactive "fHTML file name: ")
+  (pop-to-buffer "*html*")
+  (erase-buffer)
+  (shr-insert-document
+   (with-temp-buffer
+     (insert-file-contents file)
+     (libxml-parse-html-region (point-min) (point-max))))
+  (goto-char (point-min)))
+
 ;;;###autoload
 (defun shr-insert-document (dom)
+  "Render the parsed document DOM into the current buffer.
+DOM should be a parse tree as generated by
+`libxml-parse-html-region' or similar."
   (setq shr-content-cache nil)
-  (let ((shr-state nil)
-	(shr-start nil))
-    (shr-descend (shr-transform-dom dom))))
+  (let ((start (point))
+	(shr-state nil)
+	(shr-start nil)
+	(shr-base nil)
+	(shr-width (or shr-width (window-width))))
+    (shr-descend (shr-transform-dom dom))
+    (shr-remove-trailing-whitespace start (point))))
+
+(defun shr-remove-trailing-whitespace (start end)
+  (save-restriction
+    (narrow-to-region start end)
+    (delete-trailing-whitespace)
+    (goto-char start)
+    (while (not (eobp))
+      (end-of-line)
+      (dolist (overlay (overlays-at (point)))
+	(when (overlay-get overlay 'before-string)
+	  (overlay-put overlay 'before-string nil)))
+      (forward-line 1))))
 
 (defun shr-copy-url ()
   "Copy the URL under point to the kill ring.
@@ -155,14 +204,23 @@ redirects somewhere else."
 	(message "No image under point")
       (message "%s" text))))
 
-(defun shr-browse-image ()
-  "Browse the image under point."
-  (interactive)
+(defun shr-browse-image (&optional copy-url)
+  "Browse the image under point.
+If COPY-URL (the prefix if called interactively) is non-nil, copy
+the URL of the image to the kill buffer instead."
+  (interactive "P")
   (let ((url (get-text-property (point) 'image-url)))
-    (if (not url)
-	(message "No image under point")
+    (cond
+     ((not url)
+      (message "No image under point"))
+     (copy-url
+      (with-temp-buffer
+	(insert url)
+	(copy-region-as-kill (point-min) (point-max))
+	(message "Copied %s" url)))
+     (t
       (message "Browsing %s..." url)
-      (browse-url url))))
+      (browse-url url)))))
 
 (defun shr-insert-image ()
   "Insert the image under point into the buffer."
@@ -175,6 +233,40 @@ redirects somewhere else."
 		    (list (current-buffer) (1- (point)) (point-marker))
 		    t))))
 
+(defun shr-zoom-image ()
+  "Toggle the image size.
+The size will be rotated between the default size, the original
+size, and full-buffer size."
+  (interactive)
+  (let ((url (get-text-property (point) 'image-url))
+	(size (get-text-property (point) 'image-size))
+	(buffer-read-only nil))
+    (if (not url)
+	(message "No image under point")
+      ;; Delete the old picture.
+      (while (get-text-property (point) 'image-url)
+	(forward-char -1))
+      (forward-char 1)
+      (let ((start (point)))
+	(while (get-text-property (point) 'image-url)
+	  (forward-char 1))
+	(forward-char -1)
+	(put-text-property start (point) 'display nil)
+	(when (> (- (point) start) 2)
+	  (delete-region start (1- (point)))))
+      (message "Inserting %s..." url)
+      (url-retrieve url 'shr-image-fetched
+		    (list (current-buffer) (1- (point)) (point-marker)
+			  (list (cons 'size
+				      (cond ((or (eq size 'default)
+						 (null size))
+					     'original)
+					    ((eq size 'original)
+					     'full)
+					    ((eq size 'full)
+					     'default)))))
+		    t))))
+
 ;;; Utility functions.
 
 (defun shr-transform-dom (dom)
@@ -253,16 +345,12 @@ 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 (shr-char-breakable-p
 			     (setq prev (char-after (- (point) 2))))
@@ -270,6 +358,11 @@ redirects somewhere else."
 		       (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)
@@ -377,6 +470,19 @@ redirects somewhere else."
 	 (forward-char 1))))
     (not failed)))
 
+(defun shr-expand-url (url)
+  (cond
+   ;; Absolute URL.
+   ((or (not url)
+	(string-match "\\`[a-z]*:" url)
+	(not shr-base))
+    url)
+   ((and (not (string-match "/\\'" shr-base))
+	 (not (string-match "\\`/" url)))
+    (concat shr-base "/" url))
+   (t
+    (concat shr-base url))))
+
 (defun shr-ensure-newline ()
   (unless (zerop (current-column))
     (insert "\n")))
@@ -427,7 +533,7 @@ redirects somewhere else."
      ((not url)
       (message "No link under point"))
      ((string-match "^mailto:" url)
-      (browse-url-mailto url))
+      (browse-url-mail url))
      (t
       (browse-url url)))))
 
@@ -448,7 +554,7 @@ redirects somewhere else."
 		    (expand-file-name (file-name-nondirectory url)
 				      directory)))))
 
-(defun shr-image-fetched (status buffer start end)
+(defun shr-image-fetched (status buffer start end &optional flags)
   (when (and (buffer-name buffer)
 	     (not (plist-get status :error)))
     (url-store-in-cache (current-buffer))
@@ -456,57 +562,88 @@ 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))
+		  (properties (text-properties-at start))
+		  (inhibit-read-only t))
+	      (delete-region start end)
+	      (goto-char start)
+	      (funcall shr-put-image-function data alt flags)
+	      (while properties
+		(let ((type (pop properties))
+		      (value (pop properties)))
+		  (unless (memq type '(display image-size))
+		    (put-text-property start (point) type value))))))))))
   (kill-buffer (current-buffer)))
 
-(defun shr-put-image (data alt)
+(defun shr-put-image (data alt &optional flags)
+  "Put image DATA with a string ALT.  Return image."
   (if (display-graphic-p)
-      (let ((image (ignore-errors
-                     (shr-rescale-image data))))
+      (let* ((size (cdr (assq 'size flags)))
+	     (start (point))
+	     (image (cond
+		     ((eq size 'original)
+		      (create-image data nil t :ascent 100))
+		     ((eq size 'full)
+		      (ignore-errors
+			(shr-rescale-image data t)))
+		     (t
+		      (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 "*"))))
+	  (if (eq size 'original)
+	      (let ((overlays (overlays-at (point))))
+		(insert-sliced-image image (or alt "*") nil 20 1)
+		(dolist (overlay overlays)
+		  (overlay-put overlay 'face 'default)))
+	    (insert-image image (or alt "*")))
+	  (put-text-property start (point) 'image-size size)
+	  (when (image-animated-p image)
+	    (image-animate image nil 60)))
+	image)
     (insert alt)))
 
-(defun shr-rescale-image (data)
-  (if (or (not (fboundp 'imagemagick-types))
-	  (not (get-buffer-window (current-buffer))))
-      (create-image data nil t)
-    (let* ((image (create-image data nil t))
-	   (size (image-size image t))
-	   (width (car size))
-	   (height (cdr size))
-	   (edges (window-inside-pixel-edges
-		   (get-buffer-window (current-buffer))))
-	   (window-width (truncate (* shr-max-image-proportion
-				      (- (nth 2 edges) (nth 0 edges)))))
-	   (window-height (truncate (* shr-max-image-proportion
-				       (- (nth 3 edges) (nth 1 edges)))))
-	   scaled-image)
-      (when (> height window-height)
-	(setq image (or (create-image data 'imagemagick t
-				      :height window-height)
-			image))
-	(setq size (image-size image t)))
-      (when (> (car size) window-width)
-	(setq image (or
-		     (create-image data 'imagemagick t
-				   :width window-width)
-		     image)))
-      image)))
+(defun shr-rescale-image (data &optional force)
+  "Rescale DATA, if too big, to fit the current buffer.
+If FORCE, rescale the image anyway."
+  (let ((image (create-image data nil t :ascent 100)))
+    (if (or (not (fboundp 'imagemagick-types))
+	    (not (get-buffer-window (current-buffer))))
+	image
+      (let* ((size (image-size image t))
+	     (width (car size))
+	     (height (cdr size))
+	     (edges (window-inside-pixel-edges
+		     (get-buffer-window (current-buffer))))
+	     (window-width (truncate (* shr-max-image-proportion
+					(- (nth 2 edges) (nth 0 edges)))))
+	     (window-height (truncate (* shr-max-image-proportion
+					 (- (nth 3 edges) (nth 1 edges)))))
+	     scaled-image)
+	(when (or force
+		  (> height window-height))
+	  (setq image (or (create-image data 'imagemagick t
+					:height window-height
+					:ascent 100)
+			  image))
+	  (setq size (image-size image t)))
+	(when (> (car size) window-width)
+	  (setq image (or
+		       (create-image data 'imagemagick t
+				     :width window-width
+				     :ascent 100)
+		       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")
+(autoload 'browse-url-mail "browse-url")
 
 (defun shr-get-image-data (url)
   "Get image data for URL.
@@ -524,7 +661,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 markers."
   `(lambda (url start end)
      (when url
        (if (string-match "\\`cid:" url)
@@ -533,10 +670,9 @@ START, and END."
 				     (substring url (match-end 0)))))
 		 (when image
 		   (goto-char start)
-		   (shr-put-image image
-				  (prog1
-				      (buffer-substring-no-properties start end)
-				    (delete-region start end))))))
+		   (funcall shr-put-image-function
+			    image (buffer-substring start end))
+		   (delete-region (point) end))))
 	 (url-retrieve url 'shr-image-fetched
 		       (list (current-buffer) start end)
 		       t)))))
@@ -554,6 +690,7 @@ START, and END."
    :help-echo (if title (format "%s (%s)" url title) url)
    :keymap shr-map
    url)
+  (shr-add-font start (point) 'shr-link)
   (put-text-property start (point) 'shr-url url))
 
 (defun shr-encode-url (url)
@@ -592,9 +729,10 @@ ones, in case fg and bg are nil."
 	(when fg
 	  (shr-put-color start end :foreground (cadr new-colors)))
 	(when bg
-	  (shr-put-color start end :background (car new-colors)))))))
+	  (shr-put-color start end :background (car new-colors))))
+      new-colors)))
 
-;; Put a color in the region, but avoid putting colors on on blank
+;; Put a color in the region, but avoid putting colors 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
@@ -603,17 +741,72 @@ ones, in case fg and bg are nil."
   (save-excursion
     (goto-char start)
     (while (< (point) end)
-      (when (bolp)
+      (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)))))
+	(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)))
+	 (do-put (and (listp old-props)
+                      (not (memq type old-props))))
 	 change)
     (while (< start end)
       (setq change (next-single-property-change start 'face nil end))
@@ -621,7 +814,8 @@ ones, in case fg and bg are nil."
 	(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 do-put (and (listp old-props)
+                        (not (memq type old-props))))
       (setq start change))
     (when (and do-put
 	       (> end start))
@@ -632,7 +826,8 @@ ones, in case fg and bg are nil."
 
 (defun shr-tag-body (cont)
   (let* ((start (point))
-	 (fgcolor (cdr (assq :fgcolor cont)))
+	 (fgcolor (cdr (or (assq :fgcolor cont)
+                           (assq :text cont))))
 	 (bgcolor (cdr (assq :bgcolor cont)))
 	 (shr-stylesheet (list (cons 'color fgcolor)
 			       (cons 'background-color bgcolor))))
@@ -642,6 +837,26 @@ ones, in case fg and bg are nil."
 (defun shr-tag-style (cont)
   )
 
+(defun shr-tag-script (cont)
+  )
+
+(defun shr-tag-comment (cont)
+  )
+
+(defun shr-tag-sup (cont)
+  (let ((start (point)))
+    (shr-generic cont)
+    (put-text-property start (point) 'display '(raise 0.5))))
+
+(defun shr-tag-sub (cont)
+  (let ((start (point)))
+    (shr-generic cont)
+    (put-text-property start (point) 'display '(raise -0.5))))
+
+(defun shr-tag-label (cont)
+  (shr-generic cont)
+  (shr-ensure-paragraph))
+
 (defun shr-tag-p (cont)
   (shr-ensure-paragraph)
   (shr-indent)
@@ -654,6 +869,12 @@ ones, in case fg and bg are nil."
   (shr-generic cont)
   (shr-ensure-newline))
 
+(defun shr-tag-s (cont)
+  (shr-fontize-cont cont 'shr-strike-through))
+
+(defun shr-tag-del (cont)
+  (shr-fontize-cont cont 'shr-strike-through))
+
 (defun shr-tag-b (cont)
   (shr-fontize-cont cont 'bold))
 
@@ -669,9 +890,6 @@ ones, in case fg and bg are nil."
 (defun shr-tag-u (cont)
   (shr-fontize-cont cont 'underline))
 
-(defun shr-tag-s (cont)
-  (shr-fontize-cont cont 'strike-through))
-
 (defun shr-parse-style (style)
   (when style
     (save-match-data
@@ -692,13 +910,16 @@ ones, in case fg and bg are nil."
 		    plist)))))
       plist)))
 
+(defun shr-tag-base (cont)
+  (setq shr-base (cdr (assq :href cont))))
+
 (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 title)))
+    (shr-urlify (or shr-start start) (shr-expand-url url) title)))
 
 (defun shr-tag-object (cont)
   (let ((start (point))
@@ -711,7 +932,7 @@ ones, in case fg and bg are nil."
 	(setq url (or url (cdr (assq :value (cdr elem)))))))
     (when url
       (shr-insert " [multimedia] ")
-      (shr-urlify start url))
+      (shr-urlify start (shr-expand-url url)))
     (shr-generic cont)))
 
 (defun shr-tag-video (cont)
@@ -719,7 +940,7 @@ ones, in case fg and bg are nil."
 	(url (cdr (assq :src cont)))
 	(start (point)))
     (shr-tag-img nil image)
-    (shr-urlify start url)))
+    (shr-urlify start (shr-expand-url url))))
 
 (defun shr-tag-img (cont &optional url)
   (when (or url
@@ -729,7 +950,7 @@ ones, in case fg and bg are nil."
 	       (not (eq shr-state 'image)))
       (insert "\n"))
     (let ((alt (cdr (assq :alt cont)))
-	  (url (or url (cdr (assq :src cont)))))
+	  (url (shr-expand-url (or url (cdr (assq :src cont))))))
       (let ((start (point-marker)))
 	(when (zerop (length alt))
 	  (setq alt "*"))
@@ -745,7 +966,7 @@ ones, in case fg and bg are nil."
 	    (if (or (not shr-content-function)
 		    (not (setq image (funcall shr-content-function url))))
 		(insert alt)
-	      (shr-put-image image alt))))
+	      (funcall shr-put-image-function image alt))))
 	 ((or shr-inhibit-images
 	      (and shr-blocked-images
 		   (string-match shr-blocked-images url)))
@@ -754,20 +975,30 @@ ones, in case fg and bg are nil."
 	    (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) alt))
+	 ((and (not shr-ignore-cache)
+	       (url-is-cached (shr-encode-url url)))
+	  (funcall shr-put-image-function (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))))
-	(put-text-property start (point) 'keymap shr-map)
-	(put-text-property start (point) 'shr-alt alt)
-	(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)
+	  (insert alt " ")
+	  (when (and shr-ignore-cache
+		     (url-is-cached (shr-encode-url url)))
+	    (let ((file (url-cache-create-filename (shr-encode-url url))))
+	      (when (file-exists-p file)
+		(delete-file file))))
+	  (funcall
+	   (if (fboundp 'url-queue-retrieve)
+	       'url-queue-retrieve
+	     'url-retrieve)
+	   (shr-encode-url url) 'shr-image-fetched
+	   (list (current-buffer) start (set-marker (make-marker) (1- (point))))
+	   t)))
+	(when (zerop shr-table-depth) ;; We are not in a table.
+	  (put-text-property start (point) 'keymap shr-map)
+	  (put-text-property start (point) 'shr-alt alt)
+	  (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)
@@ -903,44 +1134,53 @@ ones, in case fg and bg are nil."
 	 (nheader (if header (shr-max-columns header)))
 	 (nbody (if body (shr-max-columns body)))
 	 (nfooter (if footer (shr-max-columns footer))))
-    (shr-tag-table-1
-     (nconc
-      (if caption `((tr (td ,@caption))))
-      (if header
-	  (if footer
-	      ;; hader + body + footer
+    (if (and (not caption)
+	     (not header)
+	     (not (cdr (assq 'tbody cont)))
+	     (not (cdr (assq 'tr cont)))
+	     (not footer))
+	;; The table is totally invalid and just contains random junk.
+	;; Try to output it anyway.
+	(shr-generic cont)
+      ;; It's a real table, so render it.
+      (shr-tag-table-1
+       (nconc
+	(if caption `((tr (td ,@caption))))
+	(if header
+	    (if footer
+		;; hader + 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)
-		  (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)))))
+		  `((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))))))
     (when bgcolor
       (shr-colorize-region start (point) (cdr (assq 'color shr-stylesheet))
 			   bgcolor))))
@@ -985,8 +1225,11 @@ ones, in case fg and bg are nil."
 	  ;; possibly.
 	  (dotimes (i (- height (length lines)))
 	    (end-of-line)
-	    (insert (make-string (string-width (car lines)) ? )
-		    shr-table-vertical-line)
+	    (let ((start (point)))
+	      (insert (make-string (string-width (car lines)) ? )
+		      shr-table-vertical-line)
+	      (when (nth 4 column)
+		(shr-put-color start (1- (point)) :background (nth 4 column))))
 	    (forward-line 1)))))
     (shr-insert-table-ruler widths)))
 
@@ -1053,7 +1296,7 @@ ones, in case fg and bg are nil."
 	  (fgcolor (cdr (assq :fgcolor cont)))
 	  (style (cdr (assq :style cont)))
 	  (shr-stylesheet shr-stylesheet)
-	  overlays)
+	  overlays actual-colors)
       (when style
 	(setq style (and (string-match "color" style)
 			 (shr-parse-style style))))
@@ -1103,17 +1346,19 @@ ones, in case fg and bg are nil."
 	      (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))))
+	      (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")
-		  (shr-collect-overlays))
+		  (shr-collect-overlays)
+		  (car actual-colors))
 	  (list max
 		(shr-natural-width)))))))