lisp/gnus/gnus-art.el (gnus-article-browse-html-parts): Make external links absolute...

diff --git a/lisp/gnus/ChangeLog b/lisp/gnus/ChangeLog
index 95ead23cb51fe2a7bd0ed6a758d7db4743293f14..14734e3e40dbd9dc5891459b0ff39b8ef03de7fa 100644 (file)
--- a/lisp/gnus/ChangeLog
+++ b/lisp/gnus/ChangeLog
@@ -1,3 +1,10 @@
+2015-04-03  Katsumi Yamaoka  <yamaoka@jpl.org>
+
+       * gnus-art.el (gnus-article-browse-html-save-cid-content):
+       Always return relative file name.
+       (gnus-article-browse-html-parts):
+       Make external links absolute and cid file names relative.
+
 2015-04-01  Eric Abrahamsen  <eric@ericabrahamsen.net>
 
        * registry.el (registry-prune): Re-use `registry-full' in

diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el
index 19da2cce42f3dba17cc04287aa875149ed58d0c4..5ec1268aee7941cd3960a5d314c264593566de03 100644 (file)
--- a/lisp/gnus/gnus-art.el
+++ b/lisp/gnus/gnus-art.el
@@ -50,6 +50,7 @@
 (autoload 'ansi-color-apply-on-region "ansi-color")
 (autoload 'mm-url-insert-file-contents-external "mm-url")
 (autoload 'mm-extern-cache-contents "mm-extern")
+(autoload 'url-expand-file-name "url-expand")
 
 (defgroup gnus-article nil
   "Article display."
@@ -2792,10 +2793,9 @@ summary buffer."
     (setq gnus-article-browse-html-temp-list nil))
   gnus-article-browse-html-temp-list)
 
-(defun gnus-article-browse-html-save-cid-content (cid handles directory abs)
+(defun gnus-article-browse-html-save-cid-content (cid handles directory)
   "Find CID content in HANDLES and save it in a file in DIRECTORY.
-Return absolute file name if ABS is non-nil, otherwise relative to
-the parent of DIRECTORY."
+Return file name relative to the parent of DIRECTORY."
   (save-match-data
     (let (file afile)
       (catch 'found
@@ -2807,7 +2807,7 @@ the parent of DIRECTORY."
           ((not (or (bufferp (car handle)) (stringp (car handle)))))
           ((equal (mm-handle-media-supertype handle) "multipart")
            (when (setq file (gnus-article-browse-html-save-cid-content
-                             cid handle directory abs))
+                             cid handle directory))
              (throw 'found file)))
           ((equal (concat "<" cid ">") (mm-handle-id handle))
            (setq file (or (mm-handle-filename handle)
@@ -2817,11 +2817,9 @@ the parent of DIRECTORY."
                                         mailcap-mime-extensions))))
                  afile (expand-file-name file directory))
            (mm-save-part-to-file handle afile)
-           (throw 'found (if abs
-                             afile
-                           (concat (file-name-nondirectory
-                                    (directory-file-name directory))
-                                   "/" file))))))))))
+           (throw 'found (concat (file-name-nondirectory
+                                  (directory-file-name directory))
+                                 "/" file)))))))))
 
 (defun gnus-article-browse-html-parts (list &optional header)
   "View all \"text/html\" parts from LIST.
@@ -2857,13 +2855,32 @@ message header will be added to the bodies of the \"text/html\" parts."
               (insert content)
               ;; resolve cid contents
               (let ((case-fold-search t)
-                    abs st cid-file)
+                    st base regexp cid-file)
                 (goto-char (point-min))
-                (when (re-search-forward "<head[\t\n >]" nil t)
-                  (setq st (match-end 0)
-                        abs (or
-                             (not (re-search-forward "</head[\t\n >]" nil t))
-                             (re-search-backward "<base[\t\n >]" st t))))
+                (when (and (re-search-forward "<head[\t\n >]" nil t)
+                           (progn
+                             (setq st (match-end 0))
+                             (re-search-forward "</head[\t\n >]" nil t))
+                           (re-search-backward "<base\
+\\(?:[\t\n ]+[^\t\n >]+\\)*[\t\n ]+href=\"\\([^\"]+\\)\"[^>]*>" st t))
+                  (setq base (match-string 1))
+                  (replace-match "<!--\\&-->")
+                  (setq st (point))
+                  (dolist (tag '(("a" . "href") ("form" . "action")
+                                 ("img" . "src")))
+                    (setq regexp (concat "<" (car tag)
+                                         "\\(?:[\t\n ]+[^\t\n >]+\\)*[\t\n ]+"
+                                         (cdr tag) "=\"\\([^\"]+\\)"))
+                    (while (re-search-forward regexp nil t)
+                      (insert (prog1
+                                  (condition-case nil
+                                      (save-match-data
+                                        (url-expand-file-name (match-string 1)
+                                                              base))
+                                    (error (match-string 1)))
+                                (delete-region (match-beginning 1)
+                                               (match-end 1)))))
+                    (goto-char st)))
                 (while (re-search-forward "\
 <img[\t\n ]+\\(?:[^\t\n >]+[\t\n ]+\\)*src=\"\\(cid:\\([^\"]+\\)\\)\""
                                           nil t)
@@ -2877,18 +2894,7 @@ message header will be added to the bodies of the \"text/html\" parts."
                                (match-string 2)
                                (with-current-buffer gnus-article-buffer
                                  gnus-article-mime-handles)
-                               cid-dir abs))
-                    (when abs
-                      (setq cid-file
-                            (if (eq system-type 'cygwin)
-                                (concat "file:///"
-                                        (substring
-                                         (with-output-to-string
-                                           (call-process "cygpath" nil
-                                                         standard-output
-                                                         nil "-m" cid-file))
-                                         0 -1))
-                              (concat "file://" cid-file))))
+                               cid-dir))
                     (replace-match cid-file nil nil nil 1))))
               (unless content (setq content (buffer-string))))
             (when (or charset header (not file))