[Emacs-diffs] master b7735ab 2/2: Allow preserving EXIF rotations when sending HTML messages

[Lars Ingebrigtsen]

branch: master
commit b7735ab0419de3eb16560bdbab01edadecfc353e
Author: Lars Ingebrigtsen <address@hidden>
Commit: Lars Ingebrigtsen <address@hidden>

    Allow preserving EXIF rotations when sending HTML messages
    
    * lisp/gnus/mml.el (mml--possibly-alter-image): Allow image
    rotation if you have exiftool installed and the image format
    supports it.
    (mml-expand-html-into-multipart-related): Use it.
    (mml-buffer-substring-no-properties-except-some): Renamed and
    copy display properties, too.
---
 etc/NEWS         |    7 +++++++
 lisp/gnus/mml.el |   61 +++++++++++++++++++++++++++++++++++++++++++++---------
 2 files changed, 58 insertions(+), 10 deletions(-)

diff --git a/etc/NEWS b/etc/NEWS
index b2e42e3..185b1a4 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -276,6 +276,13 @@ for the ChangeLog file, if none already exists.  Customize
 built-in IDNA support now).
 
 ---
+*** When sending HTML messages with embedded images, and you have
+exiftool installed, and you rotate images with EXIF data (i.e.,
+JPEGs), the rotational information will be inserted into the outgoing
+image in the message.  (The original image will not have its
+orientation affected.)
+
+---
 *** The 'message-valid-fqdn-regexp' variable has been removed, since
 there are now top-level domains added all the time.  Message will no
 longer warn about sending emails to top-level domains it hasn't heard
diff --git a/lisp/gnus/mml.el b/lisp/gnus/mml.el
index 97cc87d..eae4c61 100644
--- a/lisp/gnus/mml.el
+++ b/lisp/gnus/mml.el
@@ -413,12 +413,21 @@ A message part needs to be split into %d charset parts.  
Really send? "
     (setq contents (append (list (cons 'tag-location orig-point)) contents))
     (cons (intern name) (nreverse contents))))
 
-(defun mml-buffer-substring-no-properties-except-hard-newlines (start end)
+(defun mml-buffer-substring-no-properties-except-some (start end)
   (let ((str (buffer-substring-no-properties start end))
-       (bufstart start) tmp)
-    (while (setq tmp (text-property-any start end 'hard 't))
-      (set-text-properties (- tmp bufstart) (- tmp bufstart -1)
-                          '(hard t) str)
+       (bufstart start)
+       tmp)
+    ;; Copy over all hard newlines.
+    (while (setq tmp (text-property-any start end 'hard t))
+      (put-text-property (- tmp bufstart) (- tmp bufstart -1)
+                        'hard t str)
+      (setq start (1+ tmp)))
+    ;; Copy over all `display' properties (which are usually images).
+    (setq start bufstart)
+    (while (setq tmp (text-property-not-all start end 'display nil))
+      (put-text-property (- tmp bufstart) (- tmp bufstart -1)
+                        'display (get-text-property tmp 'display)
+                        str)
       (setq start (1+ tmp)))
     str))
 
@@ -435,21 +444,21 @@ If MML is non-nil, return the buffer up till the 
correspondent mml tag."
            (if (re-search-forward "<#\\(/\\)?mml." nil t)
                (setq count (+ count (if (match-beginning 1) -1 1)))
              (goto-char (point-max))))
-         (mml-buffer-substring-no-properties-except-hard-newlines
+         (mml-buffer-substring-no-properties-except-some
           beg (if (> count 0)
                   (point)
                 (match-beginning 0))))
       (if (re-search-forward
           "<#\\(/\\)?\\(multipart\\|part\\|external\\|mml\\)." nil t)
          (prog1
-             (mml-buffer-substring-no-properties-except-hard-newlines
+             (mml-buffer-substring-no-properties-except-some
               beg (match-beginning 0))
            (if (or (not (match-beginning 1))
                    (equal (match-string 2) "multipart"))
                (goto-char (match-beginning 0))
              (when (looking-at "[ \t]*\n")
                (forward-line 1))))
-       (mml-buffer-substring-no-properties-except-hard-newlines
+       (mml-buffer-substring-no-properties-except-some
         beg (goto-char (point-max)))))))
 
 (defvar mml-boundary nil)
@@ -514,7 +523,9 @@ be \"related\" or \"alternate\"."
              (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))
+                 (push (list cid (url-filename parsed)
+                             (get-text-property start 'display))
+                       new-parts))
                (setq cid (1+ cid)))))))
       ;; We have local images that we want to include.
       (if (not new-parts)
@@ -527,11 +538,41 @@ be \"related\" or \"alternate\"."
          (setq cont
                (nconc cont
                       (list `(part (type . "image/png")
-                                   (filename . ,(nth 1 new-part))
+                                   ,@(mml--possibly-alter-image
+                                      (nth 1 new-part)
+                                      (nth 2 new-part))
                                    (id . ,(concat "<" (nth 0 new-part)
                                                   ">")))))))
        cont))))
 
+(defun mml--possibly-alter-image (file-name image)
+  (if (or (null image)
+         (not (consp image))
+         (not (eq (car image) 'image))
+         (not (image-property image :rotation))
+         (not (executable-find "exiftool")))
+      `((filename . ,file-name))
+    `((filename . ,file-name)
+      (buffer
+       .
+       ,(with-current-buffer (mml-generate-new-buffer " *mml rotation*")
+         (set-buffer-multibyte nil)
+         (call-process "exiftool"
+                       file-name
+                       (list (current-buffer) nil)
+                       nil
+                       (format "-Orientation#=%d"
+                               (cl-case (truncate
+                                         (image-property image :rotation))
+                                 (0 0)
+                                 (90 6)
+                                 (180 3)
+                                 (270 8)
+                                 (otherwise 0)))
+                       "-o" "-"
+                       "-")
+         (current-buffer))))))
+
 (defun mml-generate-mime-1 (cont)
   (let ((mm-use-ultra-safe-encoding
         (or mm-use-ultra-safe-encoding (assq 'sign cont))))