mailclient.el 7.08 KB
Newer Older
1
;;; mailclient.el --- mail sending via system's mail client.
Richard M. Stallman's avatar
Richard M. Stallman committed
2

Paul Eggert's avatar
Paul Eggert committed
3
;; Copyright (C) 2005-2015 Free Software Foundation, Inc.
Richard M. Stallman's avatar
Richard M. Stallman committed
4 5 6 7 8 9

;; Author: David Reitter <david.reitter@gmail.com>
;; Keywords: mail

;; This file is part of GNU Emacs.

10
;; GNU Emacs is free software: you can redistribute it and/or modify
Richard M. Stallman's avatar
Richard M. Stallman committed
11
;; it under the terms of the GNU General Public License as published by
12 13
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
Richard M. Stallman's avatar
Richard M. Stallman committed
14 15 16 17 18 19 20

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
21
;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
Richard M. Stallman's avatar
Richard M. Stallman committed
22 23 24

;;; Commentary:

25 26
;; This package allows to hand over a buffer to be sent off
;; via the system's designated e-mail client.
Richard M. Stallman's avatar
Richard M. Stallman committed
27 28 29
;; Note that the e-mail client will display the contents of the buffer
;; again for editing.
;; The e-mail client is taken to be whoever handles a mailto: URL
30
;; via `browse-url'.
Richard M. Stallman's avatar
Richard M. Stallman committed
31 32 33 34 35
;; Mailto: URLs are composed according to RFC2368.

;; MIME bodies are not supported - we rather expect the mail client
;; to encode the body and add, for example, a digital signature.
;; The mailto URL RFC calls for "short text messages that are
36
;; actually the content of automatic processing."
Richard M. Stallman's avatar
Richard M. Stallman committed
37
;; So mailclient.el is ideal for situations where an e-mail is
38 39
;; generated automatically, and the user can edit it in the
;; mail client (e.g. bug-reports).
Richard M. Stallman's avatar
Richard M. Stallman committed
40 41 42 43 44 45 46 47 48

;; To activate:
;; (setq send-mail-function 'mailclient-send-it) ; if you use `mail'

;;; Code:


(require 'sendmail)   ;; for mail-sendmail-undelimit-header
(require 'mail-utils) ;; for mail-fetch-field
49
(require 'browse-url)
Richard M. Stallman's avatar
Richard M. Stallman committed
50

51
(defcustom mailclient-place-body-on-clipboard-flag
Richard M. Stallman's avatar
Richard M. Stallman committed
52 53
  (fboundp 'w32-set-clipboard-data)
  "If non-nil, put the e-mail body on the clipboard in mailclient.
54 55
This is useful on systems where only short mailto:// URLs are
supported.  Defaults to non-nil on Windows, nil otherwise."
Richard M. Stallman's avatar
Richard M. Stallman committed
56 57 58 59 60 61 62 63 64
  :type 'boolean
  :group 'mail)

(defun mailclient-encode-string-as-url (string)
  "Convert STRING to a URL, using utf-8 as encoding."
  (apply (function concat)
	 (mapcar
	  (lambda (char)
	    (cond
65
	     ((eq char ?\n) "%0D%0A")  ;; newline
66 67
	     ((string-match "[-a-zA-Z0-9._~]" (char-to-string char))
	      (char-to-string char))   ;; unreserved as per RFC 6068
Richard M. Stallman's avatar
Richard M. Stallman committed
68 69 70 71 72 73 74 75
	     (t                        ;; everything else
	      (format "%%%02x" char))))	;; escape
	  ;; Convert string to list of chars
	  (append (encode-coding-string string 'utf-8)))))

(defvar mailclient-delim-static "?")
(defun mailclient-url-delim ()
  (let ((current mailclient-delim-static))
76
    (setq mailclient-delim-static "&")
Richard M. Stallman's avatar
Richard M. Stallman committed
77 78 79 80 81 82
    current))

(defun mailclient-gather-addresses (str &optional drop-first-name)
  (let ((field (mail-fetch-field str nil t)))
    (if field
	(save-excursion
83
	  (let ((first t)
Richard M. Stallman's avatar
Richard M. Stallman committed
84 85 86
		(result ""))
	    (mapc
	     (lambda (recp)
87 88
	       (setq result
		     (concat
Richard M. Stallman's avatar
Richard M. Stallman committed
89 90 91 92 93
		      result
		      (if (and drop-first-name
			       first)
			  ""
			(concat (mailclient-url-delim) str "="))
94
		      (mailclient-encode-string-as-url
Richard M. Stallman's avatar
Richard M. Stallman committed
95 96
		       recp)))
	       (setq first nil))
97
	     (split-string
Richard M. Stallman's avatar
Richard M. Stallman committed
98 99 100
	      (mail-strip-quoted-names field) "\, *"))
	    result)))))

Glenn Morris's avatar
Glenn Morris committed
101 102
(declare-function clipboard-kill-ring-save "menu-bar.el"
		  (beg end &optional region))
103

Richard M. Stallman's avatar
Richard M. Stallman committed
104
;;;###autoload
105
(defun mailclient-send-it ()
Richard M. Stallman's avatar
Richard M. Stallman committed
106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125
  "Pass current buffer on to the system's mail client.
Suitable value for `send-mail-function'.
The mail client is taken to be the handler of mailto URLs."
  (require 'mail-utils)
  (let ((case-fold-search nil)
	delimline
	(mailbuf (current-buffer)))
    (unwind-protect
	(with-temp-buffer
	  (insert-buffer-substring mailbuf)
	  ;; Move to header delimiter
	  (mail-sendmail-undelimit-header)
	  (setq delimline (point-marker))
	  (if mail-aliases
	      (expand-mail-aliases (point-min) delimline))
	  (goto-char (point-min))
	  ;; ignore any blank lines in the header
	  (while (and (re-search-forward "\n\n\n*" delimline t)
		      (< (point) delimline))
	    (replace-match "\n"))
126
	  (let ((case-fold-search t)
127 128 129 130 131 132 133
		(mime-charset-pattern
		 (concat
		  "^content-type:[ \t]*text/plain;"
		  "\\(?:[ \t\n]*\\(?:format\\|delsp\\)=\"?[-a-z0-9]+\"?;\\)*"
		  "[ \t\n]*charset=\"?\\([^ \t\n\";]+\\)\"?"))
		coding-system
		character-coding
134 135 136
		;; Use the external browser function to send the
		;; message.
		(browse-url-mailto-function nil))
Richard M. Stallman's avatar
Richard M. Stallman committed
137 138 139
	    ;; initialize limiter
	    (setq mailclient-delim-static "?")
	    ;; construct and call up mailto URL
140 141
	    (browse-url
	     (concat
Richard M. Stallman's avatar
Richard M. Stallman committed
142 143
	      (save-excursion
		(narrow-to-region (point-min) delimline)
144 145 146 147 148 149 150 151 152
		(goto-char (point-min))
		(setq coding-system
		      (if (re-search-forward mime-charset-pattern nil t)
			  (coding-system-from-name (match-string 1))
			'undecided))
		(setq character-coding
		      (mail-fetch-field "content-transfer-encoding"))
		(when character-coding
		  (setq character-coding (downcase character-coding)))
153
		(concat
Richard M. Stallman's avatar
Richard M. Stallman committed
154 155
		 "mailto:"
		 ;; some of the headers according to RFC822
156 157
		 (mailclient-gather-addresses "To"
					      'drop-first-name)
Richard M. Stallman's avatar
Richard M. Stallman committed
158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173
		 (mailclient-gather-addresses "cc"  )
		 (mailclient-gather-addresses "bcc"  )
		 (mailclient-gather-addresses "Resent-To"  )
		 (mailclient-gather-addresses "Resent-cc"  )
		 (mailclient-gather-addresses "Resent-bcc"  )
		 (mailclient-gather-addresses "Reply-To"  )
		 ;; The From field is not honored for now: it's
		 ;; not necessarily configured. The mail client
		 ;; knows the user's address(es)
		 ;; (mailclient-gather-addresses "From"  )
		 ;; subject line
		 (let ((subj (mail-fetch-field "Subject" nil t)))
		   (widen) ;; so we can read the body later on
		   (if subj ;; if non-blank
		       ;; the mail client will deal with
		       ;; warning the user etc.
174
		       (concat (mailclient-url-delim) "subject="
Richard M. Stallman's avatar
Richard M. Stallman committed
175 176 177
			       (mailclient-encode-string-as-url subj))
		     ""))))
	      ;; body
178 179
	      (concat
	       (mailclient-url-delim) "body="
Richard M. Stallman's avatar
Richard M. Stallman committed
180 181 182
	       (mailclient-encode-string-as-url
		(if mailclient-place-body-on-clipboard-flag
		    (progn
183
		      (clipboard-kill-ring-save
Richard M. Stallman's avatar
Richard M. Stallman committed
184 185 186
		       (+ 1 delimline) (point-max))
		      (concat
		       "*** E-Mail body has been placed on clipboard, "
187
		       "please paste it here! ***"))
Richard M. Stallman's avatar
Richard M. Stallman committed
188
		  ;; else
189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208
		  (let ((body (buffer-substring (+ 1 delimline) (point-max))))
		    (if (null character-coding)
			body
		      ;; mailto: requires UTF-8 and cannot deal with
		      ;; Content-Transfer-Encoding or Content-Type.
		      ;; FIXME: There is a lot of code duplication here
		      ;; with rmail.el.
		      (erase-buffer)
		      (set-buffer-multibyte nil)
		      (insert body)
		      (cond
		       ((string= character-coding "quoted-printable")
			(mail-unquote-printable-region (point-min) (point-max)
						       nil nil 'unibyte))
		       ((string= character-coding "base64")
			(base64-decode-region (point-min) (point-max)))
		       (t (error "unsupported Content-Transfer-Encoding: %s"
				 character-coding)))
		      (decode-coding-region (point-min) (point-max)
					    coding-system t)))))))))))))
Richard M. Stallman's avatar
Richard M. Stallman committed
209 210 211 212

(provide 'mailclient)

;;; mailclient.el ends here