Be more liberal when extracting forwards as MIME

[gnus] / lisp / shr.el

diff --git a/lisp/shr.el b/lisp/shr.el
index 969d893..41f1224 100644 (file)
--- a/lisp/shr.el
+++ b/lisp/shr.el
@@ -35,6 +35,7 @@
 
 (defgroup shr nil
   "Simple HTML Renderer"
+  :version "24.1"
   :group 'mail)
 
 (defcustom shr-max-image-proportion 0.9
@@ -128,6 +129,7 @@ cid: URL as the argument.")
 ;; Public functions and commands.
 
 (defun shr-visit-file (file)
+  "Parse FILE as an HTML document, and render it in a new buffer."
   (interactive "fHTML file name: ")
   (pop-to-buffer "*html*")
   (erase-buffer)
@@ -139,12 +141,30 @@ cid: URL as the argument.")
 
 ;;;###autoload
 (defun shr-insert-document (dom)
+  "Render the parsed document DOM into the current buffer.
+DOM should be a parse tree as generated by
+`libxml-parse-html-region' or similar."
   (setq shr-content-cache nil)
-  (let ((shr-state nil)
+  (let ((start (point))
+       (shr-state nil)
        (shr-start nil)
        (shr-base nil)
        (shr-width (or shr-width (window-width))))
-    (shr-descend (shr-transform-dom dom))))
+    (shr-descend (shr-transform-dom dom))
+    (shr-remove-trailing-whitespace start (point))))
+
+(defun shr-remove-trailing-whitespace (start end)
+  (let ((width (window-width)))
+    (save-restriction
+      (narrow-to-region start end)
+      (goto-char start)
+      (while (not (eobp))
+       (end-of-line)
+       (when (> (shr-previous-newline-padding-width (current-column)) width)
+         (dolist (overlay (overlays-at (point)))
+           (when (overlay-get overlay 'before-string)
+             (overlay-put overlay 'before-string nil))))
+       (forward-line 1)))))
 
 (defun shr-copy-url ()
   "Copy the URL under point to the kill ring.
@@ -169,7 +189,8 @@ redirects somewhere else."
             (when (re-search-forward ".utm_.*" nil t)
               (replace-match "" t t))
             (message "Copied %s" (buffer-string))
-            (copy-region-as-kill (point-min) (point-max)))))))
+            (copy-region-as-kill (point-min) (point-max)))))
+       nil t))
      ;; Copy the URL to the kill ring.
      (t
       (with-temp-buffer
@@ -212,7 +233,7 @@ the URL of the image to the kill buffer instead."
       (message "Inserting %s..." url)
       (url-retrieve url 'shr-image-fetched
                    (list (current-buffer) (1- (point)) (point-marker))
-                   t))))
+                   t t))))
 
 ;;; Utility functions.
 
@@ -480,7 +501,7 @@ the URL of the image to the kill buffer instead."
      ((not url)
       (message "No link under point"))
      ((string-match "^mailto:" url)
-      (browse-url-mailto url))
+      (browse-url-mail url))
      (t
       (browse-url url)))))
 
@@ -491,7 +512,8 @@ the URL of the image to the kill buffer instead."
     (if (not url)
        (message "No link under point")
       (url-retrieve (shr-encode-url url)
-                   'shr-store-contents (list url directory)))))
+                   'shr-store-contents (list url directory)
+                   nil t))))
 
 (defun shr-store-contents (status url directory)
   (unless (plist-get status :error)
@@ -502,20 +524,21 @@ the URL of the image to the kill buffer instead."
                                      directory)))))
 
 (defun shr-image-fetched (status buffer start end)
-  (when (and (buffer-name buffer)
-            (not (plist-get status :error)))
-    (url-store-in-cache (current-buffer))
-    (when (or (search-forward "\n\n" nil t)
-             (search-forward "\r\n\r\n" nil t))
-      (let ((data (buffer-substring (point) (point-max))))
-        (with-current-buffer buffer
-         (save-excursion
-           (let ((alt (buffer-substring start end))
-                 (inhibit-read-only t))
-             (delete-region start end)
-             (goto-char start)
-             (funcall shr-put-image-function data alt)))))))
-  (kill-buffer (current-buffer)))
+  (let ((image-buffer (current-buffer)))
+    (when (and (buffer-name buffer)
+              (not (plist-get status :error)))
+      (url-store-in-cache image-buffer)
+      (when (or (search-forward "\n\n" nil t)
+               (search-forward "\r\n\r\n" nil t))
+       (let ((data (buffer-substring (point) (point-max))))
+         (with-current-buffer buffer
+           (save-excursion
+             (let ((alt (buffer-substring start end))
+                   (inhibit-read-only t))
+               (delete-region start end)
+               (goto-char start)
+               (funcall shr-put-image-function data alt)))))))
+    (kill-buffer image-buffer)))
 
 (defun shr-put-image (data alt)
   "Put image DATA with a string ALT.  Return image."
@@ -566,7 +589,7 @@ the URL of the image to the kill buffer instead."
 ;; url-cache-extract autoloads url-cache.
 (declare-function url-cache-create-filename "url-cache" (url))
 (autoload 'mm-disable-multibyte "mm-util")
-(autoload 'browse-url-mailto "browse-url")
+(autoload 'browse-url-mail "browse-url")
 
 (defun shr-get-image-data (url)
   "Get image data for URL.
@@ -598,7 +621,7 @@ START, and END.  Note that START and END should be markers."
                   (delete-region (point) end))))
         (url-retrieve url 'shr-image-fetched
                       (list (current-buffer) start end)
-                      t)))))
+                      t t)))))
 
 (defun shr-heading (cont &rest types)
   (shr-ensure-paragraph)
@@ -908,13 +931,10 @@ ones, in case fg and bg are nil."
            (let ((file (url-cache-create-filename (shr-encode-url url))))
              (when (file-exists-p file)
                (delete-file file))))
-         (funcall
-          (if (fboundp 'url-queue-retrieve)
-              'url-queue-retrieve
-            'url-retrieve)
+         (url-queue-retrieve
           (shr-encode-url url) 'shr-image-fetched
           (list (current-buffer) start (set-marker (make-marker) (1- (point))))
-          t)))
+          t t)))
        (when (zerop shr-table-depth) ;; We are not in a table.
          (put-text-property start (point) 'keymap shr-map)
          (put-text-property start (point) 'shr-alt alt)
@@ -1344,10 +1364,10 @@ ones, in case fg and bg are nil."
            (when (memq (car column) '(td th))
              (let ((width (cdr (assq :width (cdr column)))))
                (when (and width
-                          (string-match "\\([0-9]+\\)%" width))
-                 (aset columns i
-                       (/ (string-to-number (match-string 1 width))
-                          100.0))))
+                          (string-match "\\([0-9]+\\)%" width)
+                          (not (zerop (setq width (string-to-number
+                                                   (match-string 1 width))))))
+                 (aset columns i (/ width 100.0))))
              (setq i (1+ i)))))))
     columns))