X-Git-Url: http://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fmml.el;h=575447585975d41e7a3cdfbdca161e953d6944bf;hp=cf902574bf6739b7d426e8fedf6c3447c9036095;hb=829fe7e073a13eaf991e04e90b1e731b1ccce0c2;hpb=37159f7bfe7bc12dc4ca3966e2a7525be82a60c9

diff --git a/lisp/mml.el b/lisp/mml.el
index cf902574b..575447585 100644
--- a/lisp/mml.el
+++ b/lisp/mml.el
@@ -1,6 +1,6 @@
 ;;; mml.el --- A package for parsing and validating MML documents
 
-;; Copyright (C) 1998-2014 Free Software Foundation, Inc.
+;; Copyright (C) 1998-2015 Free Software Foundation, Inc.
 
 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
 ;; This file is part of GNU Emacs.
@@ -28,6 +28,7 @@
 (require 'mm-decode)
 (require 'mml-sec)
 (eval-when-compile (require 'cl))
+(eval-when-compile (require 'url))
 (eval-when-compile
   (when (featurep 'xemacs)
     (require 'easy-mmode))) ; for `define-minor-mode'
@@ -256,7 +257,9 @@ part.  This is for the internal use, you should never modify the value.")
 		((string= mode "encrypt")
 		 (setq tags (list "encrypt" method)))
 		((string= mode "signencrypt")
-		 (setq tags (list "sign" method "encrypt" method))))
+		 (setq tags (list "sign" method "encrypt" method)))
+		(t
+		 (error "Unknown secure mode %s" mode)))
 	  (eval `(mml-insert-tag ,secure-mode
 				 ,@tags
 				 ,(if keyfile "keyfile")
@@ -459,6 +462,9 @@ If MML is non-nil, return the buffer up till the correspondent mml tag."
 (defvar mml-multipart-number 0)
 (defvar mml-inhibit-compute-boundary nil)
 
+(declare-function libxml-parse-html-region "xml.c"
+		  (start end &optional base-url discard-comments))
+
 (defun mml-generate-mime (&optional multipart-type)
   "Generate a MIME message based on the current MML document.
 MULTIPART-TYPE defaults to \"mixed\", but can also
@@ -468,19 +474,69 @@ be \"related\" or \"alternate\"."
 	(options message-options))
     (if (not cont)
 	nil
+      (when (and (consp (car cont))
+		 (= (length cont) 1)
+		 (fboundp 'libxml-parse-html-region)
+		 (equal (cdr (assq 'type (car cont))) "text/html"))
+	(setq cont (mml-expand-html-into-multipart-related (car cont))))
       (prog1
 	  (mm-with-multibyte-buffer
 	    (setq message-options options)
-	    (if (and (consp (car cont))
-		     (= (length cont) 1))
-		(mml-generate-mime-1 (car cont))
+	    (cond
+	     ((and (consp (car cont))
+		   (= (length cont) 1))
+	      (mml-generate-mime-1 (car cont)))
+	     ((eq (car cont) 'multipart)
+	      (mml-generate-mime-1 cont))
+	     (t
 	      (mml-generate-mime-1
 	       (nconc (list 'multipart (cons 'type (or multipart-type "mixed")))
-		      cont)))
+		      cont))))
 	    (setq options message-options)
 	    (buffer-string))
 	(setq message-options options)))))
 
+(defun mml-expand-html-into-multipart-related (cont)
+  (let ((new-parts nil)
+	(cid 1))
+    (mm-with-multibyte-buffer
+      (insert (cdr (assq 'contents cont)))
+      (goto-char (point-min))
+      (with-syntax-table mml-syntax-table
+	(while (re-search-forward "<img\\b" nil t)
+	  (goto-char (match-beginning 0))
+	  (let* ((start (point))
+		 (img (nth 2
+			   (nth 2
+				(libxml-parse-html-region
+				 (point) (progn (forward-sexp) (point))))))
+		 (end (point))
+		 (parsed (url-generic-parse-url (cdr (assq 'src (cadr img))))))
+	    (when (and (null (url-type parsed))
+		       (url-filename parsed)
+		       (file-exists-p (url-filename parsed)))
+	      (goto-char start)
+	      (when (search-forward (url-filename parsed) end t)
+		(let ((cid (format "fsf.%d" cid)))
+		  (replace-match (concat "cid:" cid) t t)
+		  (push (list cid (url-filename parsed)) new-parts))
+		(setq cid (1+ cid)))))))
+      ;; We have local images that we want to include.
+      (if (not new-parts)
+	  (list cont)
+	(setcdr (assq 'contents cont) (buffer-string))
+	(setq cont
+	      (nconc (list 'multipart (cons 'type "related"))
+		     (list cont)))
+	(dolist (new-part (nreverse new-parts))
+	  (setq cont
+		(nconc cont
+		       (list `(part (type . "image/png")
+				    (filename . ,(nth 1 new-part))
+				    (id . ,(concat "<" (nth 0 new-part)
+						   ">")))))))
+	cont))))
+
 (defun mml-generate-mime-1 (cont)
   (let ((mm-use-ultra-safe-encoding
 	 (or mm-use-ultra-safe-encoding (assq 'sign cont))))