(defcustom mml-content-type-parameters
'(name access-type expiration size permission format)
- "*A list of acceptable parameters in MML tag.
+ "A list of acceptable parameters in MML tag.
These parameters are generated in Content-Type header if exists."
:version "22.1"
:type '(repeat (symbol :tag "Parameter"))
(defcustom mml-content-disposition-parameters
'(filename creation-date modification-date read-date)
- "*A list of acceptable parameters in MML tag.
+ "A list of acceptable parameters in MML tag.
These parameters are generated in Content-Disposition header if exists."
:version "22.1"
:type '(repeat (symbol :tag "Parameter"))
(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))
(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)
(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)
(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))))
(let ((mm-coding-system-priorities
(cons 'utf-8 mm-coding-system-priorities)))
(setq charset (mm-encode-body))))
+ (mm-disable-multibyte)
(setq encoding (mm-body-encoding
charset (cdr (assq 'encoding cont))))))
(setq coded (buffer-string)))
(if (setq encoding (cdr (assq 'encoding cont)))
(setq encoding (intern (downcase encoding))))
(setq encoding (mm-encode-buffer type encoding)
- coded (mm-string-as-multibyte (buffer-string))))
+ coded (string-as-multibyte (buffer-string))))
(mml-insert-mime-headers cont type charset encoding nil)
(insert "\n" coded))))
((eq (car cont) 'external)
(message-sort-headers)
(mml-to-mime))
(if raw
- (when (fboundp 'set-buffer-multibyte)
- (let ((s (buffer-string)))
- ;; Insert the content into unibyte buffer.
- (erase-buffer)
- (mm-disable-multibyte)
- (insert s)))
+ (let ((s (buffer-string)))
+ ;; Insert the content into unibyte buffer.
+ (erase-buffer)
+ (mm-disable-multibyte)
+ (insert s))
(let ((gnus-newsgroup-charset (car message-posting-charset))
gnus-article-prepare-hook gnus-original-article-buffer
gnus-displaying-mime)