Make it possible to use Message as a mailto: desktop handler

* doc/misc/message.texi (System Mailer Setup): Document the usage.

* lisp/gnus/gnus-art.el (gnus-url-mailto): Move most of the code
here to 'message-mailto-1' (bug#38314).

* lisp/gnus/message.el (message-parse-mailto-url): Mark as obsolete.
(message-parse-mailto-url): Rewritten slightly from the above.
(message-mailto): New command.
(message-mailto-1): New function.

diff --git a/doc/misc/message.texi b/doc/misc/message.texi
index 7a66422b17e4b6b34bbd6e75f24d461f0f7ce3cf..c9a466eae9f5335cf9f72acf5f896dbff3ff10d3 100644 (file)
--- a/doc/misc/message.texi
+++ b/doc/misc/message.texi
@@ -99,6 +99,7 @@ sending it.
 * Resending::            Resending a mail message.
 * Bouncing::             Bouncing a mail message.
 * Mailing Lists::        Send mail to mailing lists.
+* System Mailer Setup::  Using Message as the system mailer.
 @end menu
 
 You can customize the Message Mode tool bar, see @kbd{M-x
@@ -529,6 +530,29 @@ It is considered good netiquette to honor MFT, as it is assumed the
 fellow who posted a message knows where the followups need to go
 better than you do.
 
+
+@node System Mailer Setup
+@section System Mailer Setup
+@cindex mailto:
+
+Emacs can be set up as the system mailer, so that Emacs is opened when
+you click on @samp{mailto:} links in other programs.
+
+How this is done varies from system to system, but commonly there's a
+way to set the default application for a @acronym{MIME} type, and the
+relevant type here is @samp{x-scheme-handler/mailto;}.
+
+The application to start should be @samp{"emacs -f message-mailto %u"}.
+This will start Emacs, and then run the @code{message-mailto}
+command.  It will parse the given @acronym{URL}, and set up a Message
+buffer with the given parameters.
+
+For instance, @samp{mailto:larsi@@gnus.org;subject=This+is+a+test}
+will open a Message buffer with the @samp{To:} header filled in with
+@samp{"larsi@@gnus.org"} and the @samp{Subject:} header with
+@samp{"This is a test"}.
+
+
 @node Commands
 @chapter Commands
 

diff --git a/etc/NEWS b/etc/NEWS
index cbb1842e139f7fd8fcc1bf6cade09b73d0c824c3..2df7bac9d73ffc04ccbacc03623b02d36ceb5e32 100644 (file)
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -236,6 +236,16 @@ not.
 
 ** Message
 
++++
+*** New function to start Emacs in Message mode to send an email.
+Emacs can be defined as a handler for the "x-scheme-handler/mailto"
+MIME type with the following command: "emacs -f message-mailto %u".
+An emacs-mail.desktop file has been included, suitable for installing
+in desktop directories like /usr/share/applications.  Clicking on a
+mailto: link in other applications will then open Emacs with headers
+filled out according to the link, e.g.
+"mailto:larsi@gnus.org;subject=This+is+a+test".
+
 ---
 *** Change to default value of 'message-draft-headers' user option.
 The 'Date' symbol has been removed from the default value, meaning that

diff --git a/etc/emacs-mail.desktop b/etc/emacs-mail.desktop
new file mode 100644 (file)
index 0000000..dec6cdb
--- /dev/null
+++ b/etc/emacs-mail.desktop
@@ -0,0 +1,20 @@
+Desktop Entry]
+Categories=Network;Email;
+Comment=GNU Emacs is an extensible, customizable text editor - and more
+Exec=/home/larsi/src/emacs/trunk/src/emacs -f message-mailto %u
+Icon=emacs
+Name=Emacs (Mail)
+MimeType=x-scheme-handler/mailto;
+NoDisplay=false
+Terminal=false
+Type=Application
+Desktop Entry]
+Categories=Network;Email;
+Comment=GNU Emacs is an extensible, customizable text editor - and more
+Exec=emacs -f message-mailto %u
+Icon=emacs
+Name=Emacs (Mail)
+MimeType=x-scheme-handler/mailto;
+NoDisplay=false
+Terminal=false
+Type=Application

diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el
index d33539bc7f76caa9a10e35eb6f40524b5c3989f7..1be8c48bcfc7ee0358c9ccb103ed2f2a2c903528 100644 (file)
--- a/lisp/gnus/gnus-art.el
+++ b/lisp/gnus/gnus-art.el
@@ -8341,6 +8341,7 @@ url is put as the `gnus-button-url' overlay property on the button."
        (and (match-end 6) (list (string-to-number (match-string 6 address))))))))
 
 (defun gnus-url-parse-query-string (query &optional downcase)
+  (declare (obsolete message-parse-mailto-url "28.1"))
   (let (retval pairs cur key val)
     (setq pairs (split-string query "&"))
     (while pairs
@@ -8360,31 +8361,8 @@ url is put as the `gnus-button-url' overlay property on the button."
 
 (defun gnus-url-mailto (url)
   ;; Send mail to someone
-  (setq url (replace-regexp-in-string "\n" " " url))
-  (when (string-match "mailto:/*\\(.*\\)" url)
-    (setq url (substring url (match-beginning 1) nil)))
-  (let* ((args (gnus-url-parse-query-string
-               (if (string-match "^\\?" url)
-                   (substring url 1)
-                 (if (string-match "^\\([^?]+\\)\\?\\(.*\\)" url)
-                     (concat "to=" (match-string 1 url) "&"
-                             (match-string 2 url))
-                   (concat "to=" url)))))
-         (subject (cdr-safe (assoc "subject" args)))
-         func)
-    (gnus-msg-mail)
-    (while args
-      (setq func (intern-soft (concat "message-goto-" (downcase (caar args)))))
-      (if (fboundp func)
-         (funcall func)
-       (message-position-on-field (caar args)))
-      (insert (replace-regexp-in-string
-              "\r\n" "\n"
-              (mapconcat #'identity (reverse (cdar args)) ", ") nil t))
-      (setq args (cdr args)))
-    (if subject
-       (message-goto-body)
-      (message-goto-subject))))
+  (gnus-msg-mail)
+  (message-mailto-1 url))
 
 (defun gnus-button-embedded-url (address)
   "Activate ADDRESS with `browse-url'."

diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el
index cf2b8eebc3031188c9ca5fc05112d6c859666276..71ab63de39efdf9e24076d37661d09d2f1cd628f 100644 (file)
--- a/lisp/gnus/message.el
+++ b/lisp/gnus/message.el
@@ -8708,6 +8708,63 @@ used to take the screenshot."
     (insert "\n\n")
     (message "")))
 
+(declare-function gnus-url-unhex-string "gnus-util")
+
+(defun message-parse-mailto-url (url)
+  "Parse a mailto: url."
+  (setq url (replace-regexp-in-string "\n" " " url))
+  (when (string-match "mailto:/*\\(.*\\)" url)
+    (setq url (substring url (match-beginning 1) nil)))
+  (setq url (if (string-match "^\\?" url)
+               (substring url 1)
+             (if (string-match "^\\([^?]+\\)\\?\\(.*\\)" url)
+                 (concat "to=" (match-string 1 url) "&"
+                         (match-string 2 url))
+               (concat "to=" url))))
+  (let (retval pairs cur key val)
+    (setq pairs (split-string url "&"))
+    (while pairs
+      (setq cur (car pairs)
+           pairs (cdr pairs))
+      (if (not (string-match "=" cur))
+         nil                           ; Grace
+       (setq key (downcase (gnus-url-unhex-string
+                            (substring cur 0 (match-beginning 0))))
+             val (gnus-url-unhex-string (substring cur (match-end 0) nil) t))
+       (setq cur (assoc key retval))
+       (if cur
+           (setcdr cur (cons val (cdr cur)))
+         (setq retval (cons (list key val) retval)))))
+    retval))
+
+;;;###autoload
+(defun message-mailto ()
+  "Function to be run to parse command line mailto: links.
+This is meant to be used for MIME handlers: Setting the handler
+for \"x-scheme-handler/mailto;\" to \"emacs -fn message-mailto %u\"
+will then start up Emacs ready to compose mail."
+  (interactive)
+  ;; <a href="mailto:someone@example.com?subject=This%20is%20the%20subject&cc=someone_else@example.com&body=This%20is%20the%20body">Send email</a>
+  (message-mail)
+  (message-mailto-1 (car command-line-args-left))
+  (setq command-line-args-left (cdr command-line-args-left)))
+
+(defun message-mailto-1 (url)
+  (let ((args (message-parse-mailto-url url)))
+    (dolist (arg args)
+      (unless (equal (car arg) "body")
+       (message-position-on-field (capitalize (car arg)))
+       (insert (replace-regexp-in-string
+                "\r\n" "\n"
+                (mapconcat #'identity (reverse (cdr arg)) ", ") nil t))))
+    (when (assoc "body" args)
+      (message-goto-body)
+      (dolist (body (cdr (assoc "body" args)))
+       (insert body "\n")))
+    (if (assoc "subject" args)
+       (message-goto-body)
+      (message-goto-subject))))
+
 (provide 'message)
 
 (run-hooks 'message-load-hook)