org.el (org-read-date-minibuffer-local-map): Check if we are at the beginning of...
[org-mode.git] / contrib / lisp / org-mime.el
blob855dc2d58eaf225406333b02c07395cfa2432fe9
1 ;;; org-mime.el --- org html export for text/html MIME emails
3 ;; Copyright (C) 2010-2013 Eric Schulte
5 ;; Author: Eric Schulte
6 ;; Keywords: mime, mail, email, html
7 ;; Homepage: http://orgmode.org/worg/org-contrib/org-mime.php
8 ;; Version: 0.01
10 ;; This file is not part of GNU Emacs.
12 ;;; License:
14 ;; This program is free software; you can redistribute it and/or modify
15 ;; it under the terms of the GNU General Public License as published by
16 ;; the Free Software Foundation; either version 3, or (at your option)
17 ;; any later version.
19 ;; This program is distributed in the hope that it will be useful,
20 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
21 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
22 ;; GNU General Public License for more details.
24 ;; You should have received a copy of the GNU General Public License
25 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
27 ;;; Commentary:
29 ;; WYSWYG, html mime composition using org-mode
31 ;; For mail composed using the orgstruct-mode minor mode, this
32 ;; provides a function for converting all or part of your mail buffer
33 ;; to embedded html as exported by org-mode. Call `org-mime-htmlize'
34 ;; in a message buffer to convert either the active region or the
35 ;; entire buffer to html.
37 ;; Similarly the `org-mime-org-buffer-htmlize' function can be called
38 ;; from within an org-mode buffer to convert the buffer to html, and
39 ;; package the results into an email handling with appropriate MIME
40 ;; encoding.
42 ;; you might want to bind this to a key with something like the
43 ;; following message-mode binding
45 ;; (add-hook 'message-mode-hook
46 ;; (lambda ()
47 ;; (local-set-key "\C-c\M-o" 'org-mime-htmlize)))
49 ;; and the following org-mode binding
51 ;; (add-hook 'org-mode-hook
52 ;; (lambda ()
53 ;; (local-set-key "\C-c\M-o" 'org-mime-org-buffer-htmlize)))
55 ;;; Code:
56 (require 'cl)
58 (declare-function org-export-string-as "ox"
59 (string backend &optional body-only ext-plist))
61 (defcustom org-mime-use-property-inheritance nil
62 "Non-nil means al MAIL_ properties apply also for sublevels."
63 :group 'org-mime
64 :type 'boolean)
66 (defcustom org-mime-default-header
67 "#+OPTIONS: latex:t\n"
68 "Default header to control html export options, and ensure
69 first line isn't assumed to be a title line."
70 :group 'org-mime
71 :type 'string)
73 (defcustom org-mime-library 'mml
74 "Library to use for marking up MIME elements."
75 :group 'org-mime
76 :type '(choice 'mml 'semi 'vm))
78 (defcustom org-mime-preserve-breaks t
79 "Used as temporary value of `org-export-preserve-breaks' during
80 mime encoding."
81 :group 'org-mime
82 :type 'boolean)
84 (defcustom org-mime-fixedwith-wrap
85 "<pre style=\"font-family: courier, monospace;\">\n%s</pre>\n"
86 "Format string used to wrap a fixedwidth HTML email."
87 :group 'org-mime
88 :type 'string)
90 (defcustom org-mime-html-hook nil
91 "Hook to run over the html buffer before attachment to email.
92 This could be used for example to post-process html elements."
93 :group 'org-mime
94 :type 'hook)
96 (mapc (lambda (fmt)
97 (eval `(defcustom
98 ,(intern (concat "org-mime-pre-" fmt "-hook"))
99 nil
100 (concat "Hook to run before " fmt " export.\nFunctions "
101 "should take no arguments and will be run in a "
102 "buffer holding\nthe text to be exported."))))
103 '("ascii" "org" "html"))
105 (defcustom org-mime-send-subtree-hook nil
106 "Hook to run in the subtree in the Org-mode file before export.")
108 (defcustom org-mime-send-buffer-hook nil
109 "Hook to run in the Org-mode file before export.")
111 ;; example hook, for setting a dark background in <pre style="background-color: #EEE;"> elements
112 (defun org-mime-change-element-style (element style)
113 "Set new default htlm style for <ELEMENT> elements in exported html."
114 (while (re-search-forward (format "<%s" element) nil t)
115 (replace-match (format "<%s style=\"%s\"" element style))))
117 (defun org-mime-change-class-style (class style)
118 "Set new default htlm style for objects with classs=CLASS in
119 exported html."
120 (while (re-search-forward (format "class=\"%s\"" class) nil t)
121 (replace-match (format "class=\"%s\" style=\"%s\"" class style))))
123 ;; ;; example addition to `org-mime-html-hook' adding a dark background
124 ;; ;; color to <pre> elements
125 ;; (add-hook 'org-mime-html-hook
126 ;; (lambda ()
127 ;; (org-mime-change-element-style
128 ;; "pre" (format "color: %s; background-color: %s;"
129 ;; "#E6E1DC" "#232323"))
130 ;; (org-mime-change-class-style
131 ;; "verse" "border-left: 2px solid gray; padding-left: 4px;")))
133 (defun org-mime-file (ext path id)
134 "Markup a file for attachment."
135 (case org-mime-library
136 ('mml (format (concat "<#part type=\"%s\" filename=\"%s\" "
137 "disposition=inline id=\"<%s>\">\n<#/part>\n")
138 ext path id))
139 ('semi (concat
140 (format (concat "--[[%s\nContent-Disposition: "
141 "inline;\nContent-ID: <%s>][base64]]\n")
142 ext id)
143 (base64-encode-string
144 (with-temp-buffer
145 (set-buffer-multibyte nil)
146 (binary-insert-encoded-file path)
147 (buffer-string)))))
148 ('vm "?")))
150 (defun org-mime-multipart (plain html &optional images)
151 "Markup a multipart/alternative with text/plain and text/html alternatives.
152 If the html portion of the message includes images wrap the html
153 and images in a multipart/related part."
154 (case org-mime-library
155 ('mml (concat "<#multipart type=alternative><#part type=text/plain>"
156 plain
157 (when images "<#multipart type=related>")
158 "<#part type=text/html>"
159 html
160 images
161 (when images "<#/multipart>\n")
162 "<#/multipart>\n"))
163 ('semi (concat
164 "--" "<<alternative>>-{\n"
165 "--" "[[text/plain]]\n" plain
166 (when images (concat "--" "<<alternative>>-{\n"))
167 "--" "[[text/html]]\n" html
168 images
169 (when images (concat "--" "}-<<alternative>>\n"))
170 "--" "}-<<alternative>>\n"))
171 ('vm "?")))
173 (defun org-mime-replace-images (str current-file)
174 "Replace images in html files with cid links."
175 (let (html-images)
176 (cons
177 (replace-regexp-in-string ;; replace images in html
178 "src=\"\\([^\"]+\\)\""
179 (lambda (text)
180 (format
181 "src=\"cid:%s\""
182 (let* ((url (and (string-match "src=\"\\([^\"]+\\)\"" text)
183 (match-string 1 text)))
184 (path (expand-file-name
185 url (file-name-directory current-file)))
186 (ext (file-name-extension path))
187 (id (replace-regexp-in-string "[\/\\\\]" "_" path)))
188 (add-to-list 'html-images
189 (org-mime-file (concat "image/" ext) path id))
190 id)))
191 str)
192 html-images)))
194 (defun org-mime-htmlize (arg)
195 "Export a portion of an email body composed using `mml-mode' to
196 html using `org-mode'. If called with an active region only
197 export that region, otherwise export the entire body."
198 (interactive "P")
199 (require 'ox-org)
200 (require 'ox-html)
201 (let* ((region-p (org-region-active-p))
202 (html-start (or (and region-p (region-beginning))
203 (save-excursion
204 (goto-char (point-min))
205 (search-forward mail-header-separator)
206 (+ (point) 1))))
207 (html-end (or (and region-p (region-end))
208 ;; TODO: should catch signature...
209 (point-max)))
210 (raw-body (concat org-mime-default-header
211 (buffer-substring html-start html-end)))
212 (tmp-file (make-temp-name (expand-file-name
213 "mail" temporary-file-directory)))
214 (body (org-export-string-as raw-body 'org t))
215 ;; because we probably don't want to skip part of our mail
216 (org-export-skip-text-before-1st-heading nil)
217 ;; because we probably don't want to export a huge style file
218 (org-export-htmlize-output-type 'inline-css)
219 ;; makes the replies with ">"s look nicer
220 (org-export-preserve-breaks org-mime-preserve-breaks)
221 ;; dvipng for inline latex because MathJax doesn't work in mail
222 (org-export-with-LaTeX-fragments 'dvipng)
223 ;; to hold attachments for inline html images
224 (html-and-images
225 (org-mime-replace-images
226 (org-export-string-as raw-body 'html t) tmp-file))
227 (html-images (unless arg (cdr html-and-images)))
228 (html (org-mime-apply-html-hook
229 (if arg
230 (format org-mime-fixedwith-wrap body)
231 (car html-and-images)))))
232 (delete-region html-start html-end)
233 (save-excursion
234 (goto-char html-start)
235 (insert (org-mime-multipart
236 body html (mapconcat 'identity html-images "\n"))))))
238 (defun org-mime-apply-html-hook (html)
239 (if org-mime-html-hook
240 (with-temp-buffer
241 (insert html)
242 (goto-char (point-min))
243 (run-hooks 'org-mime-html-hook)
244 (buffer-string))
245 html))
247 (defmacro org-mime-try (&rest body)
248 `(condition-case nil ,@body (error nil)))
250 (defun org-mime-send-subtree (&optional fmt)
251 (save-restriction
252 (org-narrow-to-subtree)
253 (run-hooks 'org-mime-send-subtree-hook)
254 (flet ((mp (p) (org-entry-get nil p org-mime-use-property-inheritance)))
255 (let* ((file (buffer-file-name (current-buffer)))
256 (subject (or (mp "MAIL_SUBJECT") (nth 4 (org-heading-components))))
257 (to (mp "MAIL_TO"))
258 (cc (mp "MAIL_CC"))
259 (bcc (mp "MAIL_BCC"))
260 (body (buffer-substring
261 (save-excursion (goto-char (point-min))
262 (forward-line 1)
263 (when (looking-at "[ \t]*:PROPERTIES:")
264 (re-search-forward ":END:" nil)
265 (forward-char))
266 (point))
267 (point-max))))
268 (org-mime-compose body (or fmt 'org) file to subject
269 `((cc . ,cc) (bcc . ,bcc)))))))
271 (defun org-mime-send-buffer (&optional fmt)
272 (run-hooks 'org-mime-send-buffer-hook)
273 (let* ((region-p (org-region-active-p))
274 (subject (org-export-grab-title-from-buffer))
275 (file (buffer-file-name (current-buffer)))
276 (body-start (or (and region-p (region-beginning))
277 (save-excursion (goto-char (point-min)))))
278 (body-end (or (and region-p (region-end)) (point-max)))
279 (temp-body-file (make-temp-file "org-mime-export"))
280 (body (buffer-substring body-start body-end)))
281 (org-mime-compose body (or fmt 'org) file nil subject)))
283 (defun org-mime-compose (body fmt file &optional to subject headers)
284 (require 'message)
285 (message-mail to subject headers nil)
286 (message-goto-body)
287 (flet ((bhook (body fmt)
288 (let ((hook (intern (concat "org-mime-pre-"
289 (symbol-name fmt)
290 "-hook"))))
291 (if (> (eval `(length ,hook)) 0)
292 (with-temp-buffer
293 (insert body)
294 (goto-char (point-min))
295 (eval `(run-hooks ',hook))
296 (buffer-string))
297 body))))
298 (let ((fmt (if (symbolp fmt) fmt (intern fmt))))
299 (cond
300 ((eq fmt 'org)
301 (require 'ox-org)
302 (insert (org-export-string-as
303 (org-babel-trim (bhook body 'org)) 'org t)))
304 ((eq fmt 'ascii)
305 (require 'ox-ascii)
306 (insert (org-export-string-as
307 (concat "#+Title:\n" (bhook body 'ascii)) 'ascii t)))
308 ((or (eq fmt 'html) (eq fmt 'html-ascii))
309 (require 'ox-ascii)
310 (require 'ox-org)
311 (let* ((org-link-file-path-type 'absolute)
312 ;; we probably don't want to export a huge style file
313 (org-export-htmlize-output-type 'inline-css)
314 (html-and-images
315 (org-mime-replace-images
316 (org-export-string-as (bhook body 'html) 'html t) file))
317 (images (cdr html-and-images))
318 (html (org-mime-apply-html-hook (car html-and-images))))
319 (insert (org-mime-multipart
320 (org-export-string-as
321 (org-babel-trim
322 (bhook body (if (eq fmt 'html) 'org 'ascii)))
323 (if (eq fmt 'html) 'org 'ascii) t)
324 html)
325 (mapconcat 'identity images "\n"))))))))
327 (defun org-mime-org-buffer-htmlize ()
328 "Create an email buffer containing the current org-mode file
329 exported to html and encoded in both html and in org formats as
330 mime alternatives."
331 (interactive)
332 (org-mime-send-buffer 'html))
334 (defun org-mime-subtree ()
335 "Create an email buffer containing the current org-mode subtree
336 exported to a org format or to the format specified by the
337 MAIL_FMT property of the subtree."
338 (interactive)
339 (org-mime-send-subtree
340 (or (org-entry-get nil "MAIL_FMT" org-mime-use-property-inheritance) 'org)))
342 (provide 'org-mime)