* mm-view.el (mml-smime): Require.

[gnus] / lisp / shr.el

diff --git a/lisp/shr.el b/lisp/shr.el
index c828d19..0ed73cd 100644 (file)
--- a/lisp/shr.el
+++ b/lisp/shr.el
@@ -1,6 +1,6 @@
 ;;; shr.el --- Simple HTML Renderer
 
 ;;; 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
 
 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
 ;; Keywords: html


@@ -32,8 +32,6 @@
 
 (eval-when-compile (require 'cl))
 (require 'browse-url)
 
 (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"
 
 (defgroup shr nil
   "Simple HTML Renderer"


@@ -55,24 +53,33 @@ fit these criteria."
   :group 'shr
   :type 'regexp)
 
   :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 ?+
   :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 ?-
   :group 'shr
   :type 'character)
 
 (defcustom shr-hr-line ?-

-  "Character used to draw hr line."
+  "Character used to draw hr lines."

   :group 'shr
   :type 'character)
 
 (defcustom shr-width fill-column
   :group 'shr
   :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
   :group 'shr)
 
 (defvar shr-content-function nil


@@ -91,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-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)))
 
 (defvar shr-map
   (let ((map (make-sparse-keymap)))


@@ -109,7 +117,8 @@ cid: URL as the argument.")
 (defun shr-insert-document (dom)
   (setq shr-content-cache nil)
   (let ((shr-state nil)
 (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 ()
     (shr-descend (shr-transform-dom dom))))
 
 (defun shr-copy-url ()


@@ -154,7 +163,7 @@ redirects somewhere else."
 (defun shr-browse-image ()
   "Browse the image under point."
   (interactive)
 (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)
     (if (not url)
        (message "No image under point")
       (message "Browsing %s..." url)


@@ -163,7 +172,7 @@ redirects somewhere else."
 (defun shr-insert-image ()
   "Insert the image under point into the buffer."
   (interactive)
 (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)
     (if (not url)
        (message "No image under point")
       (message "Inserting %s..." url)


@@ -186,10 +195,23 @@ redirects somewhere else."
     (nreverse result)))
 
 (defun shr-descend (dom)
     (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))
     (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)
 
 (defun shr-generic (cont)
   (dolist (sub cont)


@@ -199,6 +221,26 @@ redirects somewhere else."
      ((listp (cdr sub))
       (shr-descend 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)))
 (defun shr-insert (text)
   (when (and (eq shr-state 'image)
             (not (string-match "\\`[ \t\n]+\\'" text)))


@@ -216,83 +258,130 @@ redirects somewhere else."
       (when (and (bolp)
                 (> shr-indentation 0))
        (shr-indent))
       (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)
       ;; 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)))
                   (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)))
          (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)
       (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))
     (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))
       (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.
     (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 ? )))
                        (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)) ?>)
-                         (aref fill-find-break-point-function-table
-                               (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))
 
 (defun shr-ensure-newline ()
   (unless (zerop (current-column))


@@ -344,7 +433,7 @@ redirects somewhere else."
      ((not url)
       (message "No link under point"))
      ((string-match "^mailto:" url)
      ((not url)
       (message "No link under point"))
      ((string-match "^mailto:" url)

-      (gnus-url-mailto url))
+      (browse-url-mailto url))

      (t
       (browse-url url)))))
 
      (t
       (browse-url url)))))
 


@@ -385,6 +474,11 @@ redirects somewhere else."
       (let ((image (ignore-errors
                      (shr-rescale-image data))))
         (when image
       (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)))
 
          (insert-image image (or alt "*"))))
     (insert alt)))
 


@@ -418,6 +512,7 @@ redirects somewhere else."
 ;; url-cache-extract autoloads url-cache.
 (declare-function url-cache-create-filename "url-cache" (url))
 (autoload 'mm-disable-multibyte "mm-util")
 ;; 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.
 
 (defun shr-get-image-data (url)
   "Get image data for URL.


@@ -431,6 +526,26 @@ Return a string with image data."
                (search-forward "\r\n\r\n" nil t))
        (buffer-substring (point) (point-max))))))
 
                (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)
 (defun shr-heading (cont &rest types)
   (shr-ensure-paragraph)
   (apply #'shr-fontize-cont cont types)


@@ -438,10 +553,10 @@ Return a string with image data."
 
 (autoload 'widget-convert-button "wid-edit")
 
 
 (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)
   (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))
    :keymap shr-map
    url)
   (put-text-property start (point) 'shr-url url))


@@ -450,8 +565,95 @@ Return a string with image data."
   "Encode URL."
   (browse-url-url-encode-chars url "[)$ ]"))
 
   "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.
 
 ;;; 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-label (cont)
+  (shr-generic cont)
+  (shr-ensure-paragraph))
+

 (defun shr-tag-p (cont)
   (shr-ensure-paragraph)
   (shr-indent)
 (defun shr-tag-p (cont)
   (shr-ensure-paragraph)
   (shr-indent)


@@ -484,6 +686,9 @@ Return a string with image data."
 
 (defun shr-parse-style (style)
   (when style
 
 (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
     (let ((plist nil))
       (dolist (elem (split-string style ";"))
        (when elem


@@ -492,6 +697,8 @@ Return a string with image data."
                     (cadr elem))
            (let ((name (replace-regexp-in-string "^ +\\| +$" "" (car elem)))
                  (value (replace-regexp-in-string "^ +\\| +$" "" (cadr elem))))
                     (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)))))
              (push (cons (intern name obarray)
                          value)
                    plist)))))


@@ -499,10 +706,11 @@ Return a string with image data."
 
 (defun shr-tag-a (cont)
   (let ((url (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)
        (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))
 
 (defun shr-tag-object (cont)
   (let ((start (point))


@@ -568,7 +776,9 @@ Return a string with image data."
                          t))))
        (put-text-property start (point) 'keymap shr-map)
        (put-text-property start (point) 'shr-alt alt)
                          t))))
        (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)))))
 
        (put-text-property start (point) 'help-echo alt)
        (setq shr-state 'image)))))
 


@@ -639,6 +849,19 @@ Return a string with image data."
   (shr-ensure-newline)
   (insert (make-string shr-width shr-hr-line) "\n"))
 
   (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
 ;;; Table rendering algorithm.
 
 ;; Table rendering is the only complicated thing here.  We do this by


@@ -685,6 +908,10 @@ Return a string with image data."
         (header (cdr (assq 'thead cont)))
         (body (or (cdr (assq 'tbody cont)) cont))
         (footer (cdr (assq 'tfoot cont)))
         (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))))
         (nheader (if header (shr-max-columns header)))
         (nbody (if body (shr-max-columns body)))
         (nfooter (if footer (shr-max-columns footer))))


@@ -725,7 +952,10 @@ Return a string with image data."
                       `((tr (td (table (tbody ,@footer))))))))
          (if caption
              `((tr (td (table (tbody ,@body)))))
                       `((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)
 
 (defun shr-find-elements (cont type)
   (let (result)


@@ -746,7 +976,7 @@ Return a string with image data."
                    max)))
       (dotimes (i height)
        (shr-indent)
                    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))
       (dolist (column row)
        (goto-char start)
        (let ((lines (nth 2 column))


@@ -755,7 +985,7 @@ Return a string with image data."
          (dolist (line lines)
            (setq overlay-line (pop overlay-lines))
            (end-of-line)
          (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)))
            (dolist (overlay overlay-line)
              (let ((o (make-overlay (- (point) (nth 0 overlay) 1)
                                     (- (point) (nth 1 overlay) 1)))


@@ -767,7 +997,8 @@ Return a string with image data."
          ;; possibly.
          (dotimes (i (- height (length lines)))
            (end-of-line)
          ;; 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)))
 
            (forward-line 1)))))
     (shr-insert-table-ruler widths)))
 


@@ -777,7 +1008,8 @@ Return a string with image data."
     (shr-indent))
   (insert shr-table-corner)
   (dotimes (i (length widths))
     (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)
   (insert "\n"))
 
 (defun shr-table-widths (table suggested-widths)


@@ -829,43 +1061,73 @@ Return a string with image data."
 
 (defun shr-render-td (cont width fill)
   (with-temp-buffer
 
 (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
          (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))
 
 (defun shr-natural-width ()
   (goto-char (point-min))