code.delx.au - gnu-emacs/blob - lisp/mail/mailclient.el

   1 ;;; mailclient.el --- mail sending via system's mail client.
   2
   3 ;; Copyright (C) 2005-2015 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 <http://www.gnu.org/licenses/>.
  22
  23 ;;; Commentary:
  24
  25 ;; This package allows to hand 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 ?\x20) "%20")   ;; space
  66              ((eq char ?\n) "%0D%0A")  ;; newline
  67              ((string-match "[-a-zA-Z0-9_:/.@]" (char-to-string char))
  68               (char-to-string char))   ;; printable
  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.
 108 Suitable value for `send-mail-function'.
 109 The 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                 ;; Use the external browser function to send the
 129                 ;; message.
 130                 (browse-url-mailto-function nil))
 131             ;; initialize limiter
 132             (setq mailclient-delim-static "?")
 133             ;; construct and call up mailto URL
 134             (browse-url
 135              (concat
 136               (save-excursion
 137                 (narrow-to-region (point-min) delimline)
 138                 (concat
 139                  "mailto:"
 140                  ;; some of the headers according to RFC822
 141                  (mailclient-gather-addresses "To"
 142                                               'drop-first-name)
 143                  (mailclient-gather-addresses "cc"  )
 144                  (mailclient-gather-addresses "bcc"  )
 145                  (mailclient-gather-addresses "Resent-To"  )
 146                  (mailclient-gather-addresses "Resent-cc"  )
 147                  (mailclient-gather-addresses "Resent-bcc"  )
 148                  (mailclient-gather-addresses "Reply-To"  )
 149                  ;; The From field is not honored for now: it's
 150                  ;; not necessarily configured. The mail client
 151                  ;; knows the user's address(es)
 152                  ;; (mailclient-gather-addresses "From"  )
 153                  ;; subject line
 154                  (let ((subj (mail-fetch-field "Subject" nil t)))
 155                    (widen) ;; so we can read the body later on
 156                    (if subj ;; if non-blank
 157                        ;; the mail client will deal with
 158                        ;; warning the user etc.
 159                        (concat (mailclient-url-delim) "subject="
 160                                (mailclient-encode-string-as-url subj))
 161                      ""))))
 162               ;; body
 163               (concat
 164                (mailclient-url-delim) "body="
 165                (mailclient-encode-string-as-url
 166                 (if mailclient-place-body-on-clipboard-flag
 167                     (progn
 168                       (clipboard-kill-ring-save
 169                        (+ 1 delimline) (point-max))
 170                       (concat
 171                        "*** E-Mail body has been placed on clipboard, "
 172                        "please paste it here! ***"))
 173                   ;; else
 174                   (buffer-substring (+ 1 delimline) (point-max))))))))))))
 175
 176 (provide 'mailclient)
 177
 178 ;;; mailclient.el ends here