procyberian/emacs
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

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

Browse source
This commit is contained in:
Katsumi Yamaoka 2015-04-03 03:18:52 +00:00
parent 0c2ea36d20
commit 839decd9ec
2 changed files with 40 additions and 27 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

7
lisp/gnus/ChangeLog
View file

@ -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

60
lisp/gnus/gnus-art.el
View file

@ -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))