From: Lars Ingebrigtsen <larsi@gnus.org>
Date: Wed, 5 Aug 2020 10:21:35 +0000 (+0200)
Subject: Implement a screenshot command for Message mode
X-Git-Tag: emacs-28.0.90~6810
X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=a06f41ad2ca786a70940297fd832a649196be9be;p=emacs.git

Implement a screenshot command for Message mode

* doc/misc/message.texi (MIME): Document it.

* lisp/gnus/message.el (message-screenshot-command): New variable.
(message-mode-map): New keystroke and menu item.  Also add
mml-attach-file to the menu.
(message-insert-screenshot): New command.

* lisp/gnus/mml.el (mml-parse-1): Allow having
content-transfer-encoding already in the part, so that we can have
inline base64-encoded binaries in the Message buffers.
---

diff --git a/doc/misc/message.texi b/doc/misc/message.texi
index bdd31b1fe49..7a66422b17e 100644
--- a/doc/misc/message.texi
+++ b/doc/misc/message.texi
@@ -883,6 +883,18 @@ is a list, valid members are @code{type}, @code{description} and
 @code{nil}, don't ask for options.  If it is @code{t}, ask the user
 whether or not to specify options.
 
+@vindex message-screenshot-command
+@findex message-insert-screenshot
+@cindex screenshots
+@kindex C-c C-p
+If your system supports it, you can also insert screenshots directly
+into the Message buffer.  The @kbd{C-c C-p}
+(@code{message-insert-screenshot}) command inserts the image into the
+buffer as an @acronym{MML} part, and puts an image text property on
+top.  The @code{message-screenshot-command} variable says what
+external command to use to take the screenshot.  It defaults to
+@code{"import png:-"}, which is an ImageMagick command.
+
 You can also create arbitrarily complex multiparts using the @acronym{MML}
 language (@pxref{Composing, , Composing, emacs-mime, The Emacs MIME
 Manual}).
diff --git a/etc/NEWS b/etc/NEWS
index 670e97f52cb..8c6e3e78139 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -228,6 +228,14 @@ The names of the commands 'gnus-slave', 'gnus-slave-no-server' and
 *** The 'W Q' summary mode command now takes a numerical prefix to
 allow adjusting the fill width.
 
++++
+*** New variable 'mm-inline-font-lock'.
+This variable is supposed to be bound by callers to determine whether
+inline MIME parts (that support it) are supposed to be font-locked or
+not.
+
+** Message
+
 ---
 *** Change to default value of 'message-draft-headers' user option.
 The 'Date' symbol has been removed from the default value, meaning that
@@ -237,10 +245,10 @@ from when it is first saved or delayed, add the symbol 'Date' back to
 this user option.
 
 +++
-*** New variable 'mm-inline-font-lock'.
-This variable is supposed to be bound by callers to determine whether
-inline MIME parts (that support it) are supposed to be font-locked or
-not.
+*** New command to take screenshots.
+In Message mode buffers, the 'C-c C-p' ('message-insert-screenshot')
+command has been added.  It depends on using an external program to
+take the actual screenshot, and defaults to ImageMagick "import".
 
 ** Help
 
diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el
index fb560f0eab8..1453cbe643e 100644
--- a/lisp/gnus/message.el
+++ b/lisp/gnus/message.el
@@ -303,6 +303,13 @@ any confusion."
   :link '(custom-manual "(message)Message Headers")
   :type 'regexp)
 
+(defcustom message-screenshot-command '("import" "png:-")
+  "Command to take a screenshot.
+The command should insert a PNG in the current buffer."
+  :group 'message-various
+  :type '(list string)
+  :version "28.1")
+
 ;;; Start of variables adopted from `message-utils.el'.
 
 (defcustom message-subject-trailing-was-query t
@@ -2810,6 +2817,7 @@ systematically send encrypted emails when possible."
   (define-key message-mode-map [remap split-line]  'message-split-line)
 
   (define-key message-mode-map "\C-c\C-a" 'mml-attach-file)
+  (define-key message-mode-map "\C-c\C-p" 'message-insert-screenshot)
 
   (define-key message-mode-map "\C-a" 'message-beginning-of-line)
   (define-key message-mode-map "\t" 'message-tab)
@@ -2839,6 +2847,8 @@ systematically send encrypted emails when possible."
      :active (message-mark-active-p) :help "Mark region with enclosing tags"]
     ["Insert File Marked..." message-mark-insert-file
      :help "Insert file at point marked with enclosing tags"]
+    ["Attach File..." mml-attach-file t]
+    ["Insert Screenshot" message-insert-screenshot t]
     "----"
     ["Send Message" message-send-and-exit :help "Send this message"]
     ["Postpone Message" message-dont-send
@@ -8652,6 +8662,49 @@ Used in `message-simplify-recipients'."
 			   (* 0.5 (- (nth 3 edges) (nth 1 edges)))))
 	     string)))))))
 
+(defun message-insert-screenshot (delay)
+  "Take a screenshot and insert in the current buffer.
+DELAY (the numeric prefix) says how many seconds to wait before
+starting the screenshotting process.
+
+The `message-screenshot-command' variable says what command is
+used to take the screenshot."
+  (interactive "p")
+  (unless (executable-find (car message-screenshot-command))
+    (error "Can't find %s to take the screenshot"
+	   (car message-screenshot-command)))
+  (cl-decf delay)
+  (unless (zerop delay)
+    (dotimes (i delay)
+      (message "Sleeping %d second%s..."
+	       (- delay i)
+	       (if (= (- delay i) 1)
+		   ""
+		 "s"))
+      (sleep-for 1)))
+  (message "Take screenshot")
+  (let ((image
+	 (with-temp-buffer
+	   (set-buffer-multibyte nil)
+	   (apply #'call-process
+		  (car message-screenshot-command) nil (current-buffer) nil
+		  (cdr message-screenshot-command))
+	   (buffer-string))))
+    (set-mark (point))
+    (insert-image
+     (create-image image 'png t
+		   :max-width (* (frame-pixel-width) 0.8)
+		   :max-height (* (frame-pixel-height) 0.8))
+     (format "<#part type=\"image/png\" disposition=inline content-transfer-encoding=base64 raw=t>\n%s\n<#/part>"
+	     ;; Get a base64 version of the image.
+	     (with-temp-buffer
+	       (set-buffer-multibyte nil)
+	       (insert image)
+	       (base64-encode-region (point-min) (point-max) t)
+	       (buffer-string))))
+    (insert "\n\n")
+    (message "")))
+
 (provide 'message)
 
 (run-hooks 'message-load-hook)
diff --git a/lisp/gnus/mml.el b/lisp/gnus/mml.el
index 21491499eb8..1d348f3a6f0 100644
--- a/lisp/gnus/mml.el
+++ b/lisp/gnus/mml.el
@@ -295,6 +295,17 @@ part.  This is for the internal use, you should never modify the value.")
 			(t
 			 (mm-find-mime-charset-region point (point)
 						      mm-hack-charsets))))
+	;; We have a part that already has a transfer encoding.  Undo
+	;; that so that we don't double-encode later.
+	(when (and raw
+		   (cdr (assq 'content-transfer-encoding tag)))
+	  (with-temp-buffer
+	    (set-buffer-multibyte nil)
+	    (insert contents)
+	    (mm-decode-content-transfer-encoding
+	     (intern (cdr (assq 'content-transfer-encoding tag)))
+	     (cdr (assq 'type tag)))
+	    (setq contents (buffer-string))))
 	(when (and (not raw) (memq nil charsets))
 	  (if (or (memq 'unknown-encoding mml-confirmation-set)
 		  (message-options-get 'unknown-encoding)
@@ -313,8 +324,8 @@ Message contains characters with unknown encoding.  Really send? ")
 		(eq 'mml (car tag))
 		(< (length charsets) 2))
 	    (if (or (not no-markup-p)
+		    ;; Don't create blank parts.
 		    (string-match "[^ \t\r\n]" contents))
-		;; Don't create blank parts.
 		(push (nconc tag (list (cons 'contents contents)))
 		      struct))
 	  (let ((nstruct (mml-parse-singlepart-with-multiple-charsets