From 99648d27eedbdead431411bfa31edd18c4ad5db4 Mon Sep 17 00:00:00 2001
From: Lars Ingebrigtsen <larsi@gnus.org>
Date: Thu, 6 Mar 2014 19:17:09 +0100
Subject: [PATCH] HTML + multipart/related support

* mml.el (mml-expand-html-into-multipart-related): Allow sending HTML
messages with embedded images.
---
 lisp/ChangeLog  |  9 +++++++
 lisp/message.el | 12 ++++++++++
 lisp/mml.el     | 62 ++++++++++++++++++++++++++++++++++++++++++-------
 3 files changed, 75 insertions(+), 8 deletions(-)

diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index 1aa1e9649..ffaa2da42 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,3 +1,12 @@
+2014-03-06  Lars Ingebrigtsen  <larsi@gnus.org>
+
+	* mml.el (mml-expand-html-into-multipart-related): Allow sending HTML
+	messages with embedded images.
+
+2014-03-06  Lars Ingebrigtsen  <larsi@gnus.org>
+
+	* message.el (message-make-html-message-with-image-files): New command.
+
 2014-03-05  Lars Ingebrigtsen  <larsi@gnus.org>
 
 	* gnus-group.el (gnus-group-make-group): Clarify prompt.
diff --git a/lisp/message.el b/lisp/message.el
index 0110f8b3f..32cfe3b9a 100644
--- a/lisp/message.el
+++ b/lisp/message.el
@@ -47,6 +47,7 @@
 (require 'mml)
 (require 'rfc822)
 (require 'format-spec)
+(require 'dired)
 
 (autoload 'mailclient-send-it "mailclient") ;; Emacs 22 or contrib/
 
@@ -8485,6 +8486,17 @@ Used in `message-simplify-recipients'."
 	 (message-fetch-field hdr) t))
       ", "))))
 
+;;; multipart/related and HTML support.
+
+(defun message-make-html-message-with-image-files (files)
+  (interactive (list (dired-get-marked-files nil current-prefix-arg)))
+  (message-mail)
+  (message-goto-body)
+  (insert "<#part type=text/html>\n\n")
+  (dolist (file files)
+    (insert (format "<img src=%S>\n\n" file)))
+  (message-goto-to))
+
 (when (featurep 'xemacs)
   (require 'messagexmas)
   (message-xmas-redefine))
diff --git a/lisp/mml.el b/lisp/mml.el
index b7e22d4c9..e38cfcf4c 100644
--- a/lisp/mml.el
+++ b/lisp/mml.el
@@ -468,19 +468,68 @@ be \"related\" or \"alternate\"."
 	(options message-options))
     (if (not cont)
 	nil
+      (when (and (consp (car cont))
+		 (= (length cont) 1)
+		 (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))))
@@ -804,10 +853,7 @@ be \"related\" or \"alternate\"."
 	      parameters)
       (insert "Content-Disposition: "
 	      (or disposition
-		  (mml-content-disposition
-		   type
-		   (or (cdr (assq 'recipient-filename cont))
-		       (cdr (assq 'filename cont))))))
+		  (mml-content-disposition type (cdr (assq 'filename cont)))))
       (when parameters
 	(mml-insert-parameter-string
 	 cont mml-content-disposition-parameters))
-- 
2.25.1