Merge changes made in Gnus trunk.

nnir.el (nnir-categorize): Replace mapcar with mapc.
shr.el (shr-urlify): Display the title in <a> tags.
shr.el (shr-urlify): Show the URL before the title to avoid misleading URLs.
gnus-sum.el (gnus-summary-show-article): Reverse the meanings of `C-u
C-u g' and `C-u g' so that `C-u g' does what it traditionally did.
gnus.texi (Paging the Article): Note the reverse meanings of `C-u C-u g'.
gnus-html.el (gnus-html-put-image): Use widget instead of local maps
so that TAB works.
nnir.el (nnir-run-gmane): Use more careful test for gmane nntp server.
nnimap.el (nnimap-process-expiry-targets): Avoid downloading articles
unless necessary.
gnus-util.el (gnus-output-to-mail): Require nnmail before using nnmail
variables.
shr.el (shr-stylesheet): New dynamic variable for cascading the styles.
 (shr-colorize-region): New function.
 (shr-insert-background-overlay): Remove.
 (shr-render-td): Background setting should be taken care of on a higher level.
 (shr-tag-body): Use post-hoc colorizations.
 (shr-descend): Only render color/background when they change.
 (shr-tag-body): Set up a style sheet based on bgcolor/fgcolor.
 (shr-put-color-1): Don't overwrite old colors.
 (shr-colorize-region): When the background color isn't explicit, use a fixed background.
gnus.el (gnus-valid-select-methods): Allow nnimap to respool.
nntp.el (nntp-snarf-error-message): nnheader-report takes a format string as the parameter.
gnus-sum.el (gnus-summary-respool-article): The completion function expects a list instead of an alist.

12 files changed, 238 insertions, 130 deletions

diff --git a/doc/misc/ChangeLog b/doc/misc/ChangeLog
index 8d47de4f2a0..468a68b0a80 100644
--- a/doc/misc/ChangeLog
+++ b/doc/misc/ChangeLog
@@ -1,3 +1,8 @@
+2010-12-04  Lars Magne Ingebrigtsen  <larsi@gnus.org>
+
+        * gnus.texi (Paging the Article): Note the reverse meanings of `C-u C-u
+        g'.
+
 2010-12-02  Julien Danjou  <julien@danjou.info>
 
         * gnus.texi (Archived Messages): Remove gnus-outgoing-message-group.
diff --git a/doc/misc/gnus.texi b/doc/misc/gnus.texi
index 9e2e0b817b6..5b8a0b45683 100644
--- a/doc/misc/gnus.texi
+++ b/doc/misc/gnus.texi
@@ -6152,10 +6152,10 @@ Scroll the current article one line backward
 @findex gnus-summary-show-article
 @vindex gnus-summary-show-article-charset-alist
 (Re)fetch the current article (@code{gnus-summary-show-article}).  If
-given a prefix, fetch the current article, but don't run any of the
-article treatment functions.  If given a prefix twice (i.e., @kbd{C-u
-C-u g'}), show a completely ``raw'' article, just the way it came from
-the server.
+given a prefix, show a completely ``raw'' article, just the way it
+came from the server.  If given a prefix twice (i.e., @kbd{C-u C-u
+g'}), fetch the current article, but don't run any of the article
+treatment functions.
 
 @cindex charset, view article with different charset
 If given a numerical prefix, you can do semi-manual charset stuff.
diff --git a/lisp/gnus/ChangeLog b/lisp/gnus/ChangeLog
index 7d8e954debd..6ca94d17600 100644
--- a/lisp/gnus/ChangeLog
+++ b/lisp/gnus/ChangeLog
@@ -1,3 +1,57 @@
+2010-12-05  Lars Magne Ingebrigtsen  <larsi@gnus.org>
+
+        * gnus-sum.el (gnus-summary-respool-article): The completion function
+        expects a list instead of an alist.
+
+        * nntp.el (nntp-snarf-error-message): nnheader-report takes a format
+        string as the parameter.
+
+        * gnus.el (gnus-valid-select-methods): Allow nnimap to respool.
+
+        * shr.el (shr-stylesheet): New dynamic variable for cascading the
+        styles.
+        (shr-colorize-region): New function.
+        (shr-insert-background-overlay): Remove.
+        (shr-render-td): Background setting should be taken care of on a higher
+        level.
+        (shr-tag-body): Use post-hoc colorizations.
+        (shr-tag-body): Set up a style sheet based on bgcolor/fgcolor.
+        (shr-put-color-1): Don't overwrite old colors.
+        (shr-colorize-region): When the background color isn't explicit, use
+        a fixed background.
+
+        * gnus-util.el (gnus-output-to-mail): Require nnmail before using
+        nnmail variables.
+
+2010-12-05  Bjørn Mork  <bjorn@mork.no>
+
+        * nnimap.el (nnimap-process-expiry-targets): Avoid downloading articles
+        unless necessary.
+
+2010-12-05  Andrew Cohen  <cohen@andy.bu.edu>
+
+        * nnir.el (nnir-run-gmane): Use more careful test for gmane nntp
+        server.
+
+2010-12-04  Lars Magne Ingebrigtsen  <larsi@gnus.org>
+
+        * gnus-html.el (gnus-html-put-image): Use widget instead of local maps
+        so that TAB works.
+
+        * gnus-sum.el (gnus-summary-show-article): Reverse the meanings of `C-u
+        C-u g' and `C-u g' so that `C-u g' does what it traditionally did.
+
+        * shr.el (shr-urlify): Show the URL before the title to avoid
+        misleading URLs.
+
+2010-12-04  Adam Sjøgren  <asjo@koldfront.dk>
+
+        * shr.el (shr-urlify): Display the title in <a> tags.
+
+2010-12-04  Andrew Cohen  <cohen@andy.bu.edu>
+
+        * nnir.el (nnir-categorize): Replace mapcar with mapc.
+
 2010-12-03  Andrew Cohen  <cohen@andy.bu.edu>
 
         * nnir.el: Rearrange code to allow macros to be autoloaded by
diff --git a/lisp/gnus/gnus-html.el b/lisp/gnus/gnus-html.el
index 174e128a7e9..63a14b204fb 100644
--- a/lisp/gnus/gnus-html.el
+++ b/lisp/gnus/gnus-html.el
@@ -199,8 +199,11 @@ CHARS is a regexp-like character alternative (e.g., \"[)$]\")."
                                    (gnus-html-display-image url start end
                                                             ,alt-text))
                'gnus-image (list url start end alt-text)))
-        (gnus-overlay-put (gnus-make-overlay start end)
-                          'local-map gnus-html-image-map)
+        (widget-convert-button
+         'url-link start (point)
+         :help-echo alt-text
+         :keymap gnus-html-image-map
+         url)
         (if (string-match "\\`cid:" url)
             ;; URLs with cid: have their content stashed in other
             ;; parts of the MIME structure, so just insert them
@@ -473,10 +476,11 @@ Return a string with image data."
                   (let ((image (gnus-rescale-image image (gnus-html-maximum-image-size))))
                     (delete-region start end)
                     (gnus-put-image image alt-text 'external)
-                    (gnus-put-text-property start (point) 'help-echo alt-text)
-                    (gnus-overlay-put
-                     (gnus-make-overlay start (point)) 'local-map
-                     gnus-html-displayed-image-map)
+                    (widget-convert-button
+                     'url-link start (point)
+                     :help-echo alt-text
+                     :keymap gnus-html-displayed-image-map
+                     url)
                     (gnus-put-text-property start (point)
                                             'gnus-alt-text alt-text)
                     (when url
diff --git a/lisp/gnus/gnus-int.el b/lisp/gnus/gnus-int.el
index bcfff347968..767ac2e9fc5 100644
--- a/lisp/gnus/gnus-int.el
+++ b/lisp/gnus/gnus-int.el
@@ -259,20 +259,21 @@ If it is down, start it up (again)."
           (gnus-message 1 "Denied server %s" server)
           nil)
       ;; Open the server.
-      (let* ((open-server-function (gnus-get-function gnus-command-method 'open-server))
+      (let* ((open-server-function
+              (gnus-get-function gnus-command-method 'open-server))
              (result
-             (condition-case err
-                 (funcall open-server-function
-                          (nth 1 gnus-command-method)
-                          (nthcdr 2 gnus-command-method))
-               (error
-                (gnus-message 1 "Unable to open server %s due to: %s"
-                              server (error-message-string err))
-                nil)
-               (quit
-                (gnus-message 1 "Quit trying to open server %s" server)
-                nil)))
-            open-offline)
+              (condition-case err
+                  (funcall open-server-function
+                           (nth 1 gnus-command-method)
+                           (nthcdr 2 gnus-command-method))
+                (error
+                 (gnus-message 1 "Unable to open server %s due to: %s"
+                               server (error-message-string err))
+                 nil)
+                (quit
+                 (gnus-message 1 "Quit trying to open server %s" server)
+                 nil)))
+             open-offline)
         ;; If this hasn't been opened before, we add it to the list.
         (unless elem
           (setq elem (list gnus-command-method nil)
diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el
index ba124d5115d..2bb39af3fb8 100644
--- a/lisp/gnus/gnus-sum.el
+++ b/lisp/gnus/gnus-sum.el
@@ -9475,6 +9475,9 @@ C-u g', show the raw article."
    ((or (equal arg '(16))
         (eq arg t))
     ;; C-u C-u g
+    (let ((gnus-inhibit-article-treatments t))
+      (gnus-summary-select-article nil 'force)))
+   (t
     ;; We have to require this here to make sure that the following
     ;; dynamic binding isn't shadowed by autoloading.
     (require 'gnus-async)
@@ -9492,9 +9495,6 @@ C-u g', show the raw article."
           ;; Set it to nil for safety reason.
           (setq gnus-article-mime-handle-alist nil)
           (setq gnus-article-mime-handles nil)))
-      (gnus-summary-select-article nil 'force)))
-   (t
-    (let ((gnus-inhibit-article-treatments t))
       (gnus-summary-select-article nil 'force))))
   (gnus-summary-goto-subject gnus-current-article)
   (gnus-summary-position-point))
@@ -9934,7 +9934,7 @@ ACTION can be either `move' (the default), `crosspost' or `copy'."
 
         ;;;!!!Why is this necessary?
         (set-buffer gnus-summary-buffer)
-        
+
         (when (eq action 'move)
           (save-excursion
             (gnus-summary-goto-subject article)
@@ -10004,7 +10004,7 @@ current group into whatever groups they are destined to.  In the
 latter case, they will be copied into the relevant groups."
   (interactive
    (list current-prefix-arg
-         (let* ((methods (gnus-methods-using 'respool))
+         (let* ((methods (mapcar #'car (gnus-methods-using 'respool)))
                 (methname
                  (symbol-name (or gnus-summary-respool-default-method
                                   (car (gnus-find-method-for-group
diff --git a/lisp/gnus/gnus-util.el b/lisp/gnus/gnus-util.el
index 55d6ce55ebb..45fd26c86c0 100644
--- a/lisp/gnus/gnus-util.el
+++ b/lisp/gnus/gnus-util.el
@@ -902,6 +902,7 @@ Bind `print-quoted' and `print-readably' to t, and `print-length' and
 
 (defun gnus-write-buffer (file)
   "Write the current buffer's contents to FILE."
+  (require 'nnmail)
   (let ((file-name-coding-system nnmail-pathname-coding-system))
     ;; Make sure the directory exists.
     (gnus-make-directory (file-name-directory file))
@@ -1137,6 +1138,7 @@ In Emacs 22 this writes Babyl format; in Emacs 23 it writes mbox unless
 FILENAME exists and is Babyl format."
   (require 'rmail)
   (require 'mm-util)
+  (require 'nnmail)
   ;; Some of this codes is borrowed from rmailout.el.
   (setq filename (expand-file-name filename))
   ;; FIXME should we really be messing with this defcustom?
@@ -1228,6 +1230,7 @@ FILENAME exists and is Babyl format."
 
 (defun gnus-output-to-mail (filename &optional ask)
   "Append the current article to a mail file named FILENAME."
+  (require 'nnmail)
   (setq filename (expand-file-name filename))
   (let ((artbuf (current-buffer))
         (tmpbuf (get-buffer-create " *Gnus-output*")))
diff --git a/lisp/gnus/gnus.el b/lisp/gnus/gnus.el
index d32ecac5dc3..b4f7f836189 100644
--- a/lisp/gnus/gnus.el
+++ b/lisp/gnus/gnus.el
@@ -1608,7 +1608,7 @@ slower."
     ("nnweb" none)
     ("nnrss" none)
     ("nnagent" post-mail)
-    ("nnimap" post-mail address prompt-address physical-address)
+    ("nnimap" post-mail address prompt-address physical-address respool)
     ("nnmaildir" mail respool address)
     ("nnnil" none))
   "*An alist of valid select methods.
diff --git a/lisp/gnus/nnimap.el b/lisp/gnus/nnimap.el
index a53f9ac468d..4b4793dcfee 100644
--- a/lisp/gnus/nnimap.el
+++ b/lisp/gnus/nnimap.el
@@ -793,22 +793,42 @@ textual parts.")
 
 (defun nnimap-process-expiry-targets (articles group server)
   (let ((deleted-articles nil))
-    (dolist (article articles)
-      (let ((target nnmail-expiry-target))
-        (with-temp-buffer
-          (mm-disable-multibyte)
-          (when (nnimap-request-article article group server (current-buffer))
-            (nnheader-message 7 "Expiring article %s:%d" group article)
-            (when (functionp target)
-              (setq target (funcall target group)))
-            (when (and target
-                       (not (eq target 'delete)))
-              (if (or (gnus-request-group target t)
-                      (gnus-request-create-group target))
-                  (nnmail-expiry-target-group target group)
-                (setq target nil)))
-            (when target
-              (push article deleted-articles))))))
+    (cond
+     ;; shortcut further processing if we're going to delete the articles
+     ((eq nnmail-expiry-target 'delete)
+      (setq deleted-articles articles)
+      t)
+     ;; or just move them to another folder on the same IMAP server
+     ((and (not (functionp nnmail-expiry-target))
+           (gnus-server-equal (gnus-group-method nnmail-expiry-target)
+                              (gnus-server-to-method
+                               (format "nnimap:%s" server))))
+      (and (nnimap-possibly-change-group group server)
+           (with-current-buffer (nnimap-buffer)
+             (nnheader-message 7 "Expiring articles from %s: %s" group articles)
+             (nnimap-command
+              "UID COPY %s %S"
+              (nnimap-article-ranges (gnus-compress-sequence articles))
+              (utf7-encode (gnus-group-real-name nnmail-expiry-target) t))
+             (setq deleted-articles articles)))
+      t)
+     (t
+      (dolist (article articles)
+        (let ((target nnmail-expiry-target))
+          (with-temp-buffer
+            (mm-disable-multibyte)
+            (when (nnimap-request-article article group server (current-buffer))
+              (nnheader-message 7 "Expiring article %s:%d" group article)
+              (when (functionp target)
+                (setq target (funcall target group)))
+              (when (and target
+                         (not (eq target 'delete)))
+                (if (or (gnus-request-group target t)
+                        (gnus-request-create-group target))
+                    (nnmail-expiry-target-group target group)
+                  (setq target nil)))
+              (when target
+                (push article deleted-articles))))))))
     ;; Change back to the current group again.
     (nnimap-possibly-change-group group server)
     (setq deleted-articles (nreverse deleted-articles))
diff --git a/lisp/gnus/nnir.el b/lisp/gnus/nnir.el
index 7e1bd309c9d..b706d150f7d 100644
--- a/lisp/gnus/nnir.el
+++ b/lisp/gnus/nnir.el
@@ -269,7 +269,7 @@ as `(keyfunc member)' and the corresponding element is just
 is `(valuefunc member)'."
   `(unless (null ,sequence)
      (let (value)
-       (mapcar
+       (mapc
         (lambda (member)
           (let ((y (,keyfunc member))
                 (x ,(if valuefunc
@@ -1381,7 +1381,10 @@ Tested with Namazu 2.0.6 on a GNU/Linux system."
 ;; gmane interface
 (defun nnir-run-gmane (query srv &optional groups)
   "Run a search against a gmane back-end server."
-  (if (gnus-string-match-p "gmane.org$" srv)
+  (if (gnus-string-match-p
+       "gmane.org$"
+       (or (cadr (assoc 'nntp-address  (cddr (gnus-server-to-method srv))))
+           ""))
       (let* ((case-fold-search t)
              (qstring (cdr (assq 'query query)))
              (server (cadr (gnus-server-to-method srv)))
diff --git a/lisp/gnus/nntp.el b/lisp/gnus/nntp.el
index 6504f05c9d2..9c9054a49c7 100644
--- a/lisp/gnus/nntp.el
+++ b/lisp/gnus/nntp.el
@@ -398,7 +398,8 @@ be restored and the command retried."
       (cond ((looking-at "480")
              (nntp-handle-authinfo process))
             ((looking-at "482")
-             (nnheader-report 'nntp (get 'nntp-authinfo-rejected 'error-message))
+             (nnheader-report 'nntp "%s"
+                              (get 'nntp-authinfo-rejected 'error-message))
              (signal 'nntp-authinfo-rejected nil))
             ((looking-at "^.*\n")
              (delete-region (point) (progn (forward-line 1) (point)))))
@@ -1411,7 +1412,7 @@ password contained in '~/.nntp-authinfo'."
   (let ((message (buffer-string)))
     (while (string-match "[\r\n]+" message)
       (setq message (replace-match " " t t message)))
-    (nnheader-report 'nntp message)
+    (nnheader-report 'nntp "%s" message)
     message))
 
 (defun nntp-accept-process-output (process)
diff --git a/lisp/gnus/shr.el b/lisp/gnus/shr.el
index c07bb34ef8d..0b2fa939b1f 100644
--- a/lisp/gnus/shr.el
+++ b/lisp/gnus/shr.el
@@ -94,6 +94,7 @@ cid: URL as the argument.")
 (defvar shr-content-cache nil)
 (defvar shr-kinsoku-shorten nil)
 (defvar shr-table-depth 0)
+(defvar shr-stylesheet nil)
 
 (defvar shr-map
   (let ((map (make-sparse-keymap)))
@@ -191,18 +192,21 @@ redirects somewhere else."
 (defun shr-descend (dom)
   (let ((function (intern (concat "shr-tag-" (symbol-name (car dom))) obarray))
         (style (cdr (assq :style (cdr dom))))
+        (shr-stylesheet shr-stylesheet)
         (start (point)))
     (when (and style
                (string-match "color" style))
-      (setq style (shr-parse-style style)))
+      (setq shr-stylesheet (nconc (shr-parse-style style)
+                                  shr-stylesheet)))
     (if (fboundp function)
         (funcall function (cdr dom))
       (shr-generic (cdr dom)))
-    (when (consp style)
-      (shr-insert-background-overlay (cdr (assq 'background-color style))
-                                     start)
-      (shr-insert-foreground-overlay (cdr (assq 'color style))
-                                     start (point)))))
+    (let ((color (cdr (assq 'color shr-stylesheet)))
+          (background (cdr (assq 'background-color
+                                 shr-stylesheet))))
+      (when (and shr-stylesheet
+                 (or color background))
+        (shr-colorize-region start (point) color background)))))
 
 (defun shr-generic (cont)
   (dolist (sub cont)
@@ -544,10 +548,10 @@ START, and END."
 
 (autoload 'widget-convert-button "wid-edit")
 
-(defun shr-urlify (start url)
+(defun shr-urlify (start url &optional title)
   (widget-convert-button
    'url-link start (point)
-   :help-echo url
+   :help-echo (if title (format "%s (%s)" url title) url)
    :keymap shr-map
    url)
   (put-text-property start (point) 'shr-url url))
@@ -581,41 +585,58 @@ ones, in case fg and bg are nil."
               (t
                (shr-color-visible bg fg)))))))
 
-(defun shr-get-background (pos)
-  "Return background color at POS."
-  (dolist (overlay (overlays-in pos (1+ pos)))
-    (let ((background (plist-get (overlay-get overlay 'face)
-                                 :background)))
-      (when background
-        (return background)))))
-
-(defun shr-insert-foreground-overlay (fg start end)
+(defun shr-colorize-region (start end fg &optional bg)
   (when fg
-    (let ((bg (shr-get-background start)))
-      (let ((new-colors (shr-color-check fg bg)))
-        (when new-colors
-          (overlay-put (make-overlay start end) 'face
-                       (list :foreground (cadr new-colors))))))))
-
-(defun shr-insert-background-overlay (bg start)
-  "Insert an overlay with background color BG at START.
-The overlay has rear-advance set to t, so it will be used when
-text will be inserted at start."
-  (when bg
-    (let ((new-colors (shr-color-check nil bg)))
+    (let ((new-colors (shr-color-check fg bg)))
       (when new-colors
-        (overlay-put (make-overlay start start nil nil t) 'face
-                     (list :background (car new-colors)))))))
+        (shr-put-color start end :foreground (cadr new-colors))
+        (when bg
+          (shr-put-color start end :background (car new-colors)))))))
+
+;; Put a color in the region, but avoid putting colors on on blank
+;; text at the start of the line, and the newline at the end, to avoid
+;; ugliness.  Also, don't overwrite any existing color information,
+;; since this can be called recursively, and we want the "inner" color
+;; to win.
+(defun shr-put-color (start end type color)
+  (save-excursion
+    (goto-char start)
+    (while (< (point) end)
+      (when (bolp)
+        (skip-chars-forward " "))
+      (when (> (line-end-position) (point))
+        (shr-put-color-1 (point) (min (line-end-position) end) type color))
+      (if (< (line-end-position) end)
+          (forward-line 1)
+        (goto-char end)))))
+
+(defun shr-put-color-1 (start end type color)
+  (let* ((old-props (get-text-property start 'face))
+         (do-put (not (memq type old-props)))
+         change)
+    (while (< start end)
+      (setq change (next-single-property-change start 'face nil end))
+      (when do-put
+        (put-text-property start change 'face
+                           (nconc (list type color) old-props)))
+      (setq old-props (get-text-property change 'face))
+      (setq do-put (not (memq type old-props)))
+      (setq start change))
+    (when (and do-put
+               (> end start))
+      (put-text-property start end 'face
+                         (nconc (list type color old-props))))))
 
 ;;; Tag-specific rendering rules.
 
 (defun shr-tag-body (cont)
-  (let ((start (point))
-        (fgcolor (cdr (assq :fgcolor cont)))
-        (bgcolor (cdr (assq :bgcolor cont))))
-    (shr-insert-background-overlay bgcolor start)
+  (let* ((start (point))
+         (fgcolor (cdr (assq :fgcolor cont)))
+         (bgcolor (cdr (assq :bgcolor cont)))
+         (shr-stylesheet (list (cons :color fgcolor)
+                               (cons :background-color bgcolor))))
     (shr-generic cont)
-    (shr-insert-foreground-overlay fgcolor start (point))))
+    (shr-colorize-region start (point) fgcolor bgcolor)))
 
 (defun shr-tag-p (cont)
   (shr-ensure-paragraph)
@@ -669,10 +690,11 @@ text will be inserted at start."
 
 (defun shr-tag-a (cont)
   (let ((url (cdr (assq :href cont)))
+        (title (cdr (assq :title cont)))
         (start (point))
         shr-start)
     (shr-generic cont)
-    (shr-urlify (or shr-start start) url)))
+    (shr-urlify (or shr-start start) url title)))
 
 (defun shr-tag-object (cont)
   (let ((start (point))
@@ -818,7 +840,7 @@ text will be inserted at start."
   (let ((start (point))
         (color (cdr (assq :color cont))))
     (shr-generic cont)
-    (shr-insert-foreground-overlay color start (point))))
+    (shr-colorize-region start (point) color)))
 
 ;;; Table rendering algorithm.
 
@@ -870,7 +892,6 @@ text will be inserted at start."
          (nheader (if header (shr-max-columns header)))
          (nbody (if body (shr-max-columns body)))
          (nfooter (if footer (shr-max-columns footer))))
-    (shr-insert-background-overlay bgcolor (point))
     (shr-tag-table-1
      (nconc
       (if caption `((tr (td ,@caption))))
@@ -1013,48 +1034,44 @@ text will be inserted at start."
     (nreverse trs)))
 
 (defun shr-render-td (cont width fill)
-  (let ((background (shr-get-background (point))))
-    (with-temp-buffer
-      (let ((cache (cdr (assoc (cons width cont) shr-content-cache))))
-        (if cache
-            (insert cache)
-          (shr-insert-background-overlay (or (cdr (assq :bgcolor cont))
-                                             background)
-                                         (point))
-          (let ((shr-width width)
-                (shr-indentation 0))
-            (shr-generic cont))
-          (delete-region
-           (point)
-           (+ (point)
-              (skip-chars-backward " \t\n")))
-          (push (cons (cons width cont) (buffer-string))
-                shr-content-cache)))
-      (goto-char (point-min))
-      (let ((max 0))
-        (while (not (eobp))
-          (end-of-line)
-          (setq max (max max (current-column)))
-          (forward-line 1))
-        (when fill
-          (goto-char (point-min))
-          ;; If the buffer is totally empty, then put a single blank
-          ;; line here.
-          (if (zerop (buffer-size))
-              (insert (make-string width ? ))
-            ;; Otherwise, fill the buffer.
-            (while (not (eobp))
-              (end-of-line)
-              (when (> (- width (current-column)) 0)
-                (insert (make-string (- width (current-column)) ? )))
-              (forward-line 1))))
-        (if fill
-            (list max
-                  (count-lines (point-min) (point-max))
-                  (split-string (buffer-string) "\n")
-                  (shr-collect-overlays))
-          (list max
-                (shr-natural-width)))))))
+  (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
+          (list max
+                (count-lines (point-min) (point-max))
+                (split-string (buffer-string) "\n")
+                (shr-collect-overlays))
+        (list max
+              (shr-natural-width))))))
 
 (defun shr-natural-width ()
   (goto-char (point-min))