(shr-tag-script): Ignore <script>.

[gnus] / lisp / shr.el

diff --git a/lisp/shr.el b/lisp/shr.el
index 36e9333..2dc8528 100644 (file)
--- a/lisp/shr.el
+++ b/lisp/shr.el
@@ -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,18 +53,23 @@ 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)
 
   :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-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)))
 
 (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)
 (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)


@@ -162,7 +167,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)


@@ -180,24 +185,57 @@ redirects somewhere else."
            result))
     (dolist (sub dom)
       (if (stringp sub)
            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)
        (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))
     (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
 
 (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)))))
 
       (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)))
 (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)))
       (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)
          (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))
     (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)) ?>))
-               (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))


@@ -337,9 +423,13 @@ redirects somewhere else."
   "Browse the URL under point."
   (interactive)
   (let ((url (get-text-property (point) 'shr-url)))
   "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."
 
 (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)
           (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)))
 
   (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))
 
 (defun shr-rescale-image (data)
   (if (or (not (fboundp 'imagemagick-types))


@@ -407,6 +503,11 @@ redirects somewhere else."
                     image)))
       image)))
 
                     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."
 (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))))))
 
                (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-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)
   (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))


@@ -436,14 +559,103 @@ 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-p (cont)
   (shr-ensure-paragraph)
   (shr-indent)
   (shr-generic cont)
   (shr-ensure-paragraph))
 
 (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))
 
 (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-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
 (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


@@ -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))))
                     (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)))))


@@ -487,30 +696,50 @@ 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)
 
 (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] ")
     (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)))
     (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))
       (let ((start (point-marker)))
        (when (zerop (length alt))

-         (setq alt "[img]"))
+         (setq alt "*"))

        (cond
        (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)))
         ((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)
            (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))
         ((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-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))))
         (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) '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)
        (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"))
 
   (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


@@ -622,6 +866,7 @@ Return a string with image data."
   (setq cont (or (cdr (assq 'tbody cont))
                 cont))
   (let* ((shr-inhibit-images t)
   (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))
         (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.
   ;; 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)
 
 (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)))
         (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))))


@@ -692,7 +942,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)


@@ -713,7 +966,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))


@@ -722,7 +975,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)))


@@ -734,7 +987,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)))
 


@@ -744,7 +998,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)


@@ -796,43 +1051,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))