lisp/mail/mailclient.el

   1 ;;; mailclient.el --- mail sending via system's mail client.
   2
   3 ;; Copyright (C) 2005-2018 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
  51 (defcustom mailclient-place-body-on-clipboard-flag
  52   (fboundp 'w32-set-clipboard-data)
  53   "If non-nil, put the e-mail body on the clipboard in mailclient.
  54 This is useful on systems where only short mailto:// URLs are
  55 supported.  Defaults to non-nil on Windows, nil otherwise."
  56   :type 'boolean
  57   :group 'mail)
  58
  59 (defun mailclient-encode-string-as-url (string)
  60   "Convert STRING to a URL, using utf-8 as encoding."
  61   (apply (function concat)
  62          (mapcar
  63           (lambda (char)
  64             (cond
  65              ((eq char ?\n) "%0D%0A")  ;; newline
  66              ((string-match "[-a-zA-Z0-9._~]" (char-to-string char))
  67               (char-to-string char))   ;; unreserved as per RFC 6068
  68              (t                        ;; everything else
  69               (format "%%%02x" char)))) ;; escape
  70           ;; Convert string to list of chars
  71           (append (encode-coding-string string 'utf-8)))))
  72
  73 (defvar mailclient-delim-static "?")
  74 (defun mailclient-url-delim ()
  75   (let ((current mailclient-delim-static))
  76     (setq mailclient-delim-static "&")
  77     current))
  78
  79 (defun mailclient-gather-addresses (str &optional drop-first-name)
  80   (let ((field (mail-fetch-field str nil t)))
  81     (if field
  82         (save-excursion
  83           (let ((first t)
  84                 (result ""))
  85             (mapc
  86              (lambda (recp)
  87                (setq result
  88                      (concat
  89                       result
  90                       (if (and drop-first-name
  91                                first)
  92                           ""
  93                         (concat (mailclient-url-delim) str "="))
  94                       (mailclient-encode-string-as-url
  95                        recp)))
  96                (setq first nil))
  97              (split-string
  98               (mail-strip-quoted-names field) ", *"))
  99             result)))))
 100
 101 (declare-function clipboard-kill-ring-save "menu-bar.el"
 102                   (beg end &optional region))
 103
 104 ;;;###autoload
 105 (defun mailclient-send-it ()
 106   "Pass current buffer on to the system's mail client.
 107 Suitable value for `send-mail-function'.
 108 The mail client is taken to be the handler of mailto URLs."
 109   (require 'mail-utils)
 110   (let ((case-fold-search nil)
 111         delimline
 112         (mailbuf (current-buffer)))
 113     (unwind-protect
 114         (with-temp-buffer
 115           (insert-buffer-substring mailbuf)
 116           ;; Move to header delimiter
 117           (mail-sendmail-undelimit-header)
 118           (setq delimline (point-marker))
 119           (if mail-aliases
 120               (expand-mail-aliases (point-min) delimline))
 121           (goto-char (point-min))
 122           ;; ignore any blank lines in the header
 123           (while (and (re-search-forward "\n\n\n*" delimline t)
 124                       (< (point) delimline))
 125             (replace-match "\n"))
 126           (let ((case-fold-search t)
 127                 (mime-charset-pattern
 128                  (concat
 129                   "^content-type:[ \t]*text/plain;"
 130                   "\\(?:[ \t\n]*\\(?:format\\|delsp\\)=\"?[-a-z0-9]+\"?;\\)*"
 131                   "[ \t\n]*charset=\"?\\([^ \t\n\";]+\\)\"?"))
 132                 coding-system
 133                 character-coding
 134                 ;; Use the external browser function to send the
 135                 ;; message.
 136                 (browse-url-mailto-function nil))
 137             ;; initialize limiter
 138             (setq mailclient-delim-static "?")
 139             ;; construct and call up mailto URL
 140             (browse-url
 141              (concat
 142               (save-excursion
 143                 (narrow-to-region (point-min) delimline)
 144                 (goto-char (point-min))
 145                 (setq coding-system
 146                       (if (re-search-forward mime-charset-pattern nil t)
 147                           (coding-system-from-name (match-string 1))
 148                         'undecided))
 149                 (setq character-coding
 150                       (mail-fetch-field "content-transfer-encoding"))
 151                 (when character-coding
 152                   (setq character-coding (downcase character-coding)))
 153                 (concat
 154                  "mailto:"
 155                  ;; some of the headers according to RFC822
 156                  (mailclient-gather-addresses "To"
 157                                               'drop-first-name)
 158                  (mailclient-gather-addresses "cc"  )
 159                  (mailclient-gather-addresses "bcc"  )
 160                  (mailclient-gather-addresses "Resent-To"  )
 161                  (mailclient-gather-addresses "Resent-cc"  )
 162                  (mailclient-gather-addresses "Resent-bcc"  )
 163                  (mailclient-gather-addresses "Reply-To"  )
 164                  ;; The From field is not honored for now: it's
 165                  ;; not necessarily configured. The mail client
 166                  ;; knows the user's address(es)
 167                  ;; (mailclient-gather-addresses "From"  )
 168                  ;; subject line
 169                  (let ((subj (mail-fetch-field "Subject" nil t)))
 170                    (widen) ;; so we can read the body later on
 171                    (if subj ;; if non-blank
 172                        ;; the mail client will deal with
 173                        ;; warning the user etc.
 174                        (concat (mailclient-url-delim) "subject="
 175                                (mailclient-encode-string-as-url subj))
 176                      ""))))
 177               ;; body
 178               (mailclient-url-delim) "body="
 179               (progn
 180                 (delete-region (point-min) delimline)
 181                 (unless (null character-coding)
 182                   ;; mailto: and clipboard need UTF-8 and cannot deal with
 183                   ;; Content-Transfer-Encoding or Content-Type.
 184                   ;; FIXME: There is code duplication here with rmail.el.
 185                   (set-buffer-multibyte nil)
 186                   (cond
 187                    ((string= character-coding "base64")
 188                     (base64-decode-region (point-min) (point-max)))
 189                    ((string= character-coding "quoted-printable")
 190                     (mail-unquote-printable-region (point-min) (point-max)
 191                                                    nil nil t))
 192                    (t (error "unsupported Content-Transfer-Encoding: %s"
 193                              character-coding)))
 194                   (decode-coding-region (point-min) (point-max) coding-system))
 195                 (mailclient-encode-string-as-url
 196                  (if mailclient-place-body-on-clipboard-flag
 197                      (progn
 198                        (clipboard-kill-ring-save (point-min) (point-max))
 199                        (concat
 200                         "*** E-Mail body has been placed on clipboard, "
 201                         "please paste it here! ***"))
 202                    (buffer-string)))))))))))
 203
 204 (provide 'mailclient)
 205
 206 ;;; mailclient.el ends here