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.

10 files changed, 229 insertions, 126 deletions

diff --git a/lisp/gnus/ChangeLog b/lisp/gnus/ChangeLog
index 7d8e954deb..6ca94d1760 100644
--- a/lisp/gnus/ChangeLog
+++ b/lisp/gnus/ChangeLog
@@ -1,3 +1,57 @@
+2010-12-05  Lars Magne Ingebrigtsen  <[email protected]>
+
+	* 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  <[email protected]>
+
+	* nnimap.el (nnimap-process-expiry-targets): Avoid downloading articles
+	unless necessary.
+
+2010-12-05  Andrew Cohen  <[email protected]>
+
+	* nnir.el (nnir-run-gmane): Use more careful test for gmane nntp
+	server.
+
+2010-12-04  Lars Magne Ingebrigtsen  <[email protected]>
+
+	* 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  <[email protected]>
+
+	* shr.el (shr-urlify): Display the title in <a> tags.
+
+2010-12-04  Andrew Cohen  <[email protected]>
+
+	* nnir.el (nnir-categorize): Replace mapcar with mapc.
+
 2010-12-03  Andrew Cohen  <[email protected]>
 
 	* 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 174e128a7e..63a14b204f 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 bcfff34796..767ac2e9fc 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 ba124d5115..2bb39af3fb 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 55d6ce55eb..45fd26c86c 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 d32ecac5dc..b4f7f83618 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 a53f9ac468..4b4793dcfe 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 7e1bd309c9..b706d150f7 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 6504f05c9d..9c9054a49c 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 c07bb34ef8..0b2fa939b1 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))