code.delx.au - gnu-emacs/blob - 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, 2008, 2009 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 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
  50 (defcustom mailclient-place-body-on-clipboard-flag
  51   (fboundp 'w32-set-clipboard-data)
  52   "If non-nil, put the e-mail body on the clipboard in mailclient.
  53 This is useful on systems where only short mailto:// URLs are
  54 supported.  Defaults to non-nil on Windows, nil otherwise."
  55   :type 'boolean
  56   :group 'mail)
  57
  58 (defun mailclient-encode-string-as-url (string)
  59   "Convert STRING to a URL, using utf-8 as encoding."
  60   (apply (function concat)
  61          (mapcar
  62           (lambda (char)
  63             (cond
  64              ((eq char ?\x20) "%20")   ;; space
  65              ((eq char ?\n) "%0D%0A")  ;; newline
  66              ((string-match "[-a-zA-Z0-9_:/.@]" (char-to-string char))
  67               (char-to-string char))   ;; printable
  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 ;;;###autoload
 102 (defun mailclient-send-it ()
 103   "Pass current buffer on to the system's mail client.
 104 Suitable value for `send-mail-function'.
 105 The mail client is taken to be the handler of mailto URLs."
 106   (require 'mail-utils)
 107   (let ((case-fold-search nil)
 108         delimline
 109         (mailbuf (current-buffer)))
 110     (unwind-protect
 111         (with-temp-buffer
 112           (insert-buffer-substring mailbuf)
 113           ;; Move to header delimiter
 114           (mail-sendmail-undelimit-header)
 115           (setq delimline (point-marker))
 116           (if mail-aliases
 117               (expand-mail-aliases (point-min) delimline))
 118           (goto-char (point-min))
 119           ;; ignore any blank lines in the header
 120           (while (and (re-search-forward "\n\n\n*" delimline t)
 121                       (< (point) delimline))
 122             (replace-match "\n"))
 123           (let ((case-fold-search t))
 124             ;; initialize limiter
 125             (setq mailclient-delim-static "?")
 126             ;; construct and call up mailto URL
 127             (browse-url
 128              (concat
 129               (save-excursion
 130                 (narrow-to-region (point-min) delimline)
 131                 (concat
 132                  "mailto:"
 133                  ;; some of the headers according to RFC822
 134                  (mailclient-gather-addresses "To"
 135                                               'drop-first-name)
 136                  (mailclient-gather-addresses "cc"  )
 137                  (mailclient-gather-addresses "bcc"  )
 138                  (mailclient-gather-addresses "Resent-To"  )
 139                  (mailclient-gather-addresses "Resent-cc"  )
 140                  (mailclient-gather-addresses "Resent-bcc"  )
 141                  (mailclient-gather-addresses "Reply-To"  )
 142                  ;; The From field is not honored for now: it's
 143                  ;; not necessarily configured. The mail client
 144                  ;; knows the user's address(es)
 145                  ;; (mailclient-gather-addresses "From"  )
 146                  ;; subject line
 147                  (let ((subj (mail-fetch-field "Subject" nil t)))
 148                    (widen) ;; so we can read the body later on
 149                    (if subj ;; if non-blank
 150                        ;; the mail client will deal with
 151                        ;; warning the user etc.
 152                        (concat (mailclient-url-delim) "subject="
 153                                (mailclient-encode-string-as-url subj))
 154                      ""))))
 155               ;; body
 156               (concat
 157                (mailclient-url-delim) "body="
 158                (mailclient-encode-string-as-url
 159                 (if mailclient-place-body-on-clipboard-flag
 160                     (progn
 161                       (clipboard-kill-ring-save
 162                        (+ 1 delimline) (point-max))
 163                       (concat
 164                        "*** E-Mail body has been placed on clipboard, "
 165                        "please paste them here! ***"))
 166                   ;; else
 167                   (buffer-substring (+ 1 delimline) (point-max))))))))))))
 168
 169 (provide 'mailclient)
 170
 171 ;; arch-tag: 35d10fc8-a1bc-4f29-a4e6-c288e53578ef
 172 ;;; mailclient.el ends here