1;;; mailclient.el --- mail sending via system's mail client.
2
3;; Copyright (C) 2005-2021 Free Software Foundation, Inc.
4
5;; Author: David Reitter <david.reitter@gmail.com>
6;; Keywords: mail
7
8;; This file is part of GNU Emacs.
9
10;; GNU Emacs is free software: you can redistribute it and/or modify
11;; it under the terms of the GNU General Public License as published by
12;; the Free Software Foundation, either version 3 of the License, or
13;; (at your option) any later version.
14
15;; GNU Emacs is distributed in the hope that it will be useful,
16;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
18;; GNU General Public License for more details.
19
20;; You should have received a copy of the GNU General Public License
21;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.
22
23;;; Commentary:
24
25;; This package allows handing over a buffer to be sent off
26;; via the system's designated e-mail client.
27;; Note that the e-mail client will display the contents of the buffer
28;; again for editing.
29;; The e-mail client is taken to be whoever handles a mailto: URL
30;; via `browse-url'.
31;; Mailto: URLs are composed according to RFC2368.
32
33;; MIME bodies are not supported - we rather expect the mail client
34;; to encode the body and add, for example, a digital signature.
35;; The mailto URL RFC calls for "short text messages that are
36;; actually the content of automatic processing."
37;; So mailclient.el is ideal for situations where an e-mail is
38;; generated automatically, and the user can edit it in the
39;; mail client (e.g. bug-reports).
40
41;; To activate:
42;; (setq send-mail-function 'mailclient-send-it) ; if you use `mail'
43
44;;; Code:
45
46
47(require 'sendmail)   ;; for mail-sendmail-undelimit-header
48(require 'mail-utils) ;; for mail-fetch-field
49(require 'browse-url)
50(require 'mail-parse)
51
52(defcustom mailclient-place-body-on-clipboard-flag
53  (fboundp 'w32-set-clipboard-data)
54  "If non-nil, put the e-mail body on the clipboard in mailclient.
55This is useful on systems where only short mailto:// URLs are
56supported.  Defaults to non-nil on Windows, nil otherwise."
57  :type 'boolean
58  :group 'mail)
59
60(defun mailclient-encode-string-as-url (string)
61  "Convert STRING to a URL, using utf-8 as encoding."
62  (apply (function concat)
63	 (mapcar
64	  (lambda (char)
65	    (cond
66	     ((eq char ?\n) "%0D%0A")  ;; newline
67	     ((string-match "[-a-zA-Z0-9._~]" (char-to-string char))
68	      (char-to-string char))   ;; unreserved as per RFC 6068
69	     (t                        ;; everything else
70	      (format "%%%02x" char))))	;; escape
71	  ;; Convert string to list of chars
72	  (append (encode-coding-string string 'utf-8)))))
73
74(defvar mailclient-delim-static "?")
75(defun mailclient-url-delim ()
76  (let ((current mailclient-delim-static))
77    (setq mailclient-delim-static "&")
78    current))
79
80(defun mailclient-gather-addresses (str &optional drop-first-name)
81  (let ((field (mail-fetch-field str nil t)))
82    (if field
83	(save-excursion
84	  (let ((first t)
85		(result ""))
86	    (mapc
87	     (lambda (recp)
88	       (setq result
89		     (concat
90		      result
91		      (if (and drop-first-name
92			       first)
93			  ""
94			(concat (mailclient-url-delim) str "="))
95		      (mailclient-encode-string-as-url
96		       recp)))
97	       (setq first nil))
98	     (split-string
99	      (mail-strip-quoted-names field) ", *"))
100	    result)))))
101
102(declare-function clipboard-kill-ring-save "menu-bar.el"
103		  (beg end &optional region))
104
105;;;###autoload
106(defun mailclient-send-it ()
107  "Pass current buffer on to the system's mail client.
108Suitable value for `send-mail-function'.
109The mail client is taken to be the handler of mailto URLs."
110  (require 'mail-utils)
111  (let ((case-fold-search nil)
112	delimline
113	(mailbuf (current-buffer)))
114    (unwind-protect
115	(with-temp-buffer
116	  (insert-buffer-substring mailbuf)
117	  ;; Move to header delimiter
118	  (mail-sendmail-undelimit-header)
119	  (setq delimline (point-marker))
120	  (if mail-aliases
121	      (expand-mail-aliases (point-min) delimline))
122	  (goto-char (point-min))
123	  ;; ignore any blank lines in the header
124	  (while (and (re-search-forward "\n\n\n*" delimline t)
125		      (< (point) delimline))
126	    (replace-match "\n"))
127	  (let ((case-fold-search t)
128		(mime-charset-pattern
129		 (concat
130		  "^content-type:[ \t]*text/plain;"
131		  "\\(?:[ \t\n]*\\(?:format\\|delsp\\)=\"?[-a-z0-9]+\"?;\\)*"
132		  "[ \t\n]*charset=\"?\\([^ \t\n\";]+\\)\"?"))
133		coding-system
134		character-coding
135		;; Use the external browser function to send the
136		;; message.
137		(browse-url-mailto-function nil))
138	    ;; initialize limiter
139	    (setq mailclient-delim-static "?")
140	    ;; construct and call up mailto URL
141	    (browse-url
142	     (concat
143	      (save-excursion
144		(narrow-to-region (point-min) delimline)
145                ;; We can't send multipart/* messages (i. e. with
146                ;; attachments or the like) via this method.
147                (when-let ((type (mail-fetch-field "content-type")))
148                  (when (and (string-match "multipart"
149                                           (car (mail-header-parse-content-type
150                                                 type)))
151                             (not (y-or-n-p "Message with attachments can't be sent via mailclient; continue anyway?")))
152                    (error "Choose a different `send-mail-function' to send attachments")))
153		(goto-char (point-min))
154		(setq coding-system
155		      (if (re-search-forward mime-charset-pattern nil t)
156			  (coding-system-from-name (match-string 1))
157			'undecided))
158		(setq character-coding
159		      (mail-fetch-field "content-transfer-encoding"))
160		(when character-coding
161		  (setq character-coding (downcase character-coding)))
162		(concat
163		 "mailto:"
164		 ;; Some of the headers according to RFC 822 (or later).
165		 (mailclient-gather-addresses "To"
166					      'drop-first-name)
167		 (mailclient-gather-addresses "cc"  )
168		 (mailclient-gather-addresses "bcc"  )
169		 (mailclient-gather-addresses "Resent-To"  )
170		 (mailclient-gather-addresses "Resent-cc"  )
171		 (mailclient-gather-addresses "Resent-bcc"  )
172		 (mailclient-gather-addresses "Reply-To"  )
173		 ;; The From field is not honored for now: it's
174		 ;; not necessarily configured. The mail client
175		 ;; knows the user's address(es)
176		 ;; (mailclient-gather-addresses "From"  )
177		 ;; subject line
178		 (let ((subj (mail-fetch-field "Subject" nil t)))
179		   (widen) ;; so we can read the body later on
180		   (if subj ;; if non-blank
181		       ;; the mail client will deal with
182		       ;; warning the user etc.
183		       (concat (mailclient-url-delim) "subject="
184			       (mailclient-encode-string-as-url subj))
185		     ""))))
186	      ;; body
187	      (mailclient-url-delim) "body="
188	      (progn
189		(delete-region (point-min) delimline)
190		(unless (null character-coding)
191		  ;; mailto: and clipboard need UTF-8 and cannot deal with
192		  ;; Content-Transfer-Encoding or Content-Type.
193		  ;; FIXME: There is code duplication here with rmail.el.
194		  (set-buffer-multibyte nil)
195		  (cond
196		   ((string= character-coding "base64")
197		    (base64-decode-region (point-min) (point-max)))
198		   ((string= character-coding "quoted-printable")
199		    (mail-unquote-printable-region (point-min) (point-max)
200						   nil nil t))
201		   (t (error "unsupported Content-Transfer-Encoding: %s"
202			     character-coding)))
203		  (decode-coding-region (point-min) (point-max) coding-system))
204		(mailclient-encode-string-as-url
205		 (if mailclient-place-body-on-clipboard-flag
206		     (progn
207		       (clipboard-kill-ring-save (point-min) (point-max))
208		       (concat
209			"*** E-Mail body has been placed on clipboard, "
210			"please paste it here! ***"))
211		   (buffer-string)))))))))))
212
213(provide 'mailclient)
214
215;;; mailclient.el ends here
216