lisp/mail/mailclient.el

   1 ;;; mailclient.el --- mail sending via system's mail client.  -*- byte-compile-dynamic: t -*-
   2
   3 ;; Copyright (C) 2005, 2006, 2007 Free Software Foundation
   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 2, or (at your option)
  13 ;; 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; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  23 ;; Boston, MA 02110-1301, USA.
  24
  25 ;;; Commentary:
  26
  27 ;; This package allows to hand over a buffer to be sent off
  28 ;; via the system's designated e-mail client.
  29 ;; Note that the e-mail client will display the contents of the buffer
  30 ;; again for editing.
  31 ;; The e-mail client is taken to be whoever handles a mailto: URL
  32 ;; via `browse-url'.
  33 ;; Mailto: URLs are composed according to RFC2368.
  34
  35 ;; MIME bodies are not supported - we rather expect the mail client
  36 ;; to encode the body and add, for example, a digital signature.
  37 ;; The mailto URL RFC calls for "short text messages that are
  38 ;; actually the content of automatic processing."
  39 ;; So mailclient.el is ideal for situations where an e-mail is
  40 ;; generated automatically, and the user can edit it in the
  41 ;; mail client (e.g. bug-reports).
  42
  43 ;; To activate:
  44 ;; (setq send-mail-function 'mailclient-send-it) ; if you use `mail'
  45
  46 ;;; Code:
  47
  48
  49 (require 'sendmail)   ;; for mail-sendmail-undelimit-header
  50 (require 'mail-utils) ;; for mail-fetch-field
  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.
  55 This is useful on systems where only short mailto:// URLs are
  56 supported.  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 ?\x20) "%20")   ;; space
  67              ((eq char ?\n) "%0D%0A")  ;; newline
  68              ((string-match "[-a-zA-Z0-9_:/.@]" (char-to-string char))
  69               (char-to-string char))   ;; printable
  70              (t                        ;; everything else
  71               (format "%%%02x" char)))) ;; escape
  72           ;; Convert string to list of chars
  73           (append (encode-coding-string string 'utf-8)))))
  74
  75 (defvar mailclient-delim-static "?")
  76 (defun mailclient-url-delim ()
  77   (let ((current mailclient-delim-static))
  78     (setq mailclient-delim-static "&")
  79     current))
  80
  81 (defun mailclient-gather-addresses (str &optional drop-first-name)
  82   (let ((field (mail-fetch-field str nil t)))
  83     (if field
  84         (save-excursion
  85           (let ((first t)
  86                 (result ""))
  87             (mapc
  88              (lambda (recp)
  89                (setq result
  90                      (concat
  91                       result
  92                       (if (and drop-first-name
  93                                first)
  94                           ""
  95                         (concat (mailclient-url-delim) str "="))
  96                       (mailclient-encode-string-as-url
  97                        recp)))
  98                (setq first nil))
  99              (split-string
 100               (mail-strip-quoted-names field) "\, *"))
 101             result)))))
 102
 103 ;;;###autoload
 104 (defun mailclient-send-it ()
 105   "Pass current buffer on to the system's mail client.
 106 Suitable value for `send-mail-function'.
 107 The mail client is taken to be the handler of mailto URLs."
 108   (require 'mail-utils)
 109   (let ((case-fold-search nil)
 110         delimline
 111         (mailbuf (current-buffer)))
 112     (unwind-protect
 113         (with-temp-buffer
 114           (insert-buffer-substring mailbuf)
 115           ;; Move to header delimiter
 116           (mail-sendmail-undelimit-header)
 117           (setq delimline (point-marker))
 118           (if mail-aliases
 119               (expand-mail-aliases (point-min) delimline))
 120           (goto-char (point-min))
 121           ;; ignore any blank lines in the header
 122           (while (and (re-search-forward "\n\n\n*" delimline t)
 123                       (< (point) delimline))
 124             (replace-match "\n"))
 125           (let ((case-fold-search t))
 126             ;; initialize limiter
 127             (setq mailclient-delim-static "?")
 128             ;; construct and call up mailto URL
 129             (browse-url
 130              (concat
 131               (save-excursion
 132                 (narrow-to-region (point-min) delimline)
 133                 (concat
 134                  "mailto:"
 135                  ;; some of the headers according to RFC822
 136                  (mailclient-gather-addresses "To"
 137                                               'drop-first-name)
 138                  (mailclient-gather-addresses "cc"  )
 139                  (mailclient-gather-addresses "bcc"  )
 140                  (mailclient-gather-addresses "Resent-To"  )
 141                  (mailclient-gather-addresses "Resent-cc"  )
 142                  (mailclient-gather-addresses "Resent-bcc"  )
 143                  (mailclient-gather-addresses "Reply-To"  )
 144                  ;; The From field is not honored for now: it's
 145                  ;; not necessarily configured. The mail client
 146                  ;; knows the user's address(es)
 147                  ;; (mailclient-gather-addresses "From"  )
 148                  ;; subject line
 149                  (let ((subj (mail-fetch-field "Subject" nil t)))
 150                    (widen) ;; so we can read the body later on
 151                    (if subj ;; if non-blank
 152                        ;; the mail client will deal with
 153                        ;; warning the user etc.
 154                        (concat (mailclient-url-delim) "subject="
 155                                (mailclient-encode-string-as-url subj))
 156                      ""))))
 157               ;; body
 158               (concat
 159                (mailclient-url-delim) "body="
 160                (mailclient-encode-string-as-url
 161                 (if mailclient-place-body-on-clipboard-flag
 162                     (progn
 163                       (clipboard-kill-ring-save
 164                        (+ 1 delimline) (point-max))
 165                       (concat
 166                        "*** E-Mail body has been placed on clipboard, "
 167                        "please paste them here! ***"))
 168                   ;; else
 169                   (buffer-substring (+ 1 delimline) (point-max))))))))))))
 170
 171 (provide 'mailclient)
 172
 173 ;; arch-tag: 35d10fc8-a1bc-4f29-a4e6-c288e53578ef
 174 ;;; mailclient.el ends here