HTML + multipart/related support

* mml.el (mml-expand-html-into-multipart-related): Allow sending HTML
messages with embedded images.

diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index 1aa1e96..ffaa2da 100644 (file)
--- 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 0110f8b..32cfe3b 100644 (file)
--- 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 b7e22d4..e38cfcf 100644 (file)
--- 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))