[gnus git] branch master updated: m0-11-204-g8b99fee =1= gnus-art.el (gnus-article-browse-html-parts): Make external links absolute and cid file names relative

       via  8b99fee94f42fe0418a468821b1258f5419207a5 (commit)
      from  73bbdb9f9f8094f3d61922d953d15971cd529f29 (commit)


- Log -----------------------------------------------------------------
commit 8b99fee94f42fe0418a468821b1258f5419207a5
Author: Katsumi Yamaoka <[email protected]>
Date:   Fri Apr 3 03:17:27 2015 +0000

    gnus-art.el (gnus-article-browse-html-parts): Make external links absolute and cid file names relative

diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index 5c120b2..966ff9f 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,3 +1,10 @@
+2015-04-03  Katsumi Yamaoka  <[email protected]>
+
+	* 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  <[email protected]>
 
 	* registry.el (registry-prune): Re-use `registry-full' in
diff --git a/lisp/gnus-art.el b/lisp/gnus-art.el
index 1362f1d..daae98c 100644
--- a/lisp/gnus-art.el
+++ b/lisp/gnus-art.el
@@ -51,6 +51,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."
@@ -2793,10 +2794,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
@@ -2808,7 +2808,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)
@@ -2818,11 +2818,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
+	    (throw 'found (concat (file-name-nondirectory
 				   (directory-file-name directory))
-				    "/" file))))))))))
+				  "/" file)))))))))
 
 (defun gnus-article-browse-html-parts (list &optional header)
   "View all \"text/html\" parts from LIST.
@@ -2858,13 +2856,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)
@@ -2878,18 +2895,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))

-----------------------------------------------------------------------
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we listed those
revisions in full, above.

Summary of changes:
 lisp/ChangeLog   |    7 +++++++
 lisp/gnus-art.el |   60 ++++++++++++++++++++++++++++++------------------------
 2 files changed, 40 insertions(+), 27 deletions(-)

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "Gnus Project".

The branch, master has been updated


hooks/post-receive
-- 
Gnus Project