diff options
Diffstat (limited to 'lisp/gnus')
| -rw-r--r-- | lisp/gnus/message.el | 32 | ||||
| -rw-r--r-- | lisp/gnus/mml.el | 61 |
2 files changed, 68 insertions, 25 deletions
diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el index 1ca7c5cafef..03ce789e9eb 100644 --- a/lisp/gnus/message.el +++ b/lisp/gnus/message.el @@ -4545,7 +4545,7 @@ This function could be useful in `message-setup-hook'." (setq message-options options) ;; Avoid copying text props (except hard newlines). (insert (with-current-buffer mailbuf - (mml-buffer-substring-no-properties-except-hard-newlines + (mml-buffer-substring-no-properties-except-some (point-min) (point-max)))) ;; Remove some headers. (message-encode-message-body) @@ -4909,7 +4909,7 @@ Otherwise, generate and save a value for `canlock-password' first." ;; Avoid copying text props (except hard newlines). (insert (with-current-buffer messbuf - (mml-buffer-substring-no-properties-except-hard-newlines + (mml-buffer-substring-no-properties-except-some (point-min) (point-max)))) (message-encode-message-body) ;; Remove some headers. @@ -8386,30 +8386,32 @@ Used in `message-simplify-recipients'." (defun message-toggle-image-thumbnails () "For any included image files, insert a thumbnail of that image." (interactive) - (let ((overlays (overlays-in (point-min) (point-max))) - (displayed nil)) - (while overlays - (let ((overlay (car overlays))) - (when (overlay-get overlay 'put-image) - (delete-overlay overlay) - (setq displayed t))) - (setq overlays (cdr overlays))) + (let ((displayed nil)) + (save-excursion + (goto-char (point-min)) + (while (not (eobp)) + (when-let ((props (get-text-property (point) 'display))) + (when (and (consp props) + (eq (car props) 'image)) + (put-text-property (point) (1+ (point)) 'display nil) + (setq displayed t))))) (unless displayed (save-excursion (goto-char (point-min)) - (while (re-search-forward "<img.*src=\"\\([^\"]+\\)" nil t) - (let ((file (match-string 1)) + (while (re-search-forward "<img.*src=\"\\([^\"]+\\).*>" nil t) + (let ((string (match-string 0)) + (file (match-string 1)) (edges (window-inside-pixel-edges (get-buffer-window (current-buffer))))) - (put-image + (delete-region (match-beginning 0) (match-end 0)) + (insert-image (create-image file 'imagemagick nil :max-width (truncate (* 0.7 (- (nth 2 edges) (nth 0 edges)))) :max-height (truncate (* 0.5 (- (nth 3 edges) (nth 1 edges))))) - (match-beginning 0) - " "))))))) + string))))))) (provide 'message) diff --git a/lisp/gnus/mml.el b/lisp/gnus/mml.el index 97cc87d06e3..eae4c61be82 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)))) |