From 7697fa4daf3ec84f85711a84035d8f0224afd4e3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=A9bastien=20Delafond?= Date: Sun, 13 Jul 2014 13:35:01 +0200 Subject: Imported Upstream version 7.9.2 --- contrib/README | 96 + contrib/babel/langs/ob-fomus.el | 93 + contrib/babel/langs/ob-oz.el | 294 ++ contrib/babel/library-of-babel.org | 584 +++ contrib/lisp/htmlize.el | 1769 ++++++++ contrib/lisp/org-annotate-file.el | 131 + contrib/lisp/org-bibtex-extras.el | 155 + contrib/lisp/org-bookmark.el | 88 + contrib/lisp/org-checklist.el | 140 + contrib/lisp/org-choose.el | 542 +++ contrib/lisp/org-collector.el | 229 + contrib/lisp/org-contacts.el | 621 +++ contrib/lisp/org-contribdir.el | 38 + contrib/lisp/org-depend.el | 420 ++ contrib/lisp/org-drill.el | 3001 +++++++++++++ contrib/lisp/org-e-ascii.el | 1807 ++++++++ contrib/lisp/org-e-beamer.el | 1069 +++++ contrib/lisp/org-e-groff.el | 2090 +++++++++ contrib/lisp/org-e-html.el | 3044 +++++++++++++ contrib/lisp/org-e-latex.el | 2726 ++++++++++++ contrib/lisp/org-e-man.el | 1363 ++++++ contrib/lisp/org-e-odt.el | 3762 ++++++++++++++++ contrib/lisp/org-e-publish.el | 1200 ++++++ contrib/lisp/org-e-texinfo.el | 1844 ++++++++ contrib/lisp/org-elisp-symbol.el | 161 + contrib/lisp/org-eval-light.el | 201 + contrib/lisp/org-eval.el | 219 + contrib/lisp/org-exp-bibtex.el | 148 + contrib/lisp/org-expiry.el | 361 ++ contrib/lisp/org-export-generic.el | 1504 +++++++ contrib/lisp/org-export.el | 4518 ++++++++++++++++++++ contrib/lisp/org-git-link.el | 220 + contrib/lisp/org-interactive-query.el | 312 ++ contrib/lisp/org-invoice.el | 401 ++ contrib/lisp/org-jira.el | 65 + contrib/lisp/org-learn.el | 177 + contrib/lisp/org-mac-iCal.el | 251 ++ contrib/lisp/org-mac-link-grabber.el | 467 ++ contrib/lisp/org-mairix.el | 332 ++ contrib/lisp/org-man.el | 64 + contrib/lisp/org-md.el | 461 ++ contrib/lisp/org-mime.el | 336 ++ contrib/lisp/org-mtags.el | 257 ++ contrib/lisp/org-notify.el | 377 ++ contrib/lisp/org-notmuch.el | 105 + contrib/lisp/org-panel.el | 641 +++ contrib/lisp/org-registry.el | 271 ++ contrib/lisp/org-screen.el | 108 + contrib/lisp/org-secretary.el | 232 + contrib/lisp/org-static-mathjax.el | 171 + contrib/lisp/org-sudoku.el | 290 ++ contrib/lisp/org-toc.el | 488 +++ contrib/lisp/org-track.el | 219 + contrib/lisp/org-velocity.el | 724 ++++ contrib/lisp/org-wikinodes.el | 340 ++ contrib/lisp/org2rem.el | 651 +++ contrib/lisp/orgtbl-sqlinsert.el | 116 + contrib/scripts/.gitignore | 1 + contrib/scripts/StartOzServer.oz | 231 + contrib/scripts/dir2org.zsh | 54 + contrib/scripts/docco.css | 185 + contrib/scripts/org-docco.org | 206 + contrib/scripts/org2hpda | 106 + contrib/scripts/staticmathjax/.gitignore | 1 + contrib/scripts/staticmathjax/README.org | 79 + contrib/scripts/staticmathjax/application.ini | 11 + .../scripts/staticmathjax/chrome/chrome.manifest | 1 + .../scripts/staticmathjax/chrome/content/main.js | 198 + .../scripts/staticmathjax/chrome/content/main.xul | 11 + .../staticmathjax/defaults/preferences/prefs.js | 1 + 70 files changed, 43379 insertions(+) create mode 100644 contrib/README create mode 100644 contrib/babel/langs/ob-fomus.el create mode 100644 contrib/babel/langs/ob-oz.el create mode 100644 contrib/babel/library-of-babel.org create mode 100644 contrib/lisp/htmlize.el create mode 100644 contrib/lisp/org-annotate-file.el create mode 100644 contrib/lisp/org-bibtex-extras.el create mode 100644 contrib/lisp/org-bookmark.el create mode 100644 contrib/lisp/org-checklist.el create mode 100644 contrib/lisp/org-choose.el create mode 100644 contrib/lisp/org-collector.el create mode 100644 contrib/lisp/org-contacts.el create mode 100644 contrib/lisp/org-contribdir.el create mode 100644 contrib/lisp/org-depend.el create mode 100644 contrib/lisp/org-drill.el create mode 100644 contrib/lisp/org-e-ascii.el create mode 100644 contrib/lisp/org-e-beamer.el create mode 100644 contrib/lisp/org-e-groff.el create mode 100644 contrib/lisp/org-e-html.el create mode 100644 contrib/lisp/org-e-latex.el create mode 100644 contrib/lisp/org-e-man.el create mode 100644 contrib/lisp/org-e-odt.el create mode 100644 contrib/lisp/org-e-publish.el create mode 100644 contrib/lisp/org-e-texinfo.el create mode 100644 contrib/lisp/org-elisp-symbol.el create mode 100644 contrib/lisp/org-eval-light.el create mode 100644 contrib/lisp/org-eval.el create mode 100644 contrib/lisp/org-exp-bibtex.el create mode 100644 contrib/lisp/org-expiry.el create mode 100644 contrib/lisp/org-export-generic.el create mode 100644 contrib/lisp/org-export.el create mode 100644 contrib/lisp/org-git-link.el create mode 100644 contrib/lisp/org-interactive-query.el create mode 100644 contrib/lisp/org-invoice.el create mode 100644 contrib/lisp/org-jira.el create mode 100644 contrib/lisp/org-learn.el create mode 100644 contrib/lisp/org-mac-iCal.el create mode 100644 contrib/lisp/org-mac-link-grabber.el create mode 100644 contrib/lisp/org-mairix.el create mode 100644 contrib/lisp/org-man.el create mode 100644 contrib/lisp/org-md.el create mode 100644 contrib/lisp/org-mime.el create mode 100644 contrib/lisp/org-mtags.el create mode 100644 contrib/lisp/org-notify.el create mode 100644 contrib/lisp/org-notmuch.el create mode 100644 contrib/lisp/org-panel.el create mode 100644 contrib/lisp/org-registry.el create mode 100644 contrib/lisp/org-screen.el create mode 100644 contrib/lisp/org-secretary.el create mode 100644 contrib/lisp/org-static-mathjax.el create mode 100644 contrib/lisp/org-sudoku.el create mode 100644 contrib/lisp/org-toc.el create mode 100644 contrib/lisp/org-track.el create mode 100644 contrib/lisp/org-velocity.el create mode 100644 contrib/lisp/org-wikinodes.el create mode 100644 contrib/lisp/org2rem.el create mode 100644 contrib/lisp/orgtbl-sqlinsert.el create mode 100644 contrib/scripts/.gitignore create mode 100644 contrib/scripts/StartOzServer.oz create mode 100755 contrib/scripts/dir2org.zsh create mode 100644 contrib/scripts/docco.css create mode 100644 contrib/scripts/org-docco.org create mode 100755 contrib/scripts/org2hpda create mode 100644 contrib/scripts/staticmathjax/.gitignore create mode 100644 contrib/scripts/staticmathjax/README.org create mode 100644 contrib/scripts/staticmathjax/application.ini create mode 100644 contrib/scripts/staticmathjax/chrome/chrome.manifest create mode 100644 contrib/scripts/staticmathjax/chrome/content/main.js create mode 100644 contrib/scripts/staticmathjax/chrome/content/main.xul create mode 100644 contrib/scripts/staticmathjax/defaults/preferences/prefs.js (limited to 'contrib') diff --git a/contrib/README b/contrib/README new file mode 100644 index 0000000..7f71ae9 --- /dev/null +++ b/contrib/README @@ -0,0 +1,96 @@ +This directory contains add-ons to Org-mode. + +These contributions are not part of GNU Emacs or of the official Org-mode +package. But the git repository for Org-mode is glad to provide useful way +to distribute and develop them as long as they are distributed under a free +software license. + +Please put your contribution in one of these directories: + +LISP (emacs-lisp code) +====================== +htmlize.el --- Convert buffer text and decorations to HTML +org2rem.el --- Convert org appointments into reminders +org-annotate-file.el --- Annotate a file with org syntax +org-bibtex-extras.el --- Extras for working with org-bibtex entries +org-bookmark.el --- Links to bookmarks +org-checklist.el --- org functions for checklist handling +org-choose.el --- Use TODO keywords to mark decision states +org-collector.el --- Collect properties into tables +org-contacts --- Contacts management +org-contribdir.el --- Dummy file to mark the org contrib Lisp directory +org-depend.el --- TODO dependencies for Org-mode +org-drill.el --- Self-testing with org-learn +org-element.el --- Parser and applications for Org syntax +org-elisp-symbol.el --- Org links to emacs-lisp symbols +org-eval.el --- The tag, adapted from Muse +org-eval-light.el --- Evaluate in-buffer code on demand +org-exp-bibtex.el --- Export citations to LaTeX and HTML +org-expiry.el --- Expiry mechanism for Org entries +org-export.el --- Generic Export Engine For Org +org-export-generic.el --- Export framework for configurable backends +org-git-link.el --- Provide org links to specific file version +org-interactive-query.el --- Interactive modification of tags query +org-invoice.el --- Help manage client invoices in OrgMode +org-jira.el --- Add a jira:ticket protocol to Org +org-learn.el --- SuperMemo's incremental learning algorithm +org-mac-iCal.el --- Imports events from iCal.app to the Emacs diary +org-mac-link-grabber.el --- Grab links and URLs from various Mac applications +org-mairix.el --- Hook mairix search into Org for different MUAs +org-man.el --- Support for links to manpages in Org-mode +org-mime.el --- org html export for text/html MIME emails +org-mtags.el --- Support for some Muse-like tags in Org-mode +org-notify.el --- Notifications for Org-mode +org-notmuch.el --- Support for links to notmuch messages +org-panel.el --- Simple routines for us with bad memory +org-registry.el --- A registry for Org links +org-screen.el --- Visit screen sessions through Org-mode links +org-secretary.el --- Team management with org-mode +org-static-mathjax.el --- Muse-like tags in Org-mode +org-sudoku.el --- Create and solve SUDOKU puzzles in Org tables +orgtbl-sqlinsert.el --- Convert Org-mode tables to SQL insertions +org-toc.el --- Table of contents for Org-mode buffer +org-track.el --- Keep up with Org development +org-velocity.el --- something like Notational Velocity for Org +org-wikinodes.el --- CamelCase wiki-like links for Org + + +EXPORT ENGINE AND BACKENDS (emacs-lisp code) +============================================ + +org-export.el --- the new export engine +org-e-latex.el --- LaTeX export backend +org-e-ascii.el --- ASCII export backend +org-e-beamer.el --- Beamer export backend +org-e-groff.el --- Groff export backend +org-e-html.el --- HTML export backend +org-e-man.el --- man pages export backend +org-e-odt.el --- ODT export backend +org-e-texinfo.el --- TeXinfo export backend +org-md.el --- MarkDown export backend + + +BABEL +===== +library-of-babel.org --- Documentation for the library of babel +langs/ob-fomus.el --- Org-babel functions for fomus evaluation +langs/ob-oz.el --- Org-babel functions for Oz evaluation + + +ODT (OpenDocumentText) +====================== +README.org --- Legacy documentation for Org ODT exporter + + +SCRIPTS (shell, bash, etc.) +=========================== + +dir2org.zsh --- Org compatible fs structure output +ditaa.jar --- ASCII to PNG converter by Stathis Sideris, GPL +org2hpda --- Generate hipster pda style printouts from Org-mode +org-docco.org --- docco side-by-side annotated code export to HTML +StartOzServer.oz --- implements the Oz-side of the Org-babel Oz interface +staticmathjax --- XULRunner application to process MathJax statically + +This directory also contains supporting files for the following +packages: ob-oz.el, org-docco.org, and org-static-mathjax.el. diff --git a/contrib/babel/langs/ob-fomus.el b/contrib/babel/langs/ob-fomus.el new file mode 100644 index 0000000..f7c6ca8 --- /dev/null +++ b/contrib/babel/langs/ob-fomus.el @@ -0,0 +1,93 @@ +;;; ob-fomus.el --- org-babel functions for fomus evaluation + +;; Copyright (C) 2011-2012 Torsten Anders + +;; Author: Torsten Anders +;; Keywords: literate programming, reproducible research +;; Homepage: http://orgmode.org +;; Version: + +;;; License: + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;; Org-Babel support for evaluating Fomus source code. +;; For information on Fomus see http://fomus.sourceforge.net/ +;; +;; This differs from most standard languages in that +;; +;; 1) there is no such thing as a "session" in fomus +;; +;; 2) we are generally only going to return results of type "file" +;; +;; 3) we are adding the "file" and "cmdline" header arguments +;; +;; 4) there are no variables (at least for now) + +;;; Code: +(require 'ob) +(require 'ob-eval) + +(defvar org-babel-default-header-args:fomus + '((:results . "file") (:exports . "results")) + "Default arguments to use when evaluating a fomus source block.") + +(defun org-babel-expand-body:fomus (body params) + "Expand BODY according to PARAMS, return the expanded body." + (let ((vars (mapcar #'cdr (org-babel-get-header params :var)))) + (mapc + (lambda (pair) + (let ((name (symbol-name (car pair))) + (value (cdr pair))) + (setq body + (replace-regexp-in-string + (concat "\$" (regexp-quote name)) + (if (stringp value) value (format "%S" value)) + body)))) + vars) + body)) + +(defun org-babel-execute:fomus (body params) + "Execute a block of Fomus code with org-babel. +This function is called by `org-babel-execute-src-block'." + (let* ((result-params (cdr (assoc :result-params params))) + (out-file (cdr (assoc :file params))) + (cmdline (cdr (assoc :cmdline params))) + (cmd (or (cdr (assoc :cmd params)) "fomus")) + (in-file (org-babel-temp-file "fomus-" ".fms"))) + (with-temp-file in-file + (insert (org-babel-expand-body:fomus body params))) + ;; TMP: testing + ;; (message (concat cmd + ;; " " (org-babel-process-file-name in-file) + ;; " " cmdline + ;; " -o " (org-babel-process-file-name out-file))) + (org-babel-eval + (concat cmd + " " (org-babel-process-file-name in-file) + " " cmdline + " -o " (org-babel-process-file-name out-file)) "") + nil)) ;; signal that output has already been written to file + +(defun org-babel-prep-session:fomus (session params) + "Return an error because Fomus does not support sessions." + (error "Fomus does not support sessions")) + +(provide 'ob-fomus) + +;;; ob-fomus.el ends here diff --git a/contrib/babel/langs/ob-oz.el b/contrib/babel/langs/ob-oz.el new file mode 100644 index 0000000..b778b4a --- /dev/null +++ b/contrib/babel/langs/ob-oz.el @@ -0,0 +1,294 @@ +;;; ob-oz.el --- org-babel functions for Oz evaluation + +;; Copyright (C) 2009-2012 Torsten Anders and Eric Schulte + +;; Author: Torsten Anders and Eric Schulte +;; Keywords: literate programming, reproducible research +;; Homepage: http://orgmode.org +;; Version: 0.02 + +;;; License: + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;; Org-Babel support for evaluating Oz source code. +;; +;; Oz code is always send to the Oz Programming Environment (OPI), the +;; Emacs mode and compiler interface for Oz programs. Therefore, only +;; session mode is supported. In practice, non-session code blocks are +;; handled equally well by the session mode. However, only a single +;; session is supported. Consequently, the :session header argument is +;; ignored. +;; +;; The Org-babel header argument :results is interpreted as +;; follows. :results output requires the respective code block to be +;; an Oz statement and :results value requires an Oz +;; expression. Currently, results are only supported for expressions +;; (i.e. the result of :results output is always nil). +;; +;; Expression evaluation happens synchronously. Therefore there is an +;; additional header argument :wait-time , which specifies the +;; maximum time to wait for the result of a given expression. nil +;; means to wait as long as it takes to get a result (potentially wait +;; forever). +;; +;; NOTE: Currently the copyright of this file may not be in a state to +;; permit inclusion as core software into Emacs or Org-mode. + +;;; Requirements: + +;; - Mozart Programming System, the implementation of the Oz +;; programming language (http://www.mozart-oz.org/), which includes +;; the major mode mozart for editing Oz programs. +;; +;; - StartOzServer.oz which is located in the contrib/scripts +;; directory of the Org-mode repository + +;;; TODO: + +;; - Decide: set communication to \\switch -threadedqueries? +;; +;; - Only start Oz compiler when required, e.g., load Org-babel only when needed? +;; +;; - Avoid synchronous evaluation to avoid blocking Emacs (complex +;; Strasheela programs can take long to find a result..). In order +;; to cleanly map code blocks to their associated results (which can +;; arrive then in any order) I could use IDs +;; (e.g. integers). However, how do I do concurrency in Emacs Lisp, +;; and how can I define org-babel-execute:oz concurrently. +;; +;; - Expressions are rarely used in Oz at the top-level, and using +;; them in documentation and Literate Programs will cause +;; confusion. Idea: hide expression from reader and instead show +;; them statement (e.g., MIDI output statement) and then include +;; result in Org file. Implementation: for expressions (:results +;; value) support an additional header argument that takes arbitrary +;; Oz code. This code is not seen by the reader, but will be used +;; for the actual expression at the end. Alternative: feed all +;; relevant code as statement (:results output), then add expression +;; as extra code block which outputs, e.g., file name (so the file +;; name must be accessible by global var), but the code of this +;; extra codeblock is not seen. Hm, in that case it might be even +;; more easy to manually add this link to the Org file. +;; + + +(require 'ob) +;;; major mode for editing Oz programs +(require 'mozart) + +;; +;; Interface to communicate with Oz. +;; (1) For statements without any results: oz-send-string +;; (2) For expressions with a single result: oz-send-string-expression +;; (defined in org-babel-oz-ResultsValue.el) +;; + +;; oz-send-string-expression implements an additional very direct +;; communication between Org-babel and the Oz compiler. Communication +;; with the Oz server works already without this code via the function +;; oz-send-string from mozart.el.in, but this function does not get +;; back any results from Oz to Emacs. The following code creates a +;; socket for sending code to the OPI compiler and results are +;; returned by the same socket. On the Oz side, a socket is opened and +;; conected to the compiler of the OPI (via oz-send-string). On the +;; Emacs side, a connection to this socket is created for feeding code +;; and receiving results. This additional communication channel to the +;; OPI compiler ensures that results are returned cleanly (e.g., only +;; the result of the sent code is returned, no parsing or any +;; processing of *Oz Emulator* is required). +;; +;; There is no buffer, nor sentinel involved. Oz code is send +;; directly, and results from Oz are send back, but Emacs Lisp +;; requires a filter function for processing results. + +(defvar org-babel-oz-server-dir + (file-name-as-directory + (expand-file-name + "contrib/scripts" + (file-name-as-directory + (expand-file-name + "../../.." + (file-name-directory (or load-file-name buffer-file-name)))))) + "Path to the contrib/scripts directory in which +StartOzServer.oz is located.") + +(defvar org-babel-oz-port 6001 + "Port for communicating with Oz compiler.") +(defvar org-babel-oz-OPI-socket nil + "Socket for communicating with OPI.") + +(defvar org-babel-oz-collected-result nil + "Aux var to hand result from org-babel-oz-filter to oz-send-string-expression.") +(defun org-babel-oz-filter (proc string) + "Processes output from socket org-babel-oz-OPI-socket." +;; (setq org-babel-oz-collected-results (cons string org-babel-oz-collected-results)) + (setq org-babel-oz-collected-result string) + ) + + +(defun org-babel-oz-create-socket () + (message "Create OPI socket for evaluating expressions") + ;; Start Oz directly + (run-oz) + ;; Create socket on Oz side (after Oz was started). + (oz-send-string (concat "\\insert '" org-babel-oz-server-dir "StartOzServer.oz'")) + ;; Wait until socket is created before connecting to it. + ;; Quick hack: wait 3 sec + ;; + ;; extending time to 30 secs does not help when starting Emacs for + ;; the first time (and computer does nothing else) + (sit-for 3) + ;; connect to OPI socket + (setq org-babel-oz-OPI-socket + ;; Creates a socket. I/O interface of Emacs sockets as for processes. + (open-network-stream "*Org-babel-OPI-socket*" nil "localhost" org-babel-oz-port)) + ;; install filter + (set-process-filter org-babel-oz-OPI-socket #'org-babel-oz-filter) +) + +;; communication with org-babel-oz-OPI-socket is asynchronous, but +;; oz-send-string-expression turns is into synchronous... +(defun oz-send-string-expression (string &optional wait-time) + "Similar to oz-send-string, oz-send-string-expression sends a string to the OPI compiler. However, string must be expression and this function returns the result of the expression (as string). oz-send-string-expression is synchronous, wait-time allows to specify a maximum wait time. After wait-time is over with no result, the function returns nil." + (if (not org-babel-oz-OPI-socket) + (org-babel-oz-create-socket)) + (let ((polling-delay 0.1) + result) + (process-send-string org-babel-oz-OPI-socket string) + ;; wait for result + (if wait-time + (let ((waited 0)) + (unwind-protect + (progn + (while + ;; stop loop if org-babel-oz-collected-result \= nil or waiting time is over + (not (or (not (equal org-babel-oz-collected-result nil)) + (> waited wait-time))) + (progn + (sit-for polling-delay) +;; (message "org-babel-oz: next polling iteration") + (setq waited (+ waited polling-delay)))) +;; (message "org-babel-oz: waiting over, got result or waiting timed out") +;; (message (format "wait-time: %s, waited: %s" wait-time waited)) + (setq result org-babel-oz-collected-result) + (setq org-babel-oz-collected-result nil)))) + (unwind-protect + (progn + (while (equal org-babel-oz-collected-result nil) + (sit-for polling-delay)) + (setq result org-babel-oz-collected-result) + (setq org-babel-oz-collected-result nil)))) + result)) + +(defun org-babel-expand-body:oz (body params) + (let ((vars (mapcar #'cdr (org-babel-get-header params :var)))) + (if vars + ;; prepend code to define all arguments passed to the code block + (let ((var-string (mapcar (lambda (pair) + (format "%s=%s" + (car pair) + (org-babel-oz-var-to-oz (cdr pair)))) + vars))) + ;; only add var declarations if any variables are there + (mapconcat #'identity + (append (list "local") var-string (list "in" body "end")) + "\n")) + body))) + +(defun org-babel-execute:oz (body params) + "Execute a block of Oz code with org-babel. This function is +called by `org-babel-execute-src-block' via multiple-value-bind." + (let* ((result-params (cdr (assoc :result-params params))) + (full-body (org-babel-expand-body:oz body params)) + (wait-time (plist-get params :wait-time))) + ;; actually execute the source-code block + (org-babel-reassemble-table + (cond + ((member "output" result-params) + (message "Org-babel: executing Oz statement") + (oz-send-string full-body)) + ((member "value" result-params) + (message "Org-babel: executing Oz expression") + (oz-send-string-expression full-body (or wait-time 1))) + (t (error "either 'output' or 'results' must be members of :results."))) + (org-babel-pick-name (cdr (assoc :colname-names params)) + (cdr (assoc :colnames params))) + (org-babel-pick-name (cdr (assoc :roname-names params)) + (cdr (assoc :rownames params)))))) + +;; This function should be used to assign any variables in params in +;; the context of the session environment. +(defun org-babel-prep-session:oz (session params) + "Prepare SESSION according to the header arguments specified in PARAMS." + (error "org-babel-prep-session:oz unimplemented")) +;; TODO: testing... (copied from org-babel-haskell.el) +;; (defun org-babel-prep-session:oz (session params) +;; "Prepare SESSION according to the header arguments specified in PARAMS." +;; (save-window-excursion +;; (org-babel-oz-initiate-session session) +;; (let* ((vars (org-babel-ref-variables params)) +;; (var-lines (mapconcat ;; define any variables +;; (lambda (pair) +;; (format "%s=%s" +;; (car pair) +;; (org-babel-ruby-var-to-ruby (cdr pair)))) +;; vars "\n")) +;; (vars-file (concat (make-temp-file "org-babel-oz-vars") ".oz"))) +;; (when vars +;; (with-temp-buffer +;; (insert var-lines) (write-file vars-file) +;; (oz-mode) +;; ;; (inferior-oz-load-file) ; ?? +;; )) +;; (current-buffer)))) +;; + + +;; TODO: testing... (simplified version of def in org-babel-prep-session:ocaml) +;; +;; BUG: does not work yet. Error: ad-Orig-error: buffer none doesn't exist or has no process +;; UNUSED DEF +(defun org-babel-oz-initiate-session (&optional session params) + "If there is not a current inferior-process-buffer in SESSION +then create. Return the initialized session." + (unless (string= session "none") + ;; TODO: make it possible to have multiple sessions + (save-window-excursion + ;; (run-oz) + (get-buffer oz-compiler-buffer)))) + +(defun org-babel-oz-var-to-oz (var) + "Convert an elisp var into a string of Oz source code +specifying a var of the same value." + (if (listp var) +;; (concat "[" (mapconcat #'org-babel-oz-var-to-oz var ", ") "]") + (eval var) + (format "%s" var) ; don't preserve string quotes. +;; (format "%s" var) + )) + +;; TODO: +(defun org-babel-oz-table-or-string (results) + "If the results look like a table, then convert them into an +Emacs-lisp table, otherwise return the results as a string." + (error "org-babel-oz-table-or-string unimplemented")) + + +(provide 'ob-oz) +;;; org-babel-oz.el ends here diff --git a/contrib/babel/library-of-babel.org b/contrib/babel/library-of-babel.org new file mode 100644 index 0000000..0098e72 --- /dev/null +++ b/contrib/babel/library-of-babel.org @@ -0,0 +1,584 @@ +#+title: The Library of Babel +#+author: Org-mode People +#+STARTUP: hideblocks + +* Introduction + +The Library of Babel is an extensible collection of ready-made and +easily-shortcut-callable source-code blocks for handling common tasks. +Org-babel comes pre-populated with the source-code blocks located in +this file. It is possible to add source-code blocks from any org-mode +file to the library by calling =(org-babel-lob-ingest +"path/to/file.org")=. + +This file is included in worg mainly less for viewing through the web +interface, and more for contribution through the worg git repository. +If you have code snippets that you think others may find useful please +add them to this file and [[file:~/src/worg/worg-git.org::contribute-to-worg][contribute them]] to worg. + +The raw Org-mode text of this file can be downloaded at +[[repofile:contrib/babel/library-of-babel.org][library-of-babel.org]] + +* Simple + +A collection of simple utility functions: + +#+name: echo +#+begin_src emacs-lisp :var input="echo'd" + input +#+end_src + +* File I/O + +** Reading and writing files + +Read the contents of the file at =file=. The =:results vector= and +=:results scalar= header arguments can be used to read the contents of +file as either a table or a string. + +#+name: read +#+begin_src emacs-lisp :var file="" :var format="" + (if (string= format "csv") + (with-temp-buffer + (org-table-import (expand-file-name file) nil) + (org-table-to-lisp)) + (with-temp-buffer + (insert-file-contents (expand-file-name file)) + (buffer-string))) +#+end_src + +Write =data= to a file at =file=. If =data= is a list, then write it +as a table in traditional Org-mode table syntax. + +#+name: write +#+begin_src emacs-lisp :var data="" :var file="" :var ext='() + (flet ((echo (r) (if (stringp r) r (format "%S" r)))) + (with-temp-file file + (case (and (listp data) + (or ext (intern (file-name-extension file)))) + ('tsv (insert (orgtbl-to-tsv data '(:fmt echo)))) + ('csv (insert (orgtbl-to-csv data '(:fmt echo)))) + (t (org-babel-insert-result data))))) + nil +#+end_src + +** Remote files + +*** json + +Read local or remote file in [[http://www.json.org/][json]] format into emacs-lisp objects. + +#+name: json +#+begin_src emacs-lisp :var file='() :var url='() + (require 'json) + (cond + (file + (with-temp-filebuffer file + (goto-char (point-min)) + (json-read))) + (url + (require 'w3m) + (with-temp-buffer + (w3m-retrieve url) + (goto-char (point-min)) + (json-read)))) +#+end_src + +*** Google docs + +The following code blocks make use of the [[http://code.google.com/p/googlecl/][googlecl]] Google command line +tool. This tool provides functionality for accessing Google services +from the command line, and the following code blocks use /googlecl/ +for reading from and writing to Google docs with Org-mode code blocks. + +**** Read a document from Google docs + +The =google= command seems to be throwing "Moved Temporarily" errors +when trying to download textual documents, but this is working fine +for spreadsheets. + +#+name: gdoc-read +#+begin_src emacs-lisp :var title="example" :var format="csv" + (let* ((file (concat title "." format)) + (cmd (format "google docs get --format %S --title %S" format title))) + (message cmd) (message (shell-command-to-string cmd)) + (prog1 (if (string= format "csv") + (with-temp-buffer + (org-table-import (shell-quote-argument file) '(4)) + (org-table-to-lisp)) + (with-temp-buffer + (insert-file-contents (shell-quote-argument file)) + (buffer-string))) + (delete-file file))) +#+end_src + +For example, a line like the following can be used to read the +contents of a spreadsheet named =num-cells= into a table. +: #+call: gdoc-read(title="num-cells"") + +A line like the following can be used to read the contents of a +document as a string. + +: #+call: gdoc-read(title="loremi", :format "txt") + +**** Write a document to a Google docs + +Write =data= to a google document named =title=. If =data= is tabular +it will be saved to a spreadsheet, otherwise it will be saved as a +normal document. + +#+name: gdoc-write +#+begin_src emacs-lisp :var title="babel-upload" :var data=fibs(n=10) :results silent + (let* ((format (if (listp data) "csv" "txt")) + (tmp-file (make-temp-file "org-babel-google-doc" nil (concat "." format))) + (cmd (format "google docs upload --title %S %S" title tmp-file))) + (with-temp-file tmp-file + (insert + (if (listp data) + (orgtbl-to-csv + data '(:fmt (lambda (el) (if (stringp el) el (format "%S" el))))) + (if (stringp data) data (format "%S" data))))) + (message cmd) + (prog1 (shell-command-to-string cmd) (delete-file tmp-file))) +#+end_src + +example usage +: #+name: fibs +: #+begin_src emacs-lisp :var n=8 +: (flet ((fib (m) (if (< m 2) 1 (+ (fib (- m 1)) (fib (- m 2)))))) +: (mapcar (lambda (el) (list el (fib el))) (number-sequence 0 (- n 1)))) +: #+end_src +: +: #+call: gdoc-write(title="fibs", data=fibs(n=10)) + +* Plotting code + +** R + +Plot column 2 (y axis) against column 1 (x axis). Columns 3 and +beyond, if present, are ignored. + +#+name: R-plot +#+begin_src R :var data=R-plot-example-data +plot(data) +#+end_src + +#+tblname: R-plot-example-data +| 1 | 2 | +| 2 | 4 | +| 3 | 9 | +| 4 | 16 | +| 5 | 25 | + +#+call: R-plot(data=R-plot-example-data) + +#+resname: R-plot(data=R-plot-example-data) +: nil + +** Gnuplot + +* Org reference + +** Headline references + +#+name: headline +#+begin_src emacs-lisp :var headline=top :var file='() + (save-excursion + (when file (get-file-buffer file)) + (org-open-link-from-string (org-make-link-string headline)) + (save-restriction + (org-narrow-to-subtree) + (buffer-string))) +#+end_src + +#+call: headline(headline="headline references") + +* Tables + +** LaTeX Table Export + +*** booktabs + +This source block can be used to wrap a table in the latex =booktabs= +environment. The source block adds a =toprule= and =bottomrule= (so +don't use =hline= at the top or bottom of the table). The =hline= +after the header is replaced with a =midrule=. + +Note that this function bypasses the Org-mode LaTeX exporter and calls +=orgtbl-to-generic= to create the output table. This means that the +entries in the table are not translated from Org-mode to LaTeX. + +It takes the following arguments -- all but the first two are +optional. + +| arg | description | +|-------+--------------------------------------------| +| table | a reference to the table | +| align | alignment string | +| env | optional environment, default to "tabular" | +| width | optional width specification string | + +#+name: booktabs +#+begin_src emacs-lisp :var table='((:head) hline (:body)) :var align='() :var env="tabular" :var width='() :noweb yes :results latex + (flet ((to-tab (tab) + (orgtbl-to-generic + (mapcar (lambda (lis) + (if (listp lis) + (mapcar (lambda (el) + (if (stringp el) + el + (format "%S" el))) lis) + lis)) tab) + (list :lend " \\\\" :sep " & " :hline "\\hline")))) + (org-fill-template + " + \\begin{%env}%width%align + \\toprule + %table + \\bottomrule + \\end{%env}\n" + (list + (cons "env" (or env "table")) + (cons "width" (if width (format "{%s}" width) "")) + (cons "align" (if align (format "{%s}" align) "")) + (cons "table" + ;; only use \midrule if it looks like there are column headers + (if (equal 'hline (second table)) + (concat (to-tab (list (first table))) + "\n\\midrule\n" + (to-tab (cddr table))) + (to-tab table)))))) +#+end_src + +*** longtable + +This block can be used to wrap a table in the latex =longtable= +environment, it takes the following arguments -- all but the first two +are optional. + +| arg | description | +|-----------+-------------------------------------------------------------| +| table | a reference to the table | +| align | optional alignment string | +| width | optional width specification string | +| hline | the string to use as hline separator, defaults to "\\hline" | +| head | optional "head" string | +| firsthead | optional "firsthead" string | +| foot | optional "foot" string | +| lastfoot | optional "lastfoot" string | + +#+name: longtable +#+begin_src emacs-lisp :var table='((:table)) :var align='() :var width='() :var hline="\\hline" :var firsthead='() :var head='() :var foot='() :var lastfoot='() :noweb yes :results latex + (org-fill-template + " + \\begin{longtable}%width%align + %firsthead + %head + %foot + %lastfoot + + %table + \\end{longtable}\n" + (list + (cons "width" (if width (format "{%s}" width) "")) + (cons "align" (if align (format "{%s}" align) "")) + (cons "firsthead" (if firsthead (concat firsthead "\n\\endfirsthead\n") "")) + (cons "head" (if head (concat head "\n\\endhead\n") "")) + (cons "foot" (if foot (concat foot "\n\\endfoot\n") "")) + (cons "lastfoot" (if lastfoot (concat lastfoot "\n\\endlastfoot\n") "")) + (cons "table" (orgtbl-to-generic + (mapcar (lambda (lis) + (if (listp lis) + (mapcar (lambda (el) + (if (stringp el) + el + (format "%S" el))) lis) + lis)) table) + (list :lend " \\\\" :sep " & " :hline hline))))) +#+end_src + +*** booktabs-notes + +This source block builds on [[booktabs]]. It accepts two additional +arguments, both of which are optional. + +#+tblname: arguments +| arg | description | +|--------+------------------------------------------------------| +| notes | an org-mode table with footnotes | +| lspace | if non-nil, insert =addlinespace= after =bottomrule= | + +An example footnote to the =arguments= table specifies the column +span. Note the use of LaTeX, rather than Org-mode, markup. + +#+tblname: arguments-notes +| \multicolumn{2}{l}{This is a footnote to the \emph{arguments} table.} | + +#+name: booktabs-notes +#+begin_src emacs-lisp :var table='((:head) hline (:body)) :var notes='() :var align='() :var env="tabular" :var width='() :var lspace='() :noweb yes :results latex + (flet ((to-tab (tab) + (orgtbl-to-generic + (mapcar (lambda (lis) + (if (listp lis) + (mapcar (lambda (el) + (if (stringp el) + el + (format "%S" el))) lis) + lis)) tab) + (list :lend " \\\\" :sep " & " :hline "\\hline")))) + (org-fill-template + " + \\begin{%env}%width%align + \\toprule + %table + \\bottomrule%spacer + %notes + \\end{%env}\n" + (list + (cons "env" (or env "table")) + (cons "width" (if width (format "{%s}" width) "")) + (cons "align" (if align (format "{%s}" align) "")) + (cons "spacer" (if lspace "\\addlinespace" "")) + (cons "table" + ;; only use \midrule if it looks like there are column headers + (if (equal 'hline (second table)) + (concat (to-tab (list (first table))) + "\n\\midrule\n" + (to-tab (cddr table))) + (to-tab table))) + (cons "notes" (if notes (to-tab notes) "")) + ))) +#+end_src + +** Elegant lisp for transposing a matrix + +#+tblname: transpose-example +| 1 | 2 | 3 | +| 4 | 5 | 6 | + +#+name: transpose +#+begin_src emacs-lisp :var table=transpose-example + (apply #'mapcar* #'list table) +#+end_src + +#+resname: +| 1 | 4 | +| 2 | 5 | +| 3 | 6 | + +** Convert every element of a table to a string + +#+tblname: hetero-table +| 1 | 2 | 3 | +| a | b | c | + +#+name: all-to-string +#+begin_src emacs-lisp :var tbl='() + (defun all-to-string (tbl) + (if (listp tbl) + (mapcar #'all-to-string tbl) + (if (stringp tbl) + tbl + (format "%s" tbl)))) + (all-to-string tbl) +#+end_src + +#+begin_src emacs-lisp :var tbl=hetero-table + (mapcar (lambda (row) (mapcar (lambda (cell) (stringp cell)) row)) tbl) +#+end_src + +#+name: +| nil | nil | nil | +| t | t | t | + +#+begin_src emacs-lisp :var tbl=all-to-string(hetero-table) + (mapcar (lambda (row) (mapcar (lambda (cell) (stringp cell)) row)) tbl) +#+end_src + +#+name: +| t | t | t | +| t | t | t | + +* Misc + +** File-specific Version Control logging + :PROPERTIES: + :AUTHOR: Luke Crook + :END: + +This function will attempt to retrieve the entire commit log for the +file associated with the current buffer and insert this log into the +export. The function uses the Emacs VC commands to interface to the +local version control system, but has only been tested to work with +Git. 'limit' is currently unsupported. + +#+name: vc-log +#+headers: :var limit=-1 +#+headers: :var buf=(buffer-name (current-buffer)) +#+begin_src emacs-lisp + ;; Most of this code is copied from vc.el vc-print-log + (require 'vc) + (when (vc-find-backend-function + (vc-backend (buffer-file-name (get-buffer buf))) 'print-log) + (let ((limit -1) + (vc-fileset nil) + (backend nil) + (files nil)) + (with-current-buffer (get-buffer buf) + (setq vc-fileset (vc-deduce-fileset t)) ; FIXME: Why t? --Stef + (setq backend (car vc-fileset)) + (setq files (cadr vc-fileset))) + (with-temp-buffer + (let ((status (vc-call-backend + backend 'print-log files (current-buffer)))) + (when (and (processp status) ; Make sure status is a process + (= 0 (process-exit-status status))) ; which has not terminated + (while (not (eq 'exit (process-status status))) + (sit-for 1 t))) + (buffer-string))))) +#+end_src + +** Trivial python code blocks + +#+name: python-identity +#+begin_src python :var a=1 +a +#+end_src + +#+name: python-add +#+begin_src python :var a=1 :var b=2 +a + b +#+end_src + +** Arithmetic + +#+name: lob-add +#+begin_src emacs-lisp :var a=0 :var b=0 + (+ a b) +#+end_src + +#+name: lob-minus +#+begin_src emacs-lisp :var a=0 :var b=0 + (- a b) +#+end_src + +#+name: lob-times +#+begin_src emacs-lisp :var a=0 :var b=0 + (* a b) +#+end_src + +#+name: lob-div +#+begin_src emacs-lisp :var a=0 :var b=0 + (/ a b) +#+end_src + +* GANTT Charts + +The =elispgantt= source block was sent to the mailing list by Eric +Fraga. It was modified slightly by Tom Dye. + +#+name: elispgantt +#+begin_src emacs-lisp :var table=gantttest + (let ((dates "") + (entries (nthcdr 2 table)) + (milestones "") + (nmilestones 0) + (ntasks 0) + (projecttime 0) + (tasks "") + (xlength 1)) + (message "Initial: %s\n" table) + (message "Entries: %s\n" entries) + (while entries + (let ((entry (first entries))) + (if (listp entry) + (let ((id (first entry)) + (type (nth 1 entry)) + (label (nth 2 entry)) + (task (nth 3 entry)) + (dependencies (nth 4 entry)) + (start (nth 5 entry)) + (duration (nth 6 entry)) + (end (nth 7 entry)) + (alignment (nth 8 entry))) + (if (> start projecttime) (setq projecttime start)) + (if (string= type "task") + (let ((end (+ start duration)) + (textposition (+ start (/ duration 2))) + (flush "")) + (if (string= alignment "left") + (progn + (setq textposition start) + (setq flush "[left]")) + (if (string= alignment "right") + (progn + (setq textposition end) + (setq flush "[right]")))) + (setq tasks + (format "%s \\gantttask{%s}{%s}{%d}{%d}{%d}{%s}\n" + tasks label task start end textposition flush)) + (setq ntasks (+ 1 ntasks)) + (if (> end projecttime) + (setq projecttime end))) + (if (string= type "milestone") + (progn + (setq milestones + (format + "%s \\ganttmilestone{$\\begin{array}{c}\\mbox{%s}\\\\ \\mbox{%s}\\end{array}$}{%d}\n" + milestones label task start)) + (setq nmilestones (+ 1 nmilestones))) + (if (string= type "date") + (setq dates (format "%s \\ganttdateline{%s}{%d}\n" + dates label start)) + (message "Ignoring entry with type %s\n" type))))) + (message "Ignoring non-list entry %s\n" entry)) ; end if list entry + (setq entries (cdr entries)))) ; end while entries left + (format "\\pgfdeclarelayer{background} + \\pgfdeclarelayer{foreground} + \\pgfsetlayers{background,foreground} + \\renewcommand{\\ganttprojecttime}{%d} + \\renewcommand{\\ganttntasks}{%d} + \\noindent + \\begin{tikzpicture}[y=-0.75cm,x=0.75\\textwidth] + \\begin{pgfonlayer}{background} + \\draw[very thin, red!10!white] (0,1+\\ganttntasks) grid [ystep=0.75cm,xstep=1/\\ganttprojecttime] (1,0); + \\draw[\\ganttdatelinecolour] (0,0) -- (1,0); + \\draw[\\ganttdatelinecolour] (0,1+\\ganttntasks) -- (1,1+\\ganttntasks); + \\end{pgfonlayer} + %s + %s + %s + \\end{tikzpicture}" projecttime ntasks tasks milestones dates)) +#+end_src + +* Available languages + :PROPERTIES: + :AUTHOR: Bastien + :END: + +** From Org's core + +| Language | Identifier | Language | Identifier | +|------------+------------+----------------+------------| +| Asymptote | asymptote | Awk | awk | +| Emacs Calc | calc | C | C | +| C++ | C++ | Clojure | clojure | +| CSS | css | ditaa | ditaa | +| Graphviz | dot | Emacs Lisp | emacs-lisp | +| gnuplot | gnuplot | Haskell | haskell | +| Javascript | js | LaTeX | latex | +| Ledger | ledger | Lisp | lisp | +| Lilypond | lilypond | MATLAB | matlab | +| Mscgen | mscgen | Objective Caml | ocaml | +| Octave | octave | Org-mode | org | +| | | Perl | perl | +| Plantuml | plantuml | Python | python | +| R | R | Ruby | ruby | +| Sass | sass | Scheme | scheme | +| GNU Screen | screen | shell | sh | +| SQL | sql | SQLite | sqlite | + +** From Org's contrib/babel/langs + +- ob-oz.el, by Torsten Anders and Eric Schulte +- ob-fomus.el, by Torsten Anders diff --git a/contrib/lisp/htmlize.el b/contrib/lisp/htmlize.el new file mode 100644 index 0000000..516fb1d --- /dev/null +++ b/contrib/lisp/htmlize.el @@ -0,0 +1,1769 @@ +;; htmlize.el -- Convert buffer text and decorations to HTML. + +;; Copyright (C) 1997-2012 Hrvoje Niksic + +;; Author: Hrvoje Niksic +;; Keywords: hypermedia, extensions + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; This package converts the buffer text and the associated +;; decorations to HTML. Mail to to discuss +;; features and additions. All suggestions are more than welcome. + +;; To use this, just switch to the buffer you want HTML-ized and type +;; `M-x htmlize-buffer'. You will be switched to a new buffer that +;; contains the resulting HTML code. You can edit and inspect this +;; buffer, or you can just save it with C-x C-w. `M-x htmlize-file' +;; will find a file, fontify it, and save the HTML version in +;; FILE.html, without any additional intervention. `M-x +;; htmlize-many-files' allows you to htmlize any number of files in +;; the same manner. `M-x htmlize-many-files-dired' does the same for +;; files marked in a dired buffer. + +;; htmlize supports three types of HTML output, selected by setting +;; `htmlize-output-type': `css', `inline-css', and `font'. In `css' +;; mode, htmlize uses cascading style sheets to specify colors; it +;; generates classes that correspond to Emacs faces and uses ... to color parts of text. In this mode, the +;; produced HTML is valid under the 4.01 strict DTD, as confirmed by +;; the W3C validator. `inline-css' is like `css', except the CSS is +;; put directly in the STYLE attribute of the SPAN element, making it +;; possible to paste the generated HTML to other documents. In `font' +;; mode, htmlize uses ... to colorize HTML, +;; which is not standard-compliant, but works better in older +;; browsers. `css' mode is the default. + +;; You can also use htmlize from your Emacs Lisp code. When called +;; non-interactively, `htmlize-buffer' and `htmlize-region' will +;; return the resulting HTML buffer, but will not change current +;; buffer or move the point. + +;; I tried to make the package elisp-compatible with multiple Emacsen, +;; specifically aiming for XEmacs 19.14+ and GNU Emacs 19.34+. Please +;; let me know if it doesn't work on some of those, and I'll try to +;; fix it. I relied heavily on the presence of CL extensions, +;; especially for cross-emacs compatibility; please don't try to +;; remove that particular dependency. When byte-compiling under GNU +;; Emacs, you're likely to get some warnings; just ignore them. + +;; The latest version should be available at: +;; +;; +;; +;; You can find a sample of htmlize's output (possibly generated with +;; an older version) at: +;; +;; + +;; Thanks go to the multitudes of people who have sent reports and +;; contributed comments, suggestions, and fixes. They include Ron +;; Gut, Bob Weiner, Toni Drabik, Peter Breton, Thomas Vogels, Juri +;; Linkov, Maciek Pasternacki, and many others. + +;; User quotes: "You sir, are a sick, sick, _sick_ person. :)" +;; -- Bill Perry, author of Emacs/W3 + + +;;; Code: + +(require 'cl) +(eval-when-compile + (if (string-match "XEmacs" emacs-version) + (byte-compiler-options + (warnings (- unresolved)))) + (defvar font-lock-auto-fontify) + (defvar font-lock-support-mode) + (defvar global-font-lock-mode) + (when (and (eq emacs-major-version 19) + (not (string-match "XEmacs" emacs-version))) + ;; Older versions of GNU Emacs fail to autoload cl-extra even when + ;; `cl' is loaded. + (load "cl-extra"))) + +(defconst htmlize-version "1.36") + +;; Incantations to make custom stuff work without customize, e.g. on +;; XEmacs 19.14 or GNU Emacs 19.34. +(eval-and-compile + (condition-case () + (require 'custom) + (error nil)) + (if (and (featurep 'custom) (fboundp 'custom-declare-variable)) + nil ; we've got what we needed + ;; No custom or obsolete custom, define surrogates. Define all + ;; three macros, so we don't hose another library that expects + ;; e.g. `defface' to work after (fboundp 'defcustom) succeeds. + (defmacro defgroup (&rest ignored) nil) + (defmacro defcustom (var value doc &rest ignored) + `(defvar ,var ,value ,doc)) + (defmacro defface (face value doc &rest stuff) + `(make-face ,face)))) + +(defgroup htmlize nil + "Convert buffer text and faces to HTML." + :group 'hypermedia) + +(defcustom htmlize-head-tags "" + "*Additional tags to insert within HEAD of the generated document." + :type 'string + :group 'htmlize) + +(defcustom htmlize-output-type 'css + "*Output type of generated HTML, one of `css', `inline-css', or `font'. +When set to `css' (the default), htmlize will generate a style sheet +with description of faces, and use it in the HTML document, specifying +the faces in the actual text with . + +When set to `inline-css', the style will be generated as above, but +placed directly in the STYLE attribute of the span ELEMENT: . This makes it easier to paste the resulting HTML to +other documents. + +When set to `font', the properties will be set using layout tags +, , , , and . + +`css' output is normally preferred, but `font' is still useful for +supporting old, pre-CSS browsers, and both `inline-css' and `font' for +easier embedding of colorized text in foreign HTML documents (no style +sheet to carry around)." + :type '(choice (const css) (const inline-css) (const font)) + :group 'htmlize) + +(defcustom htmlize-generate-hyperlinks t + "*Non-nil means generate the hyperlinks for URLs and mail addresses. +This is on by default; set it to nil if you don't want htmlize to +insert hyperlinks in the resulting HTML. (In which case you can still +do your own hyperlinkification from htmlize-after-hook.)" + :type 'boolean + :group 'htmlize) + +(defcustom htmlize-hyperlink-style " + a { + color: inherit; + background-color: inherit; + font: inherit; + text-decoration: inherit; + } + a:hover { + text-decoration: underline; + } +" + "*The CSS style used for hyperlinks when in CSS mode." + :type 'string + :group 'htmlize) + +(defcustom htmlize-replace-form-feeds t + "*Non-nil means replace form feeds in source code with HTML separators. +Form feeds are the ^L characters at line beginnings that are sometimes +used to separate sections of source code. If this variable is set to +`t', form feed characters are replaced with the
separator. If this +is a string, it specifies the replacement to use. Note that
 is
+temporarily closed before the separator is inserted, so the default
+replacement is effectively \"

\".  If you specify
+another replacement, don't forget to close and reopen the 
 if you
+want the output to remain valid HTML.
+
+If you need more elaborate processing, set this to nil and use
+htmlize-after-hook."
+  :type 'boolean
+  :group 'htmlize)
+
+(defcustom htmlize-html-charset nil
+  "*The charset declared by the resulting HTML documents.
+When non-nil, causes htmlize to insert the following in the HEAD section
+of the generated HTML:
+
+  
+
+where CHARSET is the value you've set for htmlize-html-charset.  Valid
+charsets are defined by MIME and include strings like \"iso-8859-1\",
+\"iso-8859-15\", \"utf-8\", etc.
+
+If you are using non-Latin-1 charsets, you might need to set this for
+your documents to render correctly.  Also, the W3C validator requires
+submitted HTML documents to declare a charset.  So if you care about
+validation, you can use this to prevent the validator from bitching.
+
+Needless to say, if you set this, you should actually make sure that
+the buffer is in the encoding you're claiming it is in.  (Under Mule
+that is done by ensuring the correct \"file coding system\" for the
+buffer.)  If you don't understand what that means, this option is
+probably not for you."
+  :type '(choice (const :tag "Unset" nil)
+		 string)
+  :group 'htmlize)
+
+(defcustom htmlize-convert-nonascii-to-entities (featurep 'mule)
+  "*Whether non-ASCII characters should be converted to HTML entities.
+
+When this is non-nil, characters with codes in the 128-255 range will be
+considered Latin 1 and rewritten as \"&#CODE;\".  Characters with codes
+above 255 will be converted to \"&#UCS;\", where UCS denotes the Unicode
+code point of the character.  If the code point cannot be determined,
+the character will be copied unchanged, as would be the case if the
+option were nil.
+
+When the option is nil, the non-ASCII characters are copied to HTML
+without modification.  In that case, the web server and/or the browser
+must be set to understand the encoding that was used when saving the
+buffer.  (You might also want to specify it by setting
+`htmlize-html-charset'.)
+
+Note that in an HTML entity \"&#CODE;\", CODE is always a UCS code point,
+which has nothing to do with the charset the page is in.  For example,
+\"©\" *always* refers to the copyright symbol, regardless of charset
+specified by the META tag or the charset sent by the HTTP server.  In
+other words, \"©\" is exactly equivalent to \"©\".
+
+By default, entity conversion is turned on for Mule-enabled Emacsen and
+turned off otherwise.  This is because Mule knows the charset of
+non-ASCII characters in the buffer.  A non-Mule Emacs cannot tell
+whether a character with code 0xA9 represents Latin 1 copyright symbol,
+Latin 2 \"S with caron\", or something else altogether.  Setting this to
+t without Mule means asserting that 128-255 characters always mean Latin
+1.
+
+For most people htmlize will work fine with this option left at the
+default setting; don't change it unless you know what you're doing."
+  :type 'sexp
+  :group 'htmlize)
+
+(defcustom htmlize-ignore-face-size 'absolute
+  "*Whether face size should be ignored when generating HTML.
+If this is nil, face sizes are used.  If set to t, sizes are ignored
+If set to `absolute', only absolute size specifications are ignored.
+Please note that font sizes only work with CSS-based output types."
+  :type '(choice (const :tag "Don't ignore" nil)
+		 (const :tag "Ignore all" t)
+		 (const :tag "Ignore absolute" absolute))
+  :group 'htmlize)
+
+(defcustom htmlize-css-name-prefix ""
+  "*The prefix used for CSS names.
+The CSS names that htmlize generates from face names are often too
+generic for CSS files; for example, `font-lock-type-face' is transformed
+to `type'.  Use this variable to add a prefix to the generated names.
+The string \"htmlize-\" is an example of a reasonable prefix."
+  :type 'string
+  :group 'htmlize)
+
+(defcustom htmlize-use-rgb-txt t
+  "*Whether `rgb.txt' should be used to convert color names to RGB.
+
+This conversion means determining, for instance, that the color
+\"IndianRed\" corresponds to the (205, 92, 92) RGB triple.  `rgb.txt'
+is the X color database that maps hundreds of color names to such RGB
+triples.  When this variable is non-nil, `htmlize' uses `rgb.txt' to
+look up color names.
+
+If this variable is nil, htmlize queries Emacs for RGB components of
+colors using `color-instance-rgb-components' and `x-color-values'.
+This can yield incorrect results on non-true-color displays.
+
+If the `rgb.txt' file is not found (which will be the case if you're
+running Emacs on non-X11 systems), this option is ignored."
+  :type 'boolean
+  :group 'htmlize)
+
+(defcustom htmlize-html-major-mode nil
+  "The mode the newly created HTML buffer will be put in.
+Set this to nil if you prefer the default (fundamental) mode."
+  :type '(radio (const :tag "No mode (fundamental)" nil)
+		 (function-item html-mode)
+		 (function :tag "User-defined major mode"))
+  :group 'htmlize)
+
+(defvar htmlize-before-hook nil
+  "Hook run before htmlizing a buffer.
+The hook functions are run in the source buffer (not the resulting HTML
+buffer).")
+
+(defvar htmlize-after-hook nil
+  "Hook run after htmlizing a buffer.
+Unlike `htmlize-before-hook', these functions are run in the generated
+HTML buffer.  You may use them to modify the outlook of the final HTML
+output.")
+
+(defvar htmlize-file-hook nil
+  "Hook run by `htmlize-file' after htmlizing a file, but before saving it.")
+
+(defvar htmlize-buffer-places)
+
+;;; Some cross-Emacs compatibility.
+
+;; I try to conditionalize on features rather than Emacs version, but
+;; in some cases checking against the version *is* necessary.
+(defconst htmlize-running-xemacs (string-match "XEmacs" emacs-version))
+
+(eval-and-compile
+  ;; save-current-buffer, with-current-buffer, and with-temp-buffer
+  ;; are not available in 19.34 and in older XEmacsen.  Strictly
+  ;; speaking, we should stick to our own namespace and define and use
+  ;; htmlize-save-current-buffer, etc.  But non-standard special forms
+  ;; are a pain because they're not properly fontified or indented and
+  ;; because they look weird and ugly.  So I'll just go ahead and
+  ;; define the real ones if they're not available.  If someone
+  ;; convinces me that this breaks something, I'll switch to the
+  ;; "htmlize-" namespace.
+  (unless (fboundp 'save-current-buffer)
+    (defmacro save-current-buffer (&rest forms)
+      `(let ((__scb_current (current-buffer)))
+	 (unwind-protect
+	     (progn ,@forms)
+	   (set-buffer __scb_current)))))
+  (unless (fboundp 'with-current-buffer)
+    (defmacro with-current-buffer (buffer &rest forms)
+      `(save-current-buffer (set-buffer ,buffer) ,@forms)))
+  (unless (fboundp 'with-temp-buffer)
+    (defmacro with-temp-buffer (&rest forms)
+      (let ((temp-buffer (gensym "tb-")))
+	`(let ((,temp-buffer
+		(get-buffer-create (generate-new-buffer-name " *temp*"))))
+	   (unwind-protect
+	       (with-current-buffer ,temp-buffer
+		 ,@forms)
+	     (and (buffer-live-p ,temp-buffer)
+		  (kill-buffer ,temp-buffer))))))))
+
+;; We need a function that efficiently finds the next change of a
+;; property (usually `face'), preferably regardless of whether the
+;; change occurred because of a text property or an extent/overlay.
+;; As it turns out, it is not easy to do that compatibly.
+;;
+;; Under XEmacs, `next-single-property-change' does that.  Under GNU
+;; Emacs beginning with version 21, `next-single-char-property-change'
+;; is available and does the same.  GNU Emacs 20 had
+;; `next-char-property-change', which we can use.  GNU Emacs 19 didn't
+;; provide any means for simultaneously examining overlays and text
+;; properties, so when using Emacs 19.34, we punt and fall back to
+;; `next-single-property-change', thus ignoring overlays altogether.
+
+(cond
+ (htmlize-running-xemacs
+  ;; XEmacs: good.
+  (defun htmlize-next-change (pos prop &optional limit)
+    (next-single-property-change pos prop nil (or limit (point-max)))))
+ ((fboundp 'next-single-char-property-change)
+  ;; GNU Emacs 21: good.
+  (defun htmlize-next-change (pos prop &optional limit)
+    (next-single-char-property-change pos prop nil limit)))
+ ((fboundp 'next-char-property-change)
+  ;; GNU Emacs 20: bad, but fixable.
+  (defun htmlize-next-change (pos prop &optional limit)
+    (let ((done nil)
+	  (current-value (get-char-property pos prop))
+	  newpos next-value)
+      ;; Loop over positions returned by next-char-property-change
+      ;; until the value of PROP changes or we've hit EOB.
+      (while (not done)
+	(setq newpos (next-char-property-change pos limit)
+	      next-value (get-char-property newpos prop))
+	(cond ((eq newpos pos)
+	       ;; Possibly at EOB?  Whatever, just don't infloop.
+	       (setq done t))
+	      ((eq next-value current-value)
+	       ;; PROP hasn't changed -- keep looping.
+	       )
+	      (t
+	       (setq done t)))
+	(setq pos newpos))
+      pos)))
+ (t
+  ;; GNU Emacs 19.34: hopeless, cannot properly support overlays.
+  (defun htmlize-next-change (pos prop &optional limit)
+    (unless limit
+      (setq limit (point-max)))
+    (let ((res (next-single-property-change pos prop)))
+      (if (or (null res)
+	      (> res limit))
+	  limit
+	res)))))
+
+;;; Transformation of buffer text: HTML escapes, untabification, etc.
+
+(defvar htmlize-basic-character-table
+  ;; Map characters in the 0-127 range to either one-character strings
+  ;; or to numeric entities.
+  (let ((table (make-vector 128 ?\0)))
+    ;; Map characters in the 32-126 range to themselves, others to
+    ;; &#CODE entities;
+    (dotimes (i 128)
+      (setf (aref table i) (if (and (>= i 32) (<= i 126))
+			       (char-to-string i)
+			     (format "&#%d;" i))))
+    ;; Set exceptions manually.
+    (setf
+     ;; Don't escape newline, carriage return, and TAB.
+     (aref table ?\n) "\n"
+     (aref table ?\r) "\r"
+     (aref table ?\t) "\t"
+     ;; Escape &, <, and >.
+     (aref table ?&) "&"
+     (aref table ?<) "<"
+     (aref table ?>) ">"
+     ;; Not escaping '"' buys us a measurable speedup.  It's only
+     ;; necessary to quote it for strings used in attribute values,
+     ;; which htmlize doesn't do.
+     ;(aref table ?\") """
+     )
+    table))
+
+;; A cache of HTML representation of non-ASCII characters.  Depending
+;; on availability of `encode-char' and the setting of
+;; `htmlize-convert-nonascii-to-entities', this maps non-ASCII
+;; characters to either "&#;" or "" (mapconcat's mapper
+;; must always return strings).  It's only filled as characters are
+;; encountered, so that in a buffer with e.g. French text, it will
+;; only ever contain French accented characters as keys.  It's cleared
+;; on each entry to htmlize-buffer-1 to allow modifications of
+;; `htmlize-convert-nonascii-to-entities' to take effect.
+(defvar htmlize-extended-character-cache (make-hash-table :test 'eq))
+
+(defun htmlize-protect-string (string)
+  "HTML-protect string, escaping HTML metacharacters and I18N chars."
+  ;; Only protecting strings that actually contain unsafe or non-ASCII
+  ;; chars removes a lot of unnecessary funcalls and consing.
+  (if (not (string-match "[^\r\n\t -%'-;=?-~]" string))
+      string
+    (mapconcat (lambda (char)
+		 (cond
+		  ((< char 128)
+		   ;; ASCII: use htmlize-basic-character-table.
+		   (aref htmlize-basic-character-table char))
+		  ((gethash char htmlize-extended-character-cache)
+		   ;; We've already seen this char; return the cached
+		   ;; string.
+		   )
+		  ((not htmlize-convert-nonascii-to-entities)
+		   ;; If conversion to entities is not desired, always
+		   ;; copy the char literally.
+		   (setf (gethash char htmlize-extended-character-cache)
+			 (char-to-string char)))
+		  ((< char 256)
+		   ;; Latin 1: no need to call encode-char.
+		   (setf (gethash char htmlize-extended-character-cache)
+			 (format "&#%d;" char)))
+		  ((and (fboundp 'encode-char)
+			;; Must check if encode-char works for CHAR;
+			;; it fails for Arabic and possibly elsewhere.
+			(encode-char char 'ucs))
+		   (setf (gethash char htmlize-extended-character-cache)
+			 (format "&#%d;" (encode-char char 'ucs))))
+		  (t
+		   ;; encode-char doesn't work for this char.  Copy it
+		   ;; unchanged and hope for the best.
+		   (setf (gethash char htmlize-extended-character-cache)
+			 (char-to-string char)))))
+	       string "")))
+
+(defconst htmlize-ellipsis "...")
+(put-text-property 0 (length htmlize-ellipsis) 'htmlize-ellipsis t htmlize-ellipsis)
+
+(defun htmlize-buffer-substring-no-invisible (beg end)
+  ;; Like buffer-substring-no-properties, but don't copy invisible
+  ;; parts of the region.  Where buffer-substring-no-properties
+  ;; mandates an ellipsis to be shown, htmlize-ellipsis is inserted.
+  (let ((pos beg)
+	visible-list invisible show next-change)
+    ;; Iterate over the changes in the `invisible' property and filter
+    ;; out the portions where it's non-nil, i.e. where the text is
+    ;; invisible.
+    (while (< pos end)
+      (setq invisible (get-char-property pos 'invisible)
+	    next-change (htmlize-next-change pos 'invisible end))
+      (if (not (listp buffer-invisibility-spec))
+	  ;; If buffer-invisibility-spec is not a list, then all
+	  ;; characters with non-nil `invisible' property are visible.
+	  (setq show (not invisible))
+	;; Otherwise, the value of a non-nil `invisible' property can be:
+	;; 1. a symbol -- make the text invisible if it matches
+	;;    buffer-invisibility-spec.
+	;; 2. a list of symbols -- make the text invisible if
+	;;    any symbol in the list matches
+	;;    buffer-invisibility-spec.
+	;; If the match of buffer-invisibility-spec has a non-nil
+	;; CDR, replace the invisible text with an ellipsis.
+	(let (match)
+	  (if (symbolp invisible)
+	      (setq match (member* invisible buffer-invisibility-spec
+				   :key (lambda (i)
+					  (if (symbolp i) i (car i)))))
+	    (setq match (block nil
+			  (dolist (elem invisible)
+			    (let ((m (member*
+				      elem buffer-invisibility-spec
+				      :key (lambda (i)
+					     (if (symbolp i) i (car i))))))
+			      (when m (return m))))
+			  nil)))
+	  (setq show (cond ((null match) t)
+			   ((and (cdr-safe (car match))
+				 ;; Conflate successive ellipses.
+				 (not (eq show htmlize-ellipsis)))
+			    htmlize-ellipsis)
+			   (t nil)))))
+      (cond ((eq show t)
+	     (push (buffer-substring-no-properties pos next-change) visible-list))
+	    ((stringp show)
+	     (push show visible-list)))
+      (setq pos next-change))
+    (if (= (length visible-list) 1)
+	;; If VISIBLE-LIST consists of only one element, return it
+	;; without concatenation.  This avoids additional consing in
+	;; regions without any invisible text.
+	(car visible-list)
+      (apply #'concat (nreverse visible-list)))))
+
+(defun htmlize-trim-ellipsis (text)
+  ;; Remove htmlize-ellipses ("...") from the beginning of TEXT if it
+  ;; starts with it.  It checks for the special property of the
+  ;; ellipsis so it doesn't work on ordinary text that begins with
+  ;; "...".
+  (if (get-text-property 0 'htmlize-ellipsis text)
+      (substring text (length htmlize-ellipsis))
+    text))
+
+(defconst htmlize-tab-spaces
+  ;; A table of strings with spaces.  (aref htmlize-tab-spaces 5) is
+  ;; like (make-string 5 ?\ ), except it doesn't cons.
+  (let ((v (make-vector 32 nil)))
+    (dotimes (i (length v))
+      (setf (aref v i) (make-string i ?\ )))
+    v))
+
+(defun htmlize-untabify (text start-column)
+  "Untabify TEXT, assuming it starts at START-COLUMN."
+  (let ((column start-column)
+	(last-match 0)
+	(chunk-start 0)
+	chunks match-pos tab-size)
+    (while (string-match "[\t\n]" text last-match)
+      (setq match-pos (match-beginning 0))
+      (cond ((eq (aref text match-pos) ?\t)
+	     ;; Encountered a tab: create a chunk of text followed by
+	     ;; the expanded tab.
+	     (push (substring text chunk-start match-pos) chunks)
+	     ;; Increase COLUMN by the length of the text we've
+	     ;; skipped since last tab or newline.  (Encountering
+	     ;; newline resets it.)
+	     (incf column (- match-pos last-match))
+	     ;; Calculate tab size based on tab-width and COLUMN.
+	     (setq tab-size (- tab-width (% column tab-width)))
+	     ;; Expand the tab.
+	     (push (aref htmlize-tab-spaces tab-size) chunks)
+	     (incf column tab-size)
+	     (setq chunk-start (1+ match-pos)))
+	    (t
+	     ;; Reset COLUMN at beginning of line.
+	     (setq column 0)))
+      (setq last-match (1+ match-pos)))
+    ;; If no chunks have been allocated, it means there have been no
+    ;; tabs to expand.  Return TEXT unmodified.
+    (if (null chunks)
+	text
+      (when (< chunk-start (length text))
+	;; Push the remaining chunk.
+	(push (substring text chunk-start) chunks))
+      ;; Generate the output from the available chunks.
+      (apply #'concat (nreverse chunks)))))
+
+(defun htmlize-despam-address (string)
+  "Replace every occurrence of '@' in STRING with @.
+`htmlize-make-hyperlinks' uses this to spam-protect mailto links
+without modifying their meaning."
+  ;; Suggested by Ville Skytta.
+  (while (string-match "@" string)
+    (setq string (replace-match "@" nil t string)))
+  string)
+
+(defun htmlize-make-hyperlinks ()
+  "Make hyperlinks in HTML."
+  ;; Function originally submitted by Ville Skytta.  Rewritten by
+  ;; Hrvoje Niksic, then modified by Ville Skytta and Hrvoje Niksic.
+  (goto-char (point-min))
+  (while (re-search-forward
+	  "<\\(\\(mailto:\\)?\\([-=+_.a-zA-Z0-9]+@[-_.a-zA-Z0-9]+\\)\\)>"
+	  nil t)
+    (let ((address (match-string 3))
+	  (link-text (match-string 1)))
+      (delete-region (match-beginning 0) (match-end 0))
+      (insert "<"
+	      (htmlize-despam-address link-text)
+	      ">")))
+  (goto-char (point-min))
+  (while (re-search-forward "<\\(\\(URL:\\)?\\([a-zA-Z]+://[^;]+\\)\\)>"
+			    nil t)
+    (let ((url (match-string 3))
+	  (link-text (match-string 1)))
+      (delete-region (match-beginning 0) (match-end 0))
+      (insert "<" link-text ">"))))
+
+;; Tests for htmlize-make-hyperlinks:
+
+;; 
+;; 
+;; 
+;; 
+;; 
+;; 
+
+(defun htmlize-defang-local-variables ()
+  ;; Juri Linkov reports that an HTML-ized "Local variables" can lead
+  ;; visiting the HTML to fail with "Local variables list is not
+  ;; properly terminated".  He suggested changing the phrase to
+  ;; syntactically equivalent HTML that Emacs doesn't recognize.
+  (goto-char (point-min))
+  (while (search-forward "Local Variables:" nil t)
+    (replace-match "Local Variables:" nil t)))
+
+
+;;; Color handling.
+
+(if (fboundp 'locate-file)
+    (defalias 'htmlize-locate-file 'locate-file)
+  (defun htmlize-locate-file (file path)
+    (dolist (dir path nil)
+      (when (file-exists-p (expand-file-name file dir))
+	(return (expand-file-name file dir))))))
+
+(defvar htmlize-x-library-search-path
+  '("/usr/X11R6/lib/X11/"
+    "/usr/X11R5/lib/X11/"
+    "/usr/lib/X11R6/X11/"
+    "/usr/lib/X11R5/X11/"
+    "/usr/local/X11R6/lib/X11/"
+    "/usr/local/X11R5/lib/X11/"
+    "/usr/local/lib/X11R6/X11/"
+    "/usr/local/lib/X11R5/X11/"
+    "/usr/X11/lib/X11/"
+    "/usr/lib/X11/"
+    "/usr/local/lib/X11/"
+    "/usr/X386/lib/X11/"
+    "/usr/x386/lib/X11/"
+    "/usr/XFree86/lib/X11/"
+    "/usr/unsupported/lib/X11/"
+    "/usr/athena/lib/X11/"
+    "/usr/local/x11r5/lib/X11/"
+    "/usr/lpp/Xamples/lib/X11/"
+    "/usr/openwin/lib/X11/"
+    "/usr/openwin/share/lib/X11/"))
+
+(defun htmlize-get-color-rgb-hash (&optional rgb-file)
+  "Return a hash table mapping X color names to RGB values.
+The keys in the hash table are X11 color names, and the values are the
+#rrggbb RGB specifications, extracted from `rgb.txt'.
+
+If RGB-FILE is nil, the function will try hard to find a suitable file
+in the system directories.
+
+If no rgb.txt file is found, return nil."
+  (let ((rgb-file (or rgb-file (htmlize-locate-file
+				"rgb.txt"
+				htmlize-x-library-search-path)))
+	(hash nil))
+    (when rgb-file
+      (with-temp-buffer
+	(insert-file-contents rgb-file)
+	(setq hash (make-hash-table :test 'equal))
+	(while (not (eobp))
+	  (cond ((looking-at "^\\s-*\\([!#]\\|$\\)")
+		 ;; Skip comments and empty lines.
+		 )
+		((looking-at
+		  "[ \t]*\\([0-9]+\\)[ \t]+\\([0-9]+\\)[ \t]+\\([0-9]+\\)[ \t]+\\(.*\\)")
+		 (setf (gethash (downcase (match-string 4)) hash)
+		       (format "#%02x%02x%02x"
+			       (string-to-number (match-string 1))
+			       (string-to-number (match-string 2))
+			       (string-to-number (match-string 3)))))
+		(t
+		 (error
+		  "Unrecognized line in %s: %s"
+		  rgb-file
+		  (buffer-substring (point) (progn (end-of-line) (point))))))
+	  (forward-line 1))))
+    hash))
+
+;; Compile the RGB map when loaded.  On systems where rgb.txt is
+;; missing, the value of the variable will be nil, and rgb.txt will
+;; not be used.
+(defvar htmlize-color-rgb-hash (htmlize-get-color-rgb-hash))
+
+;;; Face handling.
+
+(defun htmlize-face-specifies-property (face prop)
+  ;; Return t if face specifies PROP, as opposed to it being inherited
+  ;; from the default face.  The problem with e.g.
+  ;; `face-foreground-instance' is that it returns an instance for
+  ;; EVERY face because every face inherits from the default face.
+  ;; However, we'd like htmlize-face-{fore,back}ground to return nil
+  ;; when called with a face that doesn't specify its own foreground
+  ;; or background.
+  (or (eq face 'default)
+      (assq 'global (specifier-spec-list (face-property face prop)))))
+
+(defun htmlize-face-color-internal (face fg)
+  ;; Used only under GNU Emacs.  Return the color of FACE, but don't
+  ;; return "unspecified-fg" or "unspecified-bg".  If the face is
+  ;; `default' and the color is unspecified, look up the color in
+  ;; frame parameters.
+  (let* ((function (if fg #'face-foreground #'face-background))
+	 color)
+    (if (>= emacs-major-version 22)
+	;; For GNU Emacs 22+ set INHERIT to get the inherited values.
+	(setq color (funcall function face nil t))
+      (setq color (funcall function face))
+      ;; For GNU Emacs 21 (which has `face-attribute'): if the color
+      ;; is nil, recursively check for the face's parent.
+      (when (and (null color)
+		 (fboundp 'face-attribute)
+		 (face-attribute face :inherit)
+		 (not (eq (face-attribute face :inherit) 'unspecified)))
+	(setq color (htmlize-face-color-internal
+		     (face-attribute face :inherit) fg))))
+    (when (and (eq face 'default) (null color))
+      (setq color (cdr (assq (if fg 'foreground-color 'background-color)
+			     (frame-parameters)))))
+    (when (or (eq color 'unspecified)
+	      (equal color "unspecified-fg")
+	      (equal color "unspecified-bg"))
+      (setq color nil))
+    (when (and (eq face 'default)
+	       (null color))
+      ;; Assuming black on white doesn't seem right, but I can't think
+      ;; of anything better to do.
+      (setq color (if fg "black" "white")))
+    color))
+
+(defun htmlize-face-foreground (face)
+  ;; Return the name of the foreground color of FACE.  If FACE does
+  ;; not specify a foreground color, return nil.
+  (cond (htmlize-running-xemacs
+	 ;; XEmacs.
+	 (and (htmlize-face-specifies-property face 'foreground)
+	      (color-instance-name (face-foreground-instance face))))
+	(t
+	 ;; GNU Emacs.
+	 (htmlize-face-color-internal face t))))
+
+(defun htmlize-face-background (face)
+  ;; Return the name of the background color of FACE.  If FACE does
+  ;; not specify a background color, return nil.
+  (cond (htmlize-running-xemacs
+	 ;; XEmacs.
+	 (and (htmlize-face-specifies-property face 'background)
+	      (color-instance-name (face-background-instance face))))
+	(t
+	 ;; GNU Emacs.
+	 (htmlize-face-color-internal face nil))))
+
+;; Convert COLOR to the #RRGGBB string.  If COLOR is already in that
+;; format, it's left unchanged.
+
+(defun htmlize-color-to-rgb (color)
+  (let ((rgb-string nil))
+    (cond ((null color)
+	   ;; Ignore nil COLOR because it means that the face is not
+	   ;; specifying any color.  Hence (htmlize-color-to-rgb nil)
+	   ;; returns nil.
+	   )
+	  ((string-match "\\`#" color)
+	   ;; The color is already in #rrggbb format.
+	   (setq rgb-string color))
+	  ((and htmlize-use-rgb-txt
+		htmlize-color-rgb-hash)
+	   ;; Use of rgb.txt is requested, and it's available on the
+	   ;; system.  Use it.
+	   (setq rgb-string (gethash (downcase color) htmlize-color-rgb-hash)))
+	  (t
+	   ;; We're getting the RGB components from Emacs.
+	   (let ((rgb
+		  ;; Here I cannot conditionalize on (fboundp ...)
+		  ;; because ps-print under some versions of GNU Emacs
+		  ;; defines its own dummy version of
+		  ;; `color-instance-rgb-components'.
+		  (if htmlize-running-xemacs
+		      (mapcar (lambda (arg)
+				(/ arg 256))
+			      (color-instance-rgb-components
+			       (make-color-instance color)))
+		    (mapcar (lambda (arg)
+			      (/ arg 256))
+			    (x-color-values color)))))
+	     (when rgb
+	       (setq rgb-string (apply #'format "#%02x%02x%02x" rgb))))))
+    ;; If RGB-STRING is still nil, it means the color cannot be found,
+    ;; for whatever reason.  In that case just punt and return COLOR.
+    ;; Most browsers support a decent set of color names anyway.
+    (or rgb-string color)))
+
+;; We store the face properties we care about into an
+;; `htmlize-fstruct' type.  That way we only have to analyze face
+;; properties, which can be time consuming, once per each face.  The
+;; mapping between Emacs faces and htmlize-fstructs is established by
+;; htmlize-make-face-map.  The name "fstruct" refers to variables of
+;; type `htmlize-fstruct', while the term "face" is reserved for Emacs
+;; faces.
+
+(defstruct htmlize-fstruct
+  foreground				; foreground color, #rrggbb
+  background				; background color, #rrggbb
+  size					; size
+  boldp					; whether face is bold
+  italicp				; whether face is italic
+  underlinep				; whether face is underlined
+  overlinep				; whether face is overlined
+  strikep				; whether face is struck through
+  css-name				; CSS name of face
+  )
+
+(defun htmlize-face-emacs21-attr (fstruct attr value)
+  ;; For ATTR and VALUE, set the equivalent value in FSTRUCT.
+  (case attr
+    (:foreground
+     (setf (htmlize-fstruct-foreground fstruct) (htmlize-color-to-rgb value)))
+    (:background
+     (setf (htmlize-fstruct-background fstruct) (htmlize-color-to-rgb value)))
+    (:height
+     (setf (htmlize-fstruct-size fstruct) value))
+    (:weight
+     (when (string-match (symbol-name value) "bold")
+       (setf (htmlize-fstruct-boldp fstruct) t)))
+    (:slant
+     (setf (htmlize-fstruct-italicp fstruct) (or (eq value 'italic)
+						 (eq value 'oblique))))
+    (:bold
+     (setf (htmlize-fstruct-boldp fstruct) value))
+    (:italic
+     (setf (htmlize-fstruct-italicp fstruct) value))
+    (:underline
+     (setf (htmlize-fstruct-underlinep fstruct) value))
+    (:overline
+     (setf (htmlize-fstruct-overlinep fstruct) value))
+    (:strike-through
+     (setf (htmlize-fstruct-strikep fstruct) value))))
+
+(defun htmlize-face-size (face)
+  ;; The size (height) of FACE, taking inheritance into account.
+  ;; Only works in Emacs 21 and later.
+  (let ((size-list
+	 (loop
+	  for f = face then (ignore-errors (face-attribute f :inherit)) ;?????
+	  until (or (not f) (eq f 'unspecified))
+	  for h = (ignore-errors (face-attribute f :height)) ;???????
+	  collect (if (eq h 'unspecified) nil h))))
+    (reduce 'htmlize-merge-size (cons nil size-list))))
+
+(defun htmlize-face-to-fstruct (face)
+  "Convert Emacs face FACE to fstruct."
+  (let ((fstruct (make-htmlize-fstruct
+		  :foreground (htmlize-color-to-rgb
+			       (htmlize-face-foreground face))
+		  :background (htmlize-color-to-rgb
+			       (htmlize-face-background face)))))
+    (cond (htmlize-running-xemacs
+	   ;; XEmacs doesn't provide a way to detect whether a face is
+	   ;; bold or italic, so we need to examine the font instance.
+	   ;; #### This probably doesn't work under MS Windows and/or
+	   ;; GTK devices.  I'll need help with those.
+	   (let* ((font-instance (face-font-instance face))
+		  (props (font-instance-properties font-instance)))
+	     (when (equalp (cdr (assq 'WEIGHT_NAME props)) "bold")
+	       (setf (htmlize-fstruct-boldp fstruct) t))
+	     (when (or (equalp (cdr (assq 'SLANT props)) "i")
+		       (equalp (cdr (assq 'SLANT props)) "o"))
+	       (setf (htmlize-fstruct-italicp fstruct) t))
+	     (setf (htmlize-fstruct-strikep fstruct)
+		   (face-strikethru-p face))
+	     (setf (htmlize-fstruct-underlinep fstruct)
+		   (face-underline-p face))))
+	  ((fboundp 'face-attribute)
+	   ;; GNU Emacs 21 and further.
+	   (dolist (attr '(:weight :slant :underline :overline :strike-through))
+	     (let ((value (if (>= emacs-major-version 22)
+			      ;; Use the INHERIT arg in GNU Emacs 22.
+			      (face-attribute face attr nil t)
+			    ;; Otherwise, fake it.
+			    (let ((face face))
+			      (while (and (eq (face-attribute face attr)
+					      'unspecified)
+					  (not (eq (face-attribute face :inherit)
+						   'unspecified)))
+				(setq face (face-attribute face :inherit)))
+			      (face-attribute face attr)))))
+	       (when (and value (not (eq value 'unspecified)))
+		 (htmlize-face-emacs21-attr fstruct attr value))))
+	   (let ((size (htmlize-face-size face)))
+	     (unless (eql size 1.0) 	; ignore non-spec
+	       (setf (htmlize-fstruct-size fstruct) size))))
+	  (t
+	   ;; Older GNU Emacs.  Some of these functions are only
+	   ;; available under Emacs 20+, hence the guards.
+	   (when (fboundp 'face-bold-p)
+	     (setf (htmlize-fstruct-boldp fstruct) (face-bold-p face)))
+	   (when (fboundp 'face-italic-p)
+	     (setf (htmlize-fstruct-italicp fstruct) (face-italic-p face)))
+	   (setf (htmlize-fstruct-underlinep fstruct)
+		 (face-underline-p face))))
+    ;; Generate the css-name property.  Emacs places no restrictions
+    ;; on the names of symbols that represent faces -- any characters
+    ;; may be in the name, even ^@.  We try hard to beat the face name
+    ;; into shape, both esthetically and according to CSS1 specs.
+    (setf (htmlize-fstruct-css-name fstruct)
+	  (let ((name (downcase (symbol-name face))))
+	    (when (string-match "\\`font-lock-" name)
+	      ;; Change font-lock-FOO-face to FOO.
+	      (setq name (replace-match "" t t name)))
+	    (when (string-match "-face\\'" name)
+	      ;; Drop the redundant "-face" suffix.
+	      (setq name (replace-match "" t t name)))
+	    (while (string-match "[^-a-zA-Z0-9]" name)
+	      ;; Drop the non-alphanumerics.
+	      (setq name (replace-match "X" t t name)))
+	    (when (string-match "\\`[-0-9]" name)
+	      ;; CSS identifiers may not start with a digit.
+	      (setq name (concat "X" name)))
+	    ;; After these transformations, the face could come
+	    ;; out empty.
+	    (when (equal name "")
+	      (setq name "face"))
+	    ;; Apply the prefix.
+	    (setq name (concat htmlize-css-name-prefix name))
+	    name))
+    fstruct))
+
+(defmacro htmlize-copy-attr-if-set (attr-list dest source)
+  ;; Expand the code of the type
+  ;; (and (htmlize-fstruct-ATTR source)
+  ;;      (setf (htmlize-fstruct-ATTR dest) (htmlize-fstruct-ATTR source)))
+  ;; for the given list of boolean attributes.
+  (cons 'progn
+	(loop for attr in attr-list
+	      for attr-sym = (intern (format "htmlize-fstruct-%s" attr))
+	      collect `(and (,attr-sym ,source)
+			    (setf (,attr-sym ,dest) (,attr-sym ,source))))))
+
+(defun htmlize-merge-size (merged next)
+  ;; Calculate the size of the merge of MERGED and NEXT.
+  (cond ((null merged)     next)
+	((integerp next)   next)
+	((null next)       merged)
+	((floatp merged)   (* merged next))
+	((integerp merged) (round (* merged next)))))
+
+(defun htmlize-merge-two-faces (merged next)
+  (htmlize-copy-attr-if-set
+   (foreground background boldp italicp underlinep overlinep strikep)
+   merged next)
+  (setf (htmlize-fstruct-size merged)
+	(htmlize-merge-size (htmlize-fstruct-size merged)
+			    (htmlize-fstruct-size next)))
+  merged)
+
+(defun htmlize-merge-faces (fstruct-list)
+  (cond ((null fstruct-list)
+	 ;; Nothing to do, return a dummy face.
+	 (make-htmlize-fstruct))
+	((null (cdr fstruct-list))
+	 ;; Optimize for the common case of a single face, simply
+	 ;; return it.
+	 (car fstruct-list))
+	(t
+	 (reduce #'htmlize-merge-two-faces
+		 (cons (make-htmlize-fstruct) fstruct-list)))))
+
+;; GNU Emacs 20+ supports attribute lists in `face' properties.  For
+;; example, you can use `(:foreground "red" :weight bold)' as an
+;; overlay's "face", or you can even use a list of such lists, etc.
+;; We call those "attrlists".
+;;
+;; htmlize supports attrlist by converting them to fstructs, the same
+;; as with regular faces.
+
+(defun htmlize-attrlist-to-fstruct (attrlist)
+  ;; Like htmlize-face-to-fstruct, but accepts an ATTRLIST as input.
+  (let ((fstruct (make-htmlize-fstruct)))
+    (cond ((eq (car attrlist) 'foreground-color)
+	   ;; ATTRLIST is (foreground-color . COLOR)
+	   (setf (htmlize-fstruct-foreground fstruct)
+		 (htmlize-color-to-rgb (cdr attrlist))))
+	  ((eq (car attrlist) 'background-color)
+	   ;; ATTRLIST is (background-color . COLOR)
+	   (setf (htmlize-fstruct-background fstruct)
+		 (htmlize-color-to-rgb (cdr attrlist))))
+	  (t
+	   ;; ATTRLIST is a plist.
+	   (while attrlist
+	     (let ((attr (pop attrlist))
+		   (value (pop attrlist)))
+	       (when (and value (not (eq value 'unspecified)))
+		 (htmlize-face-emacs21-attr fstruct attr value))))))
+    (setf (htmlize-fstruct-css-name fstruct) "ATTRLIST")
+    fstruct))
+
+(defun htmlize-face-list-p (face-prop)
+  "Return non-nil if FACE-PROP is a list of faces, nil otherwise."
+  ;; If not for attrlists, this would return (listp face-prop).  This
+  ;; way we have to be more careful because attrlist is also a list!
+  (cond
+   ((eq face-prop nil)
+    ;; FACE-PROP being nil means empty list (no face), so return t.
+    t)
+   ((symbolp face-prop)
+    ;; A symbol other than nil means that it's only one face, so return
+    ;; nil.
+    nil)
+   ((not (consp face-prop))
+    ;; Huh?  Not a symbol or cons -- treat it as a single element.
+    nil)
+   (t
+    ;; We know that FACE-PROP is a cons: check whether it looks like an
+    ;; ATTRLIST.
+    (let* ((car (car face-prop))
+	   (attrlist-p (and (symbolp car)
+			    (or (eq car 'foreground-color)
+				(eq car 'background-color)
+				(eq (aref (symbol-name car) 0) ?:)))))
+      ;; If FACE-PROP is not an ATTRLIST, it means it's a list of
+      ;; faces.
+      (not attrlist-p)))))
+
+(defun htmlize-make-face-map (faces)
+  ;; Return a hash table mapping Emacs faces to htmlize's fstructs.
+  ;; The keys are either face symbols or attrlists, so the test
+  ;; function must be `equal'.
+  (let ((face-map (make-hash-table :test 'equal))
+	css-names)
+    (dolist (face faces)
+      (unless (gethash face face-map)
+	;; Haven't seen FACE yet; convert it to an fstruct and cache
+	;; it.
+	(let ((fstruct (if (symbolp face)
+			   (htmlize-face-to-fstruct face)
+			 (htmlize-attrlist-to-fstruct face))))
+	  (setf (gethash face face-map) fstruct)
+	  (let* ((css-name (htmlize-fstruct-css-name fstruct))
+		 (new-name css-name)
+		 (i 0))
+	    ;; Uniquify the face's css-name by using NAME-1, NAME-2,
+	    ;; etc.
+	    (while (member new-name css-names)
+	      (setq new-name (format "%s-%s" css-name (incf i))))
+	    (unless (equal new-name css-name)
+	      (setf (htmlize-fstruct-css-name fstruct) new-name))
+	    (push new-name css-names)))))
+    face-map))
+
+(defun htmlize-unstringify-face (face)
+  "If FACE is a string, return it interned, otherwise return it unchanged."
+  (if (stringp face)
+      (intern face)
+    face))
+
+(defun htmlize-faces-in-buffer ()
+  "Return a list of faces used in the current buffer.
+Under XEmacs, this returns the set of faces specified by the extents
+with the `face' property.  (This covers text properties as well.)  Under
+GNU Emacs, it returns the set of faces specified by the `face' text
+property and by buffer overlays that specify `face'."
+  (let (faces)
+    ;; Testing for (fboundp 'map-extents) doesn't work because W3
+    ;; defines `map-extents' under FSF.
+    (if htmlize-running-xemacs
+	(let (face-prop)
+	  (map-extents (lambda (extent ignored)
+			 (setq face-prop (extent-face extent)
+			       ;; FACE-PROP can be a face or a list of
+			       ;; faces.
+			       faces (if (listp face-prop)
+					 (union face-prop faces)
+				       (adjoin face-prop faces)))
+			 nil)
+		       nil
+		       ;; Specify endpoints explicitly to respect
+		       ;; narrowing.
+		       (point-min) (point-max) nil nil 'face))
+      ;; FSF Emacs code.
+      ;; Faces used by text properties.
+      (let ((pos (point-min)) face-prop next)
+	(while (< pos (point-max))
+	  (setq face-prop (get-text-property pos 'face)
+		next (or (next-single-property-change pos 'face) (point-max)))
+	  ;; FACE-PROP can be a face/attrlist or a list thereof.
+	  (setq faces (if (htmlize-face-list-p face-prop)
+			  (nunion (mapcar #'htmlize-unstringify-face face-prop)
+				  faces :test 'equal)
+			(adjoin (htmlize-unstringify-face face-prop)
+				faces :test 'equal)))
+	  (setq pos next)))
+      ;; Faces used by overlays.
+      (dolist (overlay (overlays-in (point-min) (point-max)))
+	(let ((face-prop (overlay-get overlay 'face)))
+	  ;; FACE-PROP can be a face/attrlist or a list thereof.
+	  (setq faces (if (htmlize-face-list-p face-prop)
+			  (nunion (mapcar #'htmlize-unstringify-face face-prop)
+				  faces :test 'equal)
+			(adjoin (htmlize-unstringify-face face-prop)
+				faces :test 'equal))))))
+    faces))
+
+;; htmlize-faces-at-point returns the faces in use at point.  The
+;; faces are sorted by increasing priority, i.e. the last face takes
+;; precedence.
+;;
+;; Under XEmacs, this returns all the faces in all the extents at
+;; point.  Under GNU Emacs, this returns all the faces in the `face'
+;; property and all the faces in the overlays at point.
+
+(cond (htmlize-running-xemacs
+       (defun htmlize-faces-at-point ()
+	 (let (extent extent-list face-list face-prop)
+	   (while (setq extent (extent-at (point) nil 'face extent))
+	     (push extent extent-list))
+	   ;; extent-list is in reverse display order, meaning that
+	   ;; smallest ones come last.  That is the order we want,
+	   ;; except it can be overridden by the `priority' property.
+	   (setq extent-list (stable-sort extent-list #'<
+					  :key #'extent-priority))
+	   (dolist (extent extent-list)
+	     (setq face-prop (extent-face extent))
+	     ;; extent's face-list is in reverse order from what we
+	     ;; want, but the `nreverse' below will take care of it.
+	     (setq face-list (if (listp face-prop)
+				 (append face-prop face-list)
+			       (cons face-prop face-list))))
+	   (nreverse face-list))))
+      (t
+       (defun htmlize-faces-at-point ()
+	 (let (all-faces)
+	   ;; Faces from text properties.
+	   (let ((face-prop (get-text-property (point) 'face)))
+	     (setq all-faces (if (htmlize-face-list-p face-prop)
+				 (nreverse (mapcar #'htmlize-unstringify-face
+						   face-prop))
+			       (list (htmlize-unstringify-face face-prop)))))
+	   ;; Faces from overlays.
+	   (let ((overlays
+		  ;; Collect overlays at point that specify `face'.
+		  (delete-if-not (lambda (o)
+				   (overlay-get o 'face))
+				 (overlays-at (point))))
+		 list face-prop)
+	     ;; Sort the overlays so the smaller (more specific) ones
+	     ;; come later.  The number of overlays at each one
+	     ;; position should be very small, so the sort shouldn't
+	     ;; slow things down.
+	     (setq overlays (sort* overlays
+				   ;; Sort by ascending...
+				   #'<
+				   ;; ...overlay size.
+				   :key (lambda (o)
+					  (- (overlay-end o)
+					     (overlay-start o)))))
+	     ;; Overlay priorities, if present, override the above
+	     ;; established order.  Larger overlay priority takes
+	     ;; precedence and therefore comes later in the list.
+	     (setq overlays (stable-sort
+			     overlays
+			     ;; Reorder (stably) by acending...
+			     #'<
+			     ;; ...overlay priority.
+			     :key (lambda (o)
+				    (or (overlay-get o 'priority) 0))))
+	     (dolist (overlay overlays)
+	       (setq face-prop (overlay-get overlay 'face))
+	       (setq list (if (htmlize-face-list-p face-prop)
+			      (nconc (nreverse (mapcar
+						#'htmlize-unstringify-face
+						face-prop))
+				     list)
+			    (cons (htmlize-unstringify-face face-prop) list))))
+	     ;; Under "Merging Faces" the manual explicitly states
+	     ;; that faces specified by overlays take precedence over
+	     ;; faces specified by text properties.
+	     (setq all-faces (nconc all-faces list)))
+	   all-faces))))
+
+;; htmlize supports generating HTML in two several fundamentally
+;; different ways, one with the use of CSS and nested  tags, and
+;; the other with the use of the old  tags.  Rather than adding
+;; a bunch of ifs to many places, we take a semi-OO approach.
+;; `htmlize-buffer-1' calls a number of "methods", which indirect to
+;; the functions that depend on `htmlize-output-type'.  The currently
+;; used methods are `doctype', `insert-head', `body-tag', and
+;; `insert-text'.  Not all output types define all methods.
+;;
+;; Methods are called either with (htmlize-method METHOD ARGS...)
+;; special form, or by accessing the function with
+;; (htmlize-method-function 'METHOD) and calling (funcall FUNCTION).
+;; The latter form is useful in tight loops because `htmlize-method'
+;; conses.
+;;
+;; Currently defined output types are `css' and `font'.
+
+(defmacro htmlize-method (method &rest args)
+  ;; Expand to (htmlize-TYPE-METHOD ...ARGS...).  TYPE is the value of
+  ;; `htmlize-output-type' at run time.
+  `(funcall (htmlize-method-function ',method) ,@args))
+
+(defun htmlize-method-function (method)
+  ;; Return METHOD's function definition for the current output type.
+  ;; The returned object can be safely funcalled.
+  (let ((sym (intern (format "htmlize-%s-%s" htmlize-output-type method))))
+    (indirect-function (if (fboundp sym)
+			   sym
+			 (let ((default (intern (concat "htmlize-default-"
+							(symbol-name method)))))
+			   (if (fboundp default)
+			       default
+			     'ignore))))))
+
+(defvar htmlize-memoization-table (make-hash-table :test 'equal))
+
+(defmacro htmlize-memoize (key generator)
+  "Return the value of GENERATOR, memoized as KEY.
+That means that GENERATOR will be evaluated and returned the first time
+it's called with the same value of KEY.  All other times, the cached
+\(memoized) value will be returned."
+  (let ((value (gensym)))
+    `(let ((,value (gethash ,key htmlize-memoization-table)))
+       (unless ,value
+	 (setq ,value ,generator)
+	 (setf (gethash ,key htmlize-memoization-table) ,value))
+       ,value)))
+
+;;; Default methods.
+
+(defun htmlize-default-doctype ()
+  nil					; no doc-string
+  ;; According to DTDs published by the W3C, it is illegal to embed
+  ;;  in 
.  This makes sense in general, but is bad for
+  ;; htmlize's intended usage of  to specify the document color.
+
+  ;; To make generated HTML legal, htmlize's `font' mode used to
+  ;; specify the SGML declaration of "HTML Pro" DTD here.  HTML Pro
+  ;; aka Silmaril DTD was a project whose goal was to produce a GPL'ed
+  ;; DTD that would encompass all the incompatible HTML extensions
+  ;; procured by Netscape, MSIE, and other players in the field.
+  ;; Apparently the project got abandoned, the last available version
+  ;; being "Draft 0 Revision 11" from January 1997, as documented at
+  ;; .
+
+  ;; Since by now HTML Pro is remembered by none but the most die-hard
+  ;; early-web-days nostalgics and used by not even them, there is no
+  ;; use in specifying it.  So we return the standard HTML 4.0
+  ;; declaration, which makes generated HTML technically illegal.  If
+  ;; you have a problem with that, use the `css' engine designed to
+  ;; create fully conforming HTML.
+
+  ""
+
+  ;; Now-abandoned HTML Pro declaration.
+  ;""
+  )
+
+(defun htmlize-default-body-tag (face-map)
+  nil					; no doc-string
+  "")
+
+;;; CSS based output support.
+
+;; Internal function; not a method.
+(defun htmlize-css-specs (fstruct)
+  (let (result)
+    (when (htmlize-fstruct-foreground fstruct)
+      (push (format "color: %s;" (htmlize-fstruct-foreground fstruct))
+	    result))
+    (when (htmlize-fstruct-background fstruct)
+      (push (format "background-color: %s;"
+		    (htmlize-fstruct-background fstruct))
+	    result))
+    (let ((size (htmlize-fstruct-size fstruct)))
+      (when (and size (not (eq htmlize-ignore-face-size t)))
+	(cond ((floatp size)
+	       (push (format "font-size: %d%%;" (* 100 size)) result))
+	      ((not (eq htmlize-ignore-face-size 'absolute))
+	       (push (format "font-size: %spt;" (/ size 10.0)) result)))))
+    (when (htmlize-fstruct-boldp fstruct)
+      (push "font-weight: bold;" result))
+    (when (htmlize-fstruct-italicp fstruct)
+      (push "font-style: italic;" result))
+    (when (htmlize-fstruct-underlinep fstruct)
+      (push "text-decoration: underline;" result))
+    (when (htmlize-fstruct-overlinep fstruct)
+      (push "text-decoration: overline;" result))
+    (when (htmlize-fstruct-strikep fstruct)
+      (push "text-decoration: line-through;" result))
+    (nreverse result)))
+
+(defun htmlize-css-insert-head (buffer-faces face-map)
+  (insert "    \n"))
+
+(defun htmlize-css-insert-text (text fstruct-list buffer)
+  ;; Insert TEXT colored with FACES into BUFFER.  In CSS mode, this is
+  ;; easy: just nest the text in one  tag for each
+  ;; face in FSTRUCT-LIST.
+  (dolist (fstruct fstruct-list)
+    (princ "" buffer))
+  (princ text buffer)
+  (dolist (fstruct fstruct-list)
+    (ignore fstruct)			; shut up the byte-compiler
+    (princ "" buffer)))
+
+;; `inline-css' output support.
+
+(defun htmlize-inline-css-body-tag (face-map)
+  (format ""
+	  (mapconcat #'identity (htmlize-css-specs (gethash 'default face-map))
+		     " ")))
+
+(defun htmlize-inline-css-insert-text (text fstruct-list buffer)
+  (let* ((merged (htmlize-merge-faces fstruct-list))
+	 (style (htmlize-memoize
+		 merged
+		 (let ((specs (htmlize-css-specs merged)))
+		   (and specs
+			(mapconcat #'identity (htmlize-css-specs merged) " "))))))
+    (when style
+      (princ "" buffer))
+    (princ text buffer)
+    (when style
+      (princ "" buffer))))
+
+;;; `font' tag based output support.
+
+(defun htmlize-font-body-tag (face-map)
+  (let ((fstruct (gethash 'default face-map)))
+    (format ""
+	    (htmlize-fstruct-foreground fstruct)
+	    (htmlize-fstruct-background fstruct))))
+
+(defun htmlize-font-insert-text (text fstruct-list buffer)
+  ;; In `font' mode, we use the traditional HTML means of altering
+  ;; presentation:  tag for colors,  for bold,  for
+  ;; underline, and  for strike-through.
+  (let* ((merged (htmlize-merge-faces fstruct-list))
+	 (markup (htmlize-memoize
+		  merged
+		  (cons (concat
+			 (and (htmlize-fstruct-foreground merged)
+			      (format "" (htmlize-fstruct-foreground merged)))
+			 (and (htmlize-fstruct-boldp merged)      "")
+			 (and (htmlize-fstruct-italicp merged)    "")
+			 (and (htmlize-fstruct-underlinep merged) "")
+			 (and (htmlize-fstruct-strikep merged)    ""))
+			(concat
+			 (and (htmlize-fstruct-strikep merged)    "")
+			 (and (htmlize-fstruct-underlinep merged) "")
+			 (and (htmlize-fstruct-italicp merged)    "")
+			 (and (htmlize-fstruct-boldp merged)      "")
+			 (and (htmlize-fstruct-foreground merged) ""))))))
+    (princ (car markup) buffer)
+    (princ text buffer)
+    (princ (cdr markup) buffer)))
+
+(defun htmlize-buffer-1 ()
+  ;; Internal function; don't call it from outside this file.  Htmlize
+  ;; current buffer, writing the resulting HTML to a new buffer, and
+  ;; return it.  Unlike htmlize-buffer, this doesn't change current
+  ;; buffer or use switch-to-buffer.
+  (save-excursion
+    ;; Protect against the hook changing the current buffer.
+    (save-excursion
+      (run-hooks 'htmlize-before-hook))
+    ;; Convince font-lock support modes to fontify the entire buffer
+    ;; in advance.
+    (htmlize-ensure-fontified)
+    (clrhash htmlize-extended-character-cache)
+    (clrhash htmlize-memoization-table)
+    (let* ((buffer-faces (htmlize-faces-in-buffer))
+	   (face-map (htmlize-make-face-map (adjoin 'default buffer-faces)))
+	   ;; Generate the new buffer.  It's important that it inherits
+	   ;; default-directory from the current buffer.
+	   (htmlbuf (generate-new-buffer (if (buffer-file-name)
+					     (htmlize-make-file-name
+					      (file-name-nondirectory
+					       (buffer-file-name)))
+					   "*html*")))
+	   ;; Having a dummy value in the plist allows writing simply
+	   ;; (plist-put places foo bar).
+	   (places '(nil nil))
+	   (title (if (buffer-file-name)
+		      (file-name-nondirectory (buffer-file-name))
+		    (buffer-name))))
+      ;; Initialize HTMLBUF and insert the HTML prolog.
+      (with-current-buffer htmlbuf
+	(buffer-disable-undo)
+	(insert (htmlize-method doctype) ?\n
+		(format "\n"
+			htmlize-version htmlize-output-type)
+		"\n  ")
+	(plist-put places 'head-start (point-marker))
+	(insert "\n"
+		"    " (htmlize-protect-string title) "\n"
+		(if htmlize-html-charset
+		    (format (concat "    \n")
+			    htmlize-html-charset)
+		  "")
+		htmlize-head-tags)
+	(htmlize-method insert-head buffer-faces face-map)
+	(insert "  ")
+	(plist-put places 'head-end (point-marker))
+	(insert "\n  ")
+	(plist-put places 'body-start (point-marker))
+	(insert (htmlize-method body-tag face-map)
+		"\n    ")
+	(plist-put places 'content-start (point-marker))
+	(insert "
\n"))
+      (let ((insert-text-method
+	     ;; Get the inserter method, so we can funcall it inside
+	     ;; the loop.  Not calling `htmlize-method' in the loop
+	     ;; body yields a measurable speed increase.
+	     (htmlize-method-function 'insert-text))
+	    ;; Declare variables used in loop body outside the loop
+	    ;; because it's faster to establish `let' bindings only
+	    ;; once.
+	    next-change text face-list fstruct-list trailing-ellipsis)
+	;; This loop traverses and reads the source buffer, appending
+	;; the resulting HTML to HTMLBUF with `princ'.  This method is
+	;; fast because: 1) it doesn't require examining the text
+	;; properties char by char (htmlize-next-change is used to
+	;; move between runs with the same face), and 2) it doesn't
+	;; require buffer switches, which are slow in Emacs.
+	(goto-char (point-min))
+	(while (not (eobp))
+	  (setq next-change (htmlize-next-change (point) 'face))
+	  ;; Get faces in use between (point) and NEXT-CHANGE, and
+	  ;; convert them to fstructs.
+	  (setq face-list (htmlize-faces-at-point)
+		fstruct-list (delq nil (mapcar (lambda (f)
+						 (gethash f face-map))
+					       face-list)))
+	  ;; Extract buffer text, sans the invisible parts.  Then
+	  ;; untabify it and escape the HTML metacharacters.
+	  (setq text (htmlize-buffer-substring-no-invisible
+		      (point) next-change))
+	  (when trailing-ellipsis
+	    (setq text (htmlize-trim-ellipsis text)))
+	  ;; If TEXT ends up empty, don't change trailing-ellipsis.
+	  (when (> (length text) 0)
+	    (setq trailing-ellipsis
+		  (get-text-property (1- (length text))
+				     'htmlize-ellipsis text)))
+	  (setq text (htmlize-untabify text (current-column)))
+	  (setq text (htmlize-protect-string text))
+	  ;; Don't bother writing anything if there's no text (this
+	  ;; happens in invisible regions).
+	  (when (> (length text) 0)
+	    ;; Insert the text, along with the necessary markup to
+	    ;; represent faces in FSTRUCT-LIST.
+	    (funcall insert-text-method text fstruct-list htmlbuf))
+	  (goto-char next-change)))
+
+      ;; Insert the epilog and post-process the buffer.
+      (with-current-buffer htmlbuf
+	(insert "
") + (plist-put places 'content-end (point-marker)) + (insert "\n ") + (plist-put places 'body-end (point-marker)) + (insert "\n\n") + (when htmlize-generate-hyperlinks + (htmlize-make-hyperlinks)) + (htmlize-defang-local-variables) + (when htmlize-replace-form-feeds + ;; Change each "\n^L" to "
". + (goto-char (point-min)) + (let ((source + ;; ^L has already been escaped, so search for that. + (htmlize-protect-string "\n\^L")) + (replacement + (if (stringp htmlize-replace-form-feeds) + htmlize-replace-form-feeds + "

")))
+	    (while (search-forward source nil t)
+	      (replace-match replacement t t))))
+	(goto-char (point-min))
+	(when htmlize-html-major-mode
+	  ;; What sucks about this is that the minor modes, most notably
+	  ;; font-lock-mode, won't be initialized.  Oh well.
+	  (funcall htmlize-html-major-mode))
+	(set (make-local-variable 'htmlize-buffer-places) places)
+	(run-hooks 'htmlize-after-hook)
+	(buffer-enable-undo))
+      htmlbuf)))
+
+;; Utility functions.
+
+(defmacro htmlize-with-fontify-message (&rest body)
+  ;; When forcing fontification of large buffers in
+  ;; htmlize-ensure-fontified, inform the user that he is waiting for
+  ;; font-lock, not for htmlize to finish.
+  `(progn
+     (if (> (buffer-size) 65536)
+	 (message "Forcing fontification of %s..."
+		  (buffer-name (current-buffer))))
+     ,@body
+     (if (> (buffer-size) 65536)
+	 (message "Forcing fontification of %s...done"
+		  (buffer-name (current-buffer))))))
+
+(defun htmlize-ensure-fontified ()
+  ;; If font-lock is being used, ensure that the "support" modes
+  ;; actually fontify the buffer.  If font-lock is not in use, we
+  ;; don't care because, except in htmlize-file, we don't force
+  ;; font-lock on the user.
+  (when (and (boundp 'font-lock-mode)
+	     font-lock-mode)
+    ;; In part taken from ps-print-ensure-fontified in GNU Emacs 21.
+    (cond
+     ((and (boundp 'jit-lock-mode)
+	   (symbol-value 'jit-lock-mode))
+      (htmlize-with-fontify-message
+       (jit-lock-fontify-now (point-min) (point-max))))
+     ((and (boundp 'lazy-lock-mode)
+	   (symbol-value 'lazy-lock-mode))
+      (htmlize-with-fontify-message
+       (lazy-lock-fontify-region (point-min) (point-max))))
+     ((and (boundp 'lazy-shot-mode)
+	   (symbol-value 'lazy-shot-mode))
+      (htmlize-with-fontify-message
+       ;; lazy-shot is amazing in that it must *refontify* the region,
+       ;; even if the whole buffer has already been fontified.  
+       (lazy-shot-fontify-region (point-min) (point-max))))
+     ;; There's also fast-lock, but we don't need to handle specially,
+     ;; I think.  fast-lock doesn't really defer fontification, it
+     ;; just saves it to an external cache so it's not done twice.
+     )))
+
+
+;;;###autoload
+(defun htmlize-buffer (&optional buffer)
+  "Convert BUFFER to HTML, preserving colors and decorations.
+
+The generated HTML is available in a new buffer, which is returned.
+When invoked interactively, the new buffer is selected in the current
+window.  The title of the generated document will be set to the buffer's
+file name or, if that's not available, to the buffer's name.
+
+Note that htmlize doesn't fontify your buffers, it only uses the
+decorations that are already present.  If you don't set up font-lock or
+something else to fontify your buffers, the resulting HTML will be
+plain.  Likewise, if you don't like the choice of colors, fix the mode
+that created them, or simply alter the faces it uses."
+  (interactive)
+  (let ((htmlbuf (with-current-buffer (or buffer (current-buffer))
+		   (htmlize-buffer-1))))
+    (when (interactive-p)
+      (switch-to-buffer htmlbuf))
+    htmlbuf))
+
+;;;###autoload
+(defun htmlize-region (beg end)
+  "Convert the region to HTML, preserving colors and decorations.
+See `htmlize-buffer' for details."
+  (interactive "r")
+  ;; Don't let zmacs region highlighting end up in HTML.
+  (when (fboundp 'zmacs-deactivate-region)
+    (zmacs-deactivate-region))
+  (let ((htmlbuf (save-restriction
+		   (narrow-to-region beg end)
+		   (htmlize-buffer-1))))
+    (when (interactive-p)
+      (switch-to-buffer htmlbuf))
+    htmlbuf))
+
+(defun htmlize-region-for-paste (beg end)
+  "Htmlize the region and return just the HTML as a string.
+This forces the `inline-css' style and only returns the HTML body,
+but without the BODY tag.  This should make it useful for inserting
+the text to another HTML buffer."
+  (let* ((htmlize-output-type 'inline-css)
+	 (htmlbuf (htmlize-region beg end)))
+    (unwind-protect
+	(with-current-buffer htmlbuf
+	  (buffer-substring (plist-get htmlize-buffer-places 'content-start)
+			    (plist-get htmlize-buffer-places 'content-end)))
+      (kill-buffer htmlbuf))))
+
+(defun htmlize-make-file-name (file)
+  "Make an HTML file name from FILE.
+
+In its default implementation, this simply appends `.html' to FILE.
+This function is called by htmlize to create the buffer file name, and
+by `htmlize-file' to create the target file name.
+
+More elaborate transformations are conceivable, such as changing FILE's
+extension to `.html' (\"file.c\" -> \"file.html\").  If you want them,
+overload this function to do it and htmlize will comply."
+  (concat file ".html"))
+
+;; Older implementation of htmlize-make-file-name that changes FILE's
+;; extension to ".html".
+;(defun htmlize-make-file-name (file)
+;  (let ((extension (file-name-extension file))
+;	(sans-extension (file-name-sans-extension file)))
+;    (if (or (equal extension "html")
+;	    (equal extension "htm")
+;	    (equal sans-extension ""))
+;	(concat file ".html")
+;      (concat sans-extension ".html"))))
+
+;;;###autoload
+(defun htmlize-file (file &optional target)
+  "Load FILE, fontify it, convert it to HTML, and save the result.
+
+Contents of FILE are inserted into a temporary buffer, whose major mode
+is set with `normal-mode' as appropriate for the file type.  The buffer
+is subsequently fontified with `font-lock' and converted to HTML.  Note
+that, unlike `htmlize-buffer', this function explicitly turns on
+font-lock.  If a form of highlighting other than font-lock is desired,
+please use `htmlize-buffer' directly on buffers so highlighted.
+
+Buffers currently visiting FILE are unaffected by this function.  The
+function does not change current buffer or move the point.
+
+If TARGET is specified and names a directory, the resulting file will be
+saved there instead of to FILE's directory.  If TARGET is specified and
+does not name a directory, it will be used as output file name."
+  (interactive (list (read-file-name
+		      "HTML-ize file: "
+		      nil nil nil (and (buffer-file-name)
+				       (file-name-nondirectory
+					(buffer-file-name))))))
+  (let ((output-file (if (and target (not (file-directory-p target)))
+			 target
+		       (expand-file-name
+			(htmlize-make-file-name (file-name-nondirectory file))
+			(or target (file-name-directory file)))))
+	;; Try to prevent `find-file-noselect' from triggering
+	;; font-lock because we'll fontify explicitly below.
+	(font-lock-mode nil)
+	(font-lock-auto-fontify nil)
+	(global-font-lock-mode nil)
+	;; Ignore the size limit for the purposes of htmlization.
+	(font-lock-maximum-size nil)
+	;; Disable font-lock support modes.  This will only work in
+	;; more recent Emacs versions, so htmlize-buffer-1 still needs
+	;; to call htmlize-ensure-fontified.
+	(font-lock-support-mode nil))
+    (with-temp-buffer
+      ;; Insert FILE into the temporary buffer.
+      (insert-file-contents file)
+      ;; Set the file name so normal-mode and htmlize-buffer-1 pick it
+      ;; up.  Restore it afterwards so with-temp-buffer's kill-buffer
+      ;; doesn't complain about killing a modified buffer.
+      (let ((buffer-file-name file))
+	;; Set the major mode for the sake of font-lock.
+	(normal-mode)
+	(font-lock-mode 1)
+	(unless font-lock-mode
+	  ;; In GNU Emacs (font-lock-mode 1) doesn't force font-lock,
+	  ;; contrary to the documentation.  This seems to work.
+	  (font-lock-fontify-buffer))
+	;; htmlize the buffer and save the HTML.
+	(with-current-buffer (htmlize-buffer-1)
+	  (unwind-protect
+	      (progn
+		(run-hooks 'htmlize-file-hook)
+		(write-region (point-min) (point-max) output-file))
+	    (kill-buffer (current-buffer)))))))
+  ;; I haven't decided on a useful return value yet, so just return
+  ;; nil.
+  nil)
+
+;;;###autoload
+(defun htmlize-many-files (files &optional target-directory)
+  "Convert FILES to HTML and save the corresponding HTML versions.
+
+FILES should be a list of file names to convert.  This function calls
+`htmlize-file' on each file; see that function for details.  When
+invoked interactively, you are prompted for a list of files to convert,
+terminated with RET.
+
+If TARGET-DIRECTORY is specified, the HTML files will be saved to that
+directory.  Normally, each HTML file is saved to the directory of the
+corresponding source file."
+  (interactive
+   (list
+    (let (list file)
+      ;; Use empty string as DEFAULT because setting DEFAULT to nil
+      ;; defaults to the directory name, which is not what we want.
+      (while (not (equal (setq file (read-file-name
+				     "HTML-ize file (RET to finish): "
+				     (and list (file-name-directory
+						(car list)))
+				     "" t))
+			 ""))
+	(push file list))
+      (nreverse list))))
+  ;; Verify that TARGET-DIRECTORY is indeed a directory.  If it's a
+  ;; file, htmlize-file will use it as target, and that doesn't make
+  ;; sense.
+  (and target-directory
+       (not (file-directory-p target-directory))
+       (error "target-directory must name a directory: %s" target-directory))
+  (dolist (file files)
+    (htmlize-file file target-directory)))
+
+;;;###autoload
+(defun htmlize-many-files-dired (arg &optional target-directory)
+  "HTMLize dired-marked files."
+  (interactive "P")
+  (htmlize-many-files (dired-get-marked-files nil arg) target-directory))
+
+(provide 'htmlize)
+
+;;; htmlize.el ends here
diff --git a/contrib/lisp/org-annotate-file.el b/contrib/lisp/org-annotate-file.el
new file mode 100644
index 0000000..55e5a32
--- /dev/null
+++ b/contrib/lisp/org-annotate-file.el
@@ -0,0 +1,131 @@
+;;; org-annotate-file.el --- Annotate a file with org syntax
+
+;; Copyright (C) 2008-2012 Philip Jackson
+
+;; Author: Philip Jackson 
+;; Version: 0.2
+
+;; This file is not currently part of GNU Emacs.
+
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU General Public License as
+;; published by the Free Software Foundation; either version 2, or (at
+;; your option) any later version.
+
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program ; see the file COPYING.  If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;; This is yet another implementation to allow the annotation of a
+;; file without modification of the file itself. The annotation is in
+;; org syntax so you can use all of the org features you are used to.
+
+;; To use you might put the following in your .emacs:
+;;
+;; (require 'org-annotate-file)
+;; (global-set-key (kbd "C-c C-l") 'org-annotate-file) ; for example
+;;
+;; To change the location of the annotation file:
+;;
+;; (setq org-annotate-file-storage-file "~/annotated.org")
+;;
+;; Then when you visit any file and hit C-c C-l you will find yourself
+;; in an org buffer on a headline which links to the file you were
+;; visiting, e.g:
+
+;; * ~/org-annotate-file.el
+
+;; Under here you can put anything you like, save the file
+;; and next time you hit C-c C-l you will hit those notes again.
+;;
+;; To put a subheading with a text search for the current line set
+;; `org-annotate-file-add-search` to non-nil value. Then when you hit
+;; C-c C-l (on the above line for example) you will get:
+
+;; * ~/org-annotate-file.el
+;; ** `org-annotate-file-add-search` to non-nil value. Then whe...
+
+;; Note that both of the above will be links.
+
+(require 'org)
+
+(defvar org-annotate-file-storage-file "~/.org-annotate-file.org"
+  "File in which to keep annotations.")
+
+(defvar org-annotate-file-add-search nil
+  "If non-nil then add a link as a second level to the actual
+location in the file")
+
+(defvar org-annotate-file-always-open t
+  "non-nil means always expand the full tree when you visit
+`org-annotate-file-storage-file'.")
+
+(defun org-annotate-file-elipsify-desc (string &optional after)
+  "Strip starting and ending whitespace and replace any chars
+that appear after the value in `after' with '...'"
+  (let* ((after (number-to-string (or after 30)))
+         (replace-map (list (cons "^[ \t]*" "")
+                            (cons "[ \t]*$" "")
+                            (cons (concat "^\\(.\\{" after
+                                          "\\}\\).*") "\\1..."))))
+    (mapc (lambda (x)
+            (when (string-match (car x) string)
+              (setq string (replace-match (cdr x) nil nil string))))
+          replace-map)
+    string))
+
+(defun org-annotate-file ()
+  "Put a section for the current file into your annotation file"
+  (interactive)
+  (unless (buffer-file-name)
+    (error "This buffer has no associated file"))
+  (org-annotate-file-show-section))
+
+(defun org-annotate-file-show-section (&optional buffer)
+  "Visit the buffer named `org-annotate-file-storage-file' and
+show the relevant section"
+  (let* ((filename (abbreviate-file-name (or buffer (buffer-file-name))))
+         (line (buffer-substring-no-properties (point-at-bol) (point-at-eol)))
+         (link (org-make-link-string (concat "file:" filename) filename))
+         (search-link (org-make-link-string
+                       (concat "file:" filename "::" line)
+                               (org-annotate-file-elipsify-desc line))))
+    (with-current-buffer (find-file org-annotate-file-storage-file)
+      (unless (eq major-mode 'org-mode)
+        (org-mode))
+      (goto-char (point-min))
+      (widen)
+      (when org-annotate-file-always-open
+        (show-all))
+      (unless (search-forward-regexp
+               (concat "^* " (regexp-quote link)) nil t)
+        (org-annotate-file-add-upper-level link))
+      (beginning-of-line)
+      (org-narrow-to-subtree)
+      ;; deal with a '::' search if need be
+      (when org-annotate-file-add-search
+        (unless (search-forward-regexp
+                 (concat "^** " (regexp-quote search-link)) nil t)
+          (org-annotate-file-add-second-level search-link))))))
+
+(defun org-annotate-file-add-upper-level (link)
+  (goto-char (point-min))
+  (call-interactively 'org-insert-heading)
+  (insert link))
+
+(defun org-annotate-file-add-second-level (link)
+  (goto-char (point-at-eol))
+  (call-interactively 'org-insert-subheading)
+  (insert link))
+
+(provide 'org-annotate-file)
+
+;;; org-annotate-file.el ends here
diff --git a/contrib/lisp/org-bibtex-extras.el b/contrib/lisp/org-bibtex-extras.el
new file mode 100644
index 0000000..8424e62
--- /dev/null
+++ b/contrib/lisp/org-bibtex-extras.el
@@ -0,0 +1,155 @@
+;;; org-bibtex-extras --- extras for working with org-bibtex entries
+
+;; Copyright (C) 2008-2012 Free Software Foundation, Inc.
+
+;; Author: Eric Schulte 
+;; Keywords: outlines, hypermedia, bibtex, d3
+;; Homepage: http://orgmode.org
+;; Version: 0.01
+
+;; This file is not yet part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 3, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs.  If not, see .
+
+;;; Commentary:
+
+;; Warning: This should certainly be considered EXPERIMENTAL and still
+;;          in development, feedback is welcome, but don't expect it
+;;          to work.
+
+;; This file add some extra functionality to your bibtex entries which
+;; are stored as Org-mode headlines using org-bibtex.el.  Most
+;; features expect that you keep all of your reading notes in a single
+;; file, set the `obe-bibtex-file' variable to the path to this file.
+;;
+;; - d3 view :: d3 is a Javascript library which supports interactive
+;;              display of graphs.  To view your citations as a d3
+;;              graph, execute the following which will create a .json
+;;              export of your references file, then grab a copy of
+;;              d3, edit examples/force/force.js to replace
+;;
+;;                var source`"miserables.json";
+;;
+;;              with
+;;
+;;                var source`"your-references.json";
+;;
+;;              then view examples/force/force.html in your browser.
+;;
+;; - HTML export :: Customize the `obe-html-link-base' variable so
+;;                  that it points to an html export of your
+;;                  references, then add the following to your html
+;;                  export hook, and citations will be resolved during
+;;                  html export.
+;;
+;;	 (add-hook 'org-export-first-hook
+;;	 	  (lambda ()
+;;	 	    (when (equal org-export-current-backend 'html)
+;;	 	      (obe-html-export-citations))))
+
+;;; Code:
+(require 'org-bibtex)
+
+(defcustom obe-bibtex-file nil "File holding bibtex entries.")
+
+(defcustom obe-html-link-base nil
+  "Base of citation links.
+For example, to point to your `obe-bibtex-file' use the following.
+
+  (setq obe-html-link-base (format \"file:%s\" obe-bibtex-file))
+")
+
+(defvar obe-citations nil)
+(defun obe-citations ()
+  "Return all citations from `obe-bibtex-file'."
+  (or obe-citations
+      (save-window-excursion
+	(find-file obe-bibtex-file)
+	(goto-char (point-min))
+	(while (re-search-forward "  :CUSTOM_ID: \\(.+\\)$" nil t)
+	  (push (org-babel-clean-text-properties (match-string 1))
+		obe-citations))
+	obe-citations)))
+
+(defun obe-goto-citation (&optional citation)
+  "Visit a citation given its ID."
+  (interactive)
+  (let ((citation (or citation
+		      (org-icompleting-read "Citation: "
+					    (obe-citations)))))
+    (find-file obe-bibtex-file)
+    (goto-char (point-min))
+    (when (re-search-forward (format "  :CUSTOM_ID: %s" citation) nil t)
+      (outline-previous-visible-heading 1)
+      t)))
+
+(defun obe-html-export-citations ()
+  "Convert all \\cite{...} citations in the current file into HTML links."
+  (save-excursion
+    (goto-char (point-min))
+    (while (re-search-forward "\\\\cite{\\([^\000}]+\\)}" nil t)
+      (replace-match
+       (save-match-data
+	 (mapconcat (lambda (c) (format "[[%s#%s][%s]]" obe-html-link-base c c))
+		    (mapcar #'org-babel-trim
+			    (split-string (match-string 1) ",")) ", "))))))
+
+(defun obe-get-meta-data (citation)
+  "Collect meta-data for CITATION."
+  (save-excursion
+    (when (obe-goto-citation citation)
+      (let ((pt (point)))
+	`((:authors . ,(split-string (org-entry-get pt "AUTHOR") " and " t))
+	  (:title   . ,(org-babel-clean-text-properties (org-get-heading 1 1)))
+	  (:journal . ,(org-entry-get pt "JOURNAL")))))))
+
+(defun obe-meta-to-json (meta &optional fields)
+  "Turn a list of META data from citations into a string of json."
+  (let ((counter 1) nodes links)
+    (flet ((id (it) (position it nodes :test #'string= :key #'car))
+	   (col (k) (mapcar (lambda (r) (cdr (assoc k r))) meta))
+	   (add (lst)
+		(dolist (el lst) (push (cons el counter) nodes))
+		(incf counter)))
+      ;; build the nodes of the graph
+      (add (col :title))
+      (add (remove-if (lambda (author) (string-match "others" author))
+		      (remove-duplicates (apply #'append (col :authors))
+					 :test #'string=)))
+      (dolist (field fields)
+	(add (remove-duplicates (col field) :test #'string=)))
+      ;; build the links in the graph
+      (dolist (citation meta)
+        (let ((dest (id (cdr (assoc :title citation)))))
+          (dolist (author (mapcar #'id (cdr (assoc :authors citation))))
+            (when author (push (cons author dest) links)))
+          (let ((jid (id (cdr (assoc :journal citation)))))
+            (when jid (push (cons jid dest) links)))
+          (let ((cid (id (cdr (assoc :category citation)))))
+            (when cid (push (cons cid dest) links)))))
+      ;; build the json string
+      (format "{\"nodes\":[%s],\"links\":[%s]}"
+	      (mapconcat
+	       (lambda (pair)
+		 (format "{\"name\":%S,\"group\":%d}"
+			 (car pair) (cdr pair)))
+	       nodes ",")
+	      (mapconcat
+	       (lambda (link)
+		 (format "{\"source\":%d,\"target\":%d,\"value\":1}"
+			 (car link) (cdr link)))
+	       (meta-to-links meta nodes) ",")))))
+
+(provide 'org-bibtex-extras)
+;;; org-bibtex-extras ends here
diff --git a/contrib/lisp/org-bookmark.el b/contrib/lisp/org-bookmark.el
new file mode 100644
index 0000000..56129d2
--- /dev/null
+++ b/contrib/lisp/org-bookmark.el
@@ -0,0 +1,88 @@
+;;; org-bookmark.el - Support for links to bookmark
+;; Copyright (C) 2008-2012 Free Software Foundation, Inc.
+;;
+;; Author: Tokuya Kameshima 
+;; Version: 1.0
+;; Keywords: outlines, hypermedia, calendar, wp
+;;
+;; This file is not part of GNU Emacs.
+;;
+;; Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 3, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(require 'org)
+(require 'bookmark)
+
+(defgroup org-bookmark nil
+  "Options concerning the bookmark link."
+  :tag "Org Startup"
+  :group 'org-link)
+
+(defcustom org-bookmark-in-dired nil
+  "Use org-bookmark in dired."
+  :group 'org-bookmark
+  :type 'boolean)
+
+(defcustom org-bookmark-when-visiting-a-file nil
+  "Use org-bookmark in any buffer visiting a file."
+  :group 'org-bookmark
+  :type 'boolean)
+
+(defcustom org-bookmark-use-first-bookmark nil
+  "If several bookmarks links to the buffer, take the first one.
+Otherwise prompt the user for the right bookmark to use."
+  :group 'org-bookmark
+  :type 'boolean)
+
+(org-add-link-type "bookmark" 'org-bookmark-open)
+(add-hook 'org-store-link-functions 'org-bookmark-store-link)
+
+(defun org-bookmark-open (bookmark)
+  "Visit the bookmark BOOKMARK."
+  (bookmark-jump bookmark))
+
+(defun org-bookmark-store-link ()
+  "Store a link to the current line's bookmark in bookmark list."
+  (let (file bookmark bmks)
+    (cond ((and org-bookmark-in-dired
+		(eq major-mode 'dired-mode))
+	   (setq file (abbreviate-file-name (dired-get-filename))))
+	  ((and org-bookmark-when-visiting-a-file
+		(buffer-file-name (buffer-base-buffer)))
+	   (setq file (abbreviate-file-name
+		       (buffer-file-name (buffer-base-buffer))))))
+    (if (not file)
+	(when (eq major-mode 'bookmark-bmenu-mode)
+	  (setq bookmark (bookmark-bmenu-bookmark)))
+      (when (and (setq bmks
+		       (mapcar (lambda (name)
+				 (if (equal file
+					    (abbreviate-file-name
+					     (bookmark-location name)))
+				     name))
+			       (bookmark-all-names)))
+		 (setq bmks (delete nil bmks)))
+	(setq bookmark
+	      (if (or (eq 1 (length bmks)) org-bookmark-use-first-bookmark)
+		  (car bmks)
+		(completing-read "Bookmark: " bmks nil t nil nil (car bmks))))))
+    (if bookmark
+	(org-store-link-props :link (contact "bookmark:" bookmark)
+			      :description bookmark))))
+
+(provide 'org-bookmark)
+
+;;; org-bookmark.el ends here
diff --git a/contrib/lisp/org-checklist.el b/contrib/lisp/org-checklist.el
new file mode 100644
index 0000000..1345a55
--- /dev/null
+++ b/contrib/lisp/org-checklist.el
@@ -0,0 +1,140 @@
+;;; org-checklist.el --- org functions for checklist handling
+
+;; Copyright (C) 2008-2012 James TD Smith
+
+;; Author: James TD Smith (@ ahktenzero (. mohorovi cc))
+;; Version: 1.0
+;; Keywords: org, checklists
+;;
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 3, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; if not, write to the Free Software
+;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; Commentary:
+
+;; This file provides some functions for handing repeated tasks which involve
+;; checking off a list of items. By setting the RESET_CHECK_BOXES property in an
+;; item, when the TODO state is set to done all checkboxes under that item are
+;; cleared. If the LIST_EXPORT_BASENAME property is set, a file will be created
+;; using the value of that property plus a timestamp, containing all the items
+;; in the list which are not checked. Additionally the user will be prompted to
+;; print the list.
+;;
+;; I use this for to keep track of stores of various things (food stores,
+;; components etc) which I check periodically and use the exported list of items
+;; which are not present as a shopping list.
+;;
+;;; Usage:
+;; (require 'org-checklist)
+;;
+;; Set the RESET_CHECK_BOXES and LIST_EXPORT_BASENAME properties in items as
+;; needed.
+;;
+;;; Code:
+(require 'org)
+(load "a2ps-print" 'no-error)
+
+(setq org-default-properties (cons "RESET_CHECK_BOXES" (cons "LIST_EXPORT_BASENAME" org-default-properties)))
+
+(defgroup org-checklist nil
+  "Extended checklist handling for org"
+  :tag "Org-checklist"
+  :group 'org)
+
+(defcustom org-checklist-export-time-format "%Y%m%d%H%M"
+  "The format of timestamp appended to LIST_EXPORT_BASENAME to
+  make the name of the export file."
+  :link '(function-link format-time-string)
+  :group 'org-checklist
+  :type 'string)
+
+(defcustom org-checklist-export-function 'org-export-as-ascii
+  "function used to prepare the export file for printing"
+  :group 'org-checklist
+  :type '(radio (function-item :tag "ascii text" org-export-as-ascii)
+		(function-item :tag "HTML"  org-export-as-html)
+		(function-item :tag "LaTeX" :value org-export-as-latex)
+		(function-item :tag "XOXO" :value org-export-as-xoxo)))
+
+(defcustom org-checklist-export-params nil
+  "options for the export function file for printing"
+  :group 'org-checklist
+  :type '(repeat string))
+
+(defcustom org-checklist-a2ps-params nil
+  "options for a2ps for printing"
+  :group 'org-checklist
+  :type '(repeat string))
+
+(defun org-reset-checkbox-state-maybe ()
+  "Reset all checkboxes in an entry if the `RESET_CHECK_BOXES' property is set"
+  (interactive "*")
+  (if (org-entry-get (point) "RESET_CHECK_BOXES")
+      (org-reset-checkbox-state-subtree)))
+
+
+(defun org-make-checklist-export ()
+  "Produce a checklist containing all unchecked items from a list
+of checkbox items"
+  (interactive "*")
+  (if (org-entry-get (point) "LIST_EXPORT_BASENAME")
+      (let* ((export-file (concat (org-entry-get (point) "LIST_EXPORT_BASENAME" nil)
+				  "-" (format-time-string
+				       org-checklist-export-time-format)
+				  ".org"))
+	     (print (case (org-entry-get (point) "PRINT_EXPORT" nil)
+		      (("" "nil" nil) nil)
+		      (t t)
+		      (nil (y-or-n-p "Print list? "))))
+	     exported-lines
+	     (title "Checklist export"))
+	(save-restriction
+	  (save-excursion
+	    (org-narrow-to-subtree)
+	    (org-update-checkbox-count-maybe)
+	    (org-show-subtree)
+	    (goto-char (point-min))
+	    (when (looking-at org-complex-heading-regexp)
+	      (setq title (match-string 4)))
+	    (goto-char (point-min))
+	    (let ((end (point-max)))
+	      (while (< (point) end)
+		(when (and (org-at-item-checkbox-p)
+			   (or (string= (match-string 0) "[ ]")
+			       (string= (match-string 0) "[-]")))
+		  (add-to-list 'exported-lines (thing-at-point 'line) t))
+		(beginning-of-line 2)))
+	    (set-buffer (get-buffer-create export-file))
+	    (org-insert-heading)
+	    (insert (or title export-file) "\n")
+	    (dolist (entry exported-lines) (insert entry))
+	    (org-update-checkbox-count-maybe)
+	    (write-file export-file)
+	    (if (print)
+		(progn (funcall org-checklist-export-function
+				org-checklist-export-params)
+		       (let* ((current-a2ps-switches a2ps-switches)
+			      (a2ps-switches (append current-a2ps-switches
+						     org-checklist-a2ps-params)))
+			 (a2ps-buffer)))))))))
+
+(defun org-checklist ()
+  (when (member org-state org-done-keywords) ;; org-state dynamically bound in org.el/org-todo
+    (org-make-checklist-export)
+    (org-reset-checkbox-state-maybe)))
+
+(add-hook 'org-after-todo-state-change-hook 'org-checklist)
+
+(provide 'org-checklist)
+
+;;; org-checklist.el ends here
diff --git a/contrib/lisp/org-choose.el b/contrib/lisp/org-choose.el
new file mode 100644
index 0000000..3513fe9
--- /dev/null
+++ b/contrib/lisp/org-choose.el
@@ -0,0 +1,542 @@
+;;;_ org-choose.el --- decision management for org-mode
+
+;;;_. Headers
+;;;_ , License
+;; Copyright (C) 2009-2012 Tom Breton (Tehom)
+
+;; This file is not part of GNU Emacs.
+
+;; Author: Tom Breton (Tehom)
+;; Keywords: outlines, convenience
+
+;; This file is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; This file is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING.  If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;;_ , Commentary:
+
+; This is code to support decision management.  It lets you treat a
+; group of sibling items in org-mode as alternatives in a decision.
+
+; There are no user commands in this file.  You use it by:
+;   * Loading it (manually or by M-x customize-apropos org-modules)
+
+;;   * Setting up at least one set of TODO keywords with the
+;;     interpretation "choose" by either:
+
+;;     * Using the file directive #+CHOOSE_TODO:
+
+;;       * For instance, "#+CHOOSE_TODO: NO(,-) MAYBE(,0) YES"
+
+;;     * Or by M-x customize-apropos org-todo-keywords
+
+;;   * Operating on single items with the TODO commands.
+
+;;     * Use C-S-right to change the keyword set.  Use this to change to
+;;       the "choose" keyword set that you just defined.
+
+;;     * Use S-right to advance the TODO mark to the next setting.
+
+;;       For "choose", that means you like this alternative more than
+;;       before.  Other alternatives will be automatically demoted to
+;;       keep your settings consistent.
+
+;;     * Use S-left to demote TODO to the previous setting.
+
+;;       For "choose", that means you don't like this alternative as much
+;;       as before.  Other alternatives will be automatically promoted,
+;;       if this item was all that was keeping them down.
+
+;;     * All the other TODO commands are available and behave essentially
+;;       the normal way.
+
+
+;;;_ , Requires
+
+(require 'org)
+;(eval-when-compile
+;   (require 'cl))
+(require 'cl)
+
+;;;_. Body
+;;;_ , The variables
+
+(defstruct (org-choose-mark-data. (:type list))
+   "The format of an entry in org-choose-mark-data.
+Indexes are 0-based or `nil'.
+"
+   keyword
+   bot-lower-range
+   top-upper-range
+   range-length
+   static-default
+   all-keywords)
+
+(defvar org-choose-mark-data
+   ()
+   "Alist of information for choose marks.
+
+Each entry is an `org-choose-mark-data.'" )
+(make-variable-buffer-local 'org-choose-mark-data)
+;;;_ , For setup
+;;;_  . org-choose-filter-one
+
+(defun org-choose-filter-one (i)
+   "Return a list of
+ * a canonized version of the string
+ * optionally one symbol"
+
+   (if
+      (not
+	 (string-match "(.*)" i))
+      (list i i)
+      (let*
+	 (
+	    (end-text (match-beginning 0))
+	    (vanilla-text (substring i 0 end-text))
+	    ;;Get the parenthesized part.
+	    (match (match-string 0 i))
+	    ;;Remove the parentheses.
+	    (args (substring match 1 -1))
+	    ;;Split it
+	    (arglist
+	       (let
+		  ((arglist-x (org-split-string args ",")))
+		  ;;When string starts with "," `split-string' doesn't
+		  ;;make a first arg, so in that case make one
+		  ;;manually.
+		  (if
+		     (string-match "^," args)
+		     (cons nil arglist-x)
+		     arglist-x)))
+	    (decision-arg (second arglist))
+	    (type
+	       (cond
+		  ((string= decision-arg "0")
+		     'default-mark)
+		  ((string= decision-arg "+")
+		     'top-upper-range)
+		  ((string= decision-arg "-")
+		     'bot-lower-range)
+		  (t nil)))
+	    (vanilla-arg (first arglist))
+	    (vanilla-mark
+	       (if vanilla-arg
+		  (concat vanilla-text "("vanilla-arg")")
+		  vanilla-text)))
+	 (if type
+	    (list vanilla-text vanilla-mark type)
+	    (list vanilla-text vanilla-mark)))))
+
+;;;_  . org-choose-setup-vars
+(defun org-choose-setup-vars (bot-lower-range top-upper-range
+				   static-default num-items all-mark-texts)
+   "Add to org-choose-mark-data according to arguments"
+
+   (let*
+      (
+	 (tail
+	    ;;If there's no bot-lower-range or no default, we don't
+	    ;;have ranges.
+	    (cdr
+	       (if (and static-default bot-lower-range)
+		  (let*
+		     (
+			;;If there's no top-upper-range, use the last
+			;;item.
+			(top-upper-range
+			   (or top-upper-range (1- num-items)))
+			(lower-range-length
+			   (1+ (- static-default bot-lower-range)))
+			(upper-range-length
+			   (- top-upper-range static-default))
+			(range-length
+			   (min upper-range-length lower-range-length)))
+
+
+		     (make-org-choose-mark-data.
+			:keyword nil
+			:bot-lower-range bot-lower-range
+			:top-upper-range top-upper-range
+			:range-length    range-length
+			:static-default static-default
+			:all-keywords all-mark-texts))
+
+		  (make-org-choose-mark-data.
+		     :keyword nil
+		     :bot-lower-range nil
+		     :top-upper-range nil
+		     :range-length    nil
+		     :static-default (or static-default 0)
+		     :all-keywords all-mark-texts)))))
+
+      (dolist (text all-mark-texts)
+	 (pushnew (cons text tail)
+	    org-choose-mark-data
+	    :test
+	    #'(lambda (a b)
+		 (equal (car a) (car b)))))))
+
+
+
+
+;;;_  . org-choose-filter-tail
+(defun org-choose-filter-tail (raw)
+   "Return a translation of RAW to vanilla and set appropriate
+buffer-local variables.
+
+RAW is a list of strings representing the input text of a choose
+interpretation."
+   (let
+      ((vanilla-list nil)
+	 (all-mark-texts nil)
+	 (index 0)
+	 bot-lower-range top-upper-range range-length static-default)
+      (dolist (i raw)
+	 (destructuring-bind
+	    (vanilla-text vanilla-mark &optional type)
+	    (org-choose-filter-one i)
+	    (cond
+	       ((eq type 'bot-lower-range)
+		  (setq bot-lower-range index))
+	       ((eq type 'top-upper-range)
+		  (setq top-upper-range index))
+	       ((eq type 'default-mark)
+		  (setq static-default index)))
+	    (incf index)
+	    (push vanilla-text all-mark-texts)
+	    (push vanilla-mark vanilla-list)))
+
+      (org-choose-setup-vars bot-lower-range top-upper-range
+	 static-default index (reverse all-mark-texts))
+      (nreverse vanilla-list)))
+
+;;;_  . org-choose-setup-filter
+
+(defun org-choose-setup-filter (raw)
+   "A setup filter for choose interpretations."
+   (when (eq (car raw) 'choose)
+      (cons
+	 'choose
+	 (org-choose-filter-tail (cdr raw)))))
+
+;;;_  . org-choose-conform-after-promotion
+(defun org-choose-conform-after-promotion (entry-pos keywords highest-ok-ix)
+  "Conform the current item after another item was promoted"
+
+   (unless
+      ;;Skip the entry that triggered this by skipping any entry with
+      ;;the same starting position.  plist uses the start of the
+      ;;header line as the position, but map no longer does, so we
+      ;;have to go back to the heading.
+      (=
+	 (save-excursion
+	    (org-back-to-heading)
+	    (point))
+	 entry-pos)
+      (let
+	 ((ix
+	     (org-choose-get-entry-index keywords)))
+	 ;;If the index of the entry exceeds the highest allowable
+	 ;;index, change it to that.
+	 (when (and ix
+		  (> ix highest-ok-ix))
+	    (org-todo
+	       (nth highest-ok-ix keywords))))))
+;;;_  . org-choose-conform-after-demotion
+(defun org-choose-conform-after-demotion (entry-pos keywords
+					       raise-to-ix
+					       old-highest-ok-ix)
+  "Conform the current item after another item was demoted."
+
+   (unless
+      ;;Skip the entry that triggered this.
+      (=
+	 (save-excursion
+	    (org-back-to-heading)
+	    (point))
+	 entry-pos)
+      (let
+	 ((ix
+	     (org-choose-get-entry-index keywords)))
+	 ;;If the index of the entry was at or above the old allowable
+	 ;;position, change it to the new mirror position if there is
+	 ;;one.
+	 (when (and
+		  ix
+		  raise-to-ix
+		  (>= ix old-highest-ok-ix))
+	    (org-todo
+	       (nth raise-to-ix keywords))))))
+
+;;;_ , org-choose-keep-sensible (the org-trigger-hook function)
+(defun org-choose-keep-sensible (change-plist)
+  "Bring the other items back into a sensible state after an item's
+setting was changed."
+   (let*
+      (  (from (plist-get change-plist :from))
+	 (to (plist-get change-plist :to))
+	 (entry-pos
+	    (set-marker
+	       (make-marker)
+	       (plist-get change-plist :position)))
+	 (kwd-data
+	    (assoc to org-todo-kwd-alist)))
+      (when
+	 (eq (nth 1 kwd-data) 'choose)
+	 (let*
+	    (
+	       (data
+		  (assoc to org-choose-mark-data))
+	       (keywords
+		  (org-choose-mark-data.-all-keywords data))
+	       (old-index
+		  (org-choose-get-index-in-keywords
+		     from
+		     keywords))
+	       (new-index
+		  (org-choose-get-index-in-keywords
+		     to
+		     keywords))
+	       (highest-ok-ix
+		  (org-choose-highest-other-ok
+		     new-index
+		     data))
+	       (funcdata
+		  (cond
+		     ;;The entry doesn't participate in conformance,
+		     ;;so give `nil' which does nothing.
+		     ((not highest-ok-ix) nil)
+		     ;;The entry was created or promoted
+		     ((or
+			 (not old-index)
+			 (> new-index old-index))
+			(list
+			   #'org-choose-conform-after-promotion
+			   entry-pos keywords
+			   highest-ok-ix))
+		     (t	;;Otherwise the entry was demoted.
+			(let
+			   (
+			      (raise-to-ix
+				 (min
+				    highest-ok-ix
+				    (org-choose-mark-data.-static-default
+				       data)))
+			      (old-highest-ok-ix
+				 (org-choose-highest-other-ok
+				    old-index
+				    data)))
+
+			   (list
+			      #'org-choose-conform-after-demotion
+			      entry-pos
+			      keywords
+			      raise-to-ix
+			      old-highest-ok-ix))))))
+
+	    (if funcdata
+	       ;;The funny-looking names are to make variable capture
+	       ;;unlikely.  (Poor-man's lexical bindings).
+	       (destructuring-bind (func-d473 . args-46k) funcdata
+		  (let
+		     ((map-over-entries
+			 (org-choose-get-fn-map-group))
+			;;We may call `org-todo', so let various hooks
+			;;`nil' so we don't cause loops.
+			org-after-todo-state-change-hook
+			org-trigger-hook
+			org-blocker-hook
+			org-todo-get-default-hook
+			;;Also let this alist `nil' so we don't log
+			;;secondary transitions.
+			org-todo-log-states)
+		     ;;Map over group
+		     (funcall map-over-entries
+			#'(lambda ()
+			     (apply func-d473 args-46k))))))))
+
+      ;;Remove the marker
+      (set-marker entry-pos nil)))
+
+
+
+;;;_ , Getting the default mark
+;;;_  . org-choose-get-index-in-keywords
+(defun org-choose-get-index-in-keywords (ix all-keywords)
+  "Return the index of the current entry."
+
+   (if ix
+      (position ix all-keywords
+	 :test #'equal)))
+
+;;;_  . org-choose-get-entry-index
+(defun org-choose-get-entry-index (all-keywords)
+   "Return index of current entry."
+
+   (let*
+      ((state (org-entry-get (point) "TODO")))
+      (org-choose-get-index-in-keywords state all-keywords)))
+
+;;;_  . org-choose-get-fn-map-group
+
+(defun org-choose-get-fn-map-group ()
+   "Return a function to map over the group"
+
+   #'(lambda (fn)
+       (require 'org-agenda) ;; `org-map-entries' seems to need it.
+	(save-excursion
+	  (unless (org-up-heading-safe)
+	    (error "Choosing is only supported between siblings in a tree, not on top level"))
+	  (let
+ 	      ((level (org-reduced-level (org-outline-level))))
+	    (save-restriction
+	      (org-map-entries
+	       fn
+	       (format "LEVEL=%d" level)
+	       'tree))))))
+
+;;;_  . org-choose-get-highest-mark-index
+
+(defun org-choose-get-highest-mark-index (keywords)
+   "Get the index of the highest current mark in the group.
+If there is none, return 0"
+
+   (let*
+      (
+	 ;;Func maps over applicable entries.
+	 (map-over-entries
+	    (org-choose-get-fn-map-group))
+
+	 (indexes-list
+	    (remove nil
+	       (funcall map-over-entries
+		  #'(lambda ()
+		       (org-choose-get-entry-index keywords))))))
+      (if
+	 indexes-list
+	 (apply #'max indexes-list)
+	 0)))
+
+
+;;;_  . org-choose-highest-ok
+
+(defun org-choose-highest-other-ok (ix data)
+  "Return the highest index that any choose mark can sensibly have,
+given that another mark has index IX.
+DATA must be a `org-choose-mark-data.'."
+
+   (let
+      (
+	 (bot-lower-range
+	    (org-choose-mark-data.-bot-lower-range data))
+	 (top-upper-range
+	    (org-choose-mark-data.-top-upper-range data))
+	 (range-length
+	    (org-choose-mark-data.-range-length data)))
+      (when (and ix bot-lower-range)
+	 (let*
+	    ((delta
+		(- top-upper-range ix)))
+	    (unless
+	       (< range-length delta)
+	       (+ bot-lower-range delta))))))
+
+;;;_  . org-choose-get-default-mark-index
+
+(defun org-choose-get-default-mark-index (data)
+  "Return the index of the default mark in a choose interpretation.
+
+DATA must be a `org-choose-mark-data.'."
+
+
+   (or
+      (let
+	 ((highest-mark-index
+	     (org-choose-get-highest-mark-index
+		(org-choose-mark-data.-all-keywords data))))
+	 (org-choose-highest-other-ok
+	    highest-mark-index data))
+      (org-choose-mark-data.-static-default data)))
+
+
+
+;;;_  . org-choose-get-mark-N
+(defun org-choose-get-mark-N (n data)
+   "Get the text of the nth mark in a choose interpretation."
+
+   (let*
+      ((l (org-choose-mark-data.-all-keywords data)))
+      (nth n l)))
+
+;;;_  . org-choose-get-default-mark
+
+(defun org-choose-get-default-mark (new-mark old-mark)
+   "Get the default mark IFF in a choose interpretation.
+NEW-MARK and OLD-MARK are the text of the new and old marks."
+
+   (let*
+      (
+	 (old-kwd-data
+	    (assoc old-mark org-todo-kwd-alist))
+	 (new-kwd-data
+	    (assoc new-mark org-todo-kwd-alist))
+	 (becomes-choose
+	    (and
+	       (or
+		  (not old-kwd-data)
+		  (not
+		     (eq (nth 1 old-kwd-data) 'choose)))
+	       (eq (nth 1 new-kwd-data) 'choose))))
+      (when
+	 becomes-choose
+	 (let
+	    ((new-mark-data
+		(assoc new-mark org-choose-mark-data)))
+	    (if
+	       new-mark
+	       (org-choose-get-mark-N
+		  (org-choose-get-default-mark-index
+		     new-mark-data)
+		  new-mark-data)
+	       (error "Somehow got an unrecognizable mark"))))))
+
+;;;_ , Setting it all up
+
+(eval-after-load "org"
+  '(progn
+     (add-to-list 'org-todo-setup-filter-hook
+		  #'org-choose-setup-filter)
+     (add-to-list 'org-todo-get-default-hook
+		  #'org-choose-get-default-mark)
+     (add-to-list 'org-trigger-hook
+		  #'org-choose-keep-sensible)
+     (add-to-list 'org-todo-interpretation-widgets
+		  '(:tag "Choose   (to record decisions)" choose)
+		  'append)
+     ))
+
+
+;;;_. Footers
+;;;_ , Provides
+
+(provide 'org-choose)
+
+;;;_ * Local emacs vars.
+;;;_  + Local variables:
+;;;_  + End:
+
+;;;_ , End
+
+;;; org-choose.el ends here
diff --git a/contrib/lisp/org-collector.el b/contrib/lisp/org-collector.el
new file mode 100644
index 0000000..089e8ad
--- /dev/null
+++ b/contrib/lisp/org-collector.el
@@ -0,0 +1,229 @@
+;;; org-collector --- collect properties into tables
+
+;; Copyright (C) 2008-2012 Free Software Foundation, Inc.
+
+;; Author: Eric Schulte 
+;; Keywords: outlines, hypermedia, calendar, wp, experimentation,
+;;           organization, properties
+;; Homepage: http://orgmode.org
+;; Version: 0.01
+
+;; This file is not yet part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 3, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs.  If not, see .
+
+;;; Commentary:
+
+;; Pass in an alist of columns, each column can be either a single
+;; property or a function which takes column names as arguments.
+;;
+;; For example the following propview block would collect the value of
+;; the 'amount' property from each header in the current buffer
+;;
+;; #+BEGIN: propview :cols (ITEM amount)
+;; | "ITEM"              | "amount" |
+;; |---------------------+----------|
+;; | "December Spending" |        0 |
+;; | "Grocery Store"     |    56.77 |
+;; | "Athletic club"     |     75.0 |
+;; | "Restaurant"        |    30.67 |
+;; | "January Spending"  |        0 |
+;; | "Athletic club"     |     75.0 |
+;; | "Restaurant"        |    50.00 |
+;; |---------------------+----------|
+;; |                     |          |
+;; #+END:
+;;
+;; This slightly more selective propview block will limit those
+;; headers included to those in the subtree with the id 'december'
+;; in which the spendtype property is equal to "food"
+;;
+;; #+BEGIN: propview :id "december" :conds ((string= spendtype "food")) :cols (ITEM amount)
+;; | "ITEM"          | "amount" |
+;; |-----------------+----------|
+;; | "Grocery Store" |    56.77 |
+;; | "Restaurant"    |    30.67 |
+;; |-----------------+----------|
+;; |                 |          |
+;; #+END:
+;;
+;; Org Collector allows arbitrary processing of the property values
+;; through elisp in the cols: property.  This allows for both simple
+;; computations as in the following example
+;;
+;; #+BEGIN: propview :id "results" :cols (ITEM f d list (apply '+ list) (+ f d))
+;; | "ITEM" | "f" | "d" | "list"                  | "(apply (quote +) list)" | "(+ f d)" |
+;; |--------+-----+-----+-------------------------+--------------------------+-----------|
+;; | "run1" |   2 |  33 | (quote (9 2 3 4 5 6 7)) | 36                       |        35 |
+;; | "run2" |   2 |  34 | :na                     | :na                      |        36 |
+;; | "run3" |   2 |  35 | :na                     | :na                      |        37 |
+;; | "run4" |   2 |  36 | :na                     | :na                      |        38 |
+;; |        |     |     |                         |                          |           |
+;; #+END:
+;;
+;; or more complex computations as in the following example taken from
+;; an org file where each header in "results" subtree contained a
+;; property "sorted_hits" which was passed through the
+;; "average-precision" elisp function
+;;
+;; #+BEGIN: propview :id "results" :cols (ITEM (average-precision sorted_hits))
+;; | "ITEM"    | "(average-precision sorted_hits)" |
+;; |-----------+-----------------------------------|
+;; | run (80)  |                          0.105092 |
+;; | run (70)  |                          0.108142 |
+;; | run (10)  |                          0.111348 |
+;; | run (60)  |                          0.113593 |
+;; | run (50)  |                          0.116446 |
+;; | run (100) |                          0.118863 |
+;; #+END:
+;;
+
+;;; Code:
+(require 'org)
+(require 'org-table)
+
+(defvar org-propview-default-value 0
+  "Default value to insert into the propview table when the no
+value is calculated either through lack of required variables for
+a column, or through the generation of an error.")
+
+(defun and-rest (list)
+  (if (listp list)
+      (if (> (length list) 1)
+	  (and (car list) (and-rest (cdr list)))
+	(car list))
+    list))
+
+(put 'org-collector-error
+     'error-conditions
+     '(error column-prop-error org-collector-error))
+
+(defun org-dblock-write:propview (params)
+  "collect the column specification from the #+cols line
+preceeding the dblock, then update the contents of the dblock."
+  (interactive)
+  (condition-case er
+      (let ((cols (plist-get params :cols))
+	    (inherit (plist-get params :inherit))
+	    (conds (plist-get params :conds))
+	    (match (plist-get params :match))
+	    (scope (plist-get params :scope))
+	    (noquote (plist-get params :noquote))
+	    (colnames (plist-get params :colnames))
+	    (content-lines (org-split-string (plist-get params :content) "\n"))
+	    id table line pos)
+	(save-excursion
+	  (when (setq id (plist-get params :id))
+	    (cond ((not id) nil)
+		  ((eq id 'global) (goto-char (point-min)))
+		  ((eq id 'local)  nil)
+		  ((setq idpos (org-find-entry-with-id id))
+		   (goto-char idpos))
+		  (t (error "Cannot find entry with :ID: %s" id))))
+	  (unless (eq id 'global) (org-narrow-to-subtree))
+	  (setq stringformat (if noquote "%s" "%S"))
+	  (setq table (org-propview-to-table
+		       (org-propview-collect cols stringformat conds match scope inherit
+					     (if colnames colnames cols)) stringformat))
+	  (widen))
+	(setq pos (point))
+	(when content-lines
+	  (while (string-match "^#" (car content-lines))
+	    (insert (pop content-lines) "\n")))
+	(insert table) (insert "\n|--") (org-cycle) (move-end-of-line 1)
+	(message (format "point-%d" pos))
+	(while (setq line (pop content-lines))
+	  (when (string-match "^#" line)
+	    (insert "\n" line)))
+	(goto-char pos)
+	(org-table-recalculate 'all))
+    (org-collector-error (widen) (error "%s" er))
+    (error (widen) (error "%s" er))))
+
+(defun org-propview-eval-w-props (props body)
+  "evaluate the BODY-FORMS binding the variables using the
+variables and values specified in props"
+  (condition-case nil ;; catch any errors
+      (eval `(let ,(mapcar
+		    (lambda (pair) (list (intern (car pair)) (cdr pair)))
+		    props)
+	       ,body))
+    (error nil)))
+
+(defun org-propview-get-with-inherited (&optional inherit)
+  (append
+   (org-entry-properties)
+   (delq nil
+	 (mapcar (lambda (i)
+		   (let* ((n (symbol-name i))
+			  (p (org-entry-get (point) n 'do-inherit)))
+		     (when p (cons n p))))
+		 inherit))))
+
+(defun org-propview-collect (cols stringformat &optional conds match scope inherit colnames)
+  (interactive)
+  ;; collect the properties from every header
+  (let* ((header-props
+	  (let ((org-trust-scanner-tags t) alst)
+	    (org-map-entries
+	     (quote (cons (cons "ITEM" (org-get-heading t))
+			  (org-propview-get-with-inherited inherit)))
+	     match scope)))
+	 ;; read property values
+	 (header-props
+	  (mapcar (lambda (props)
+		    (mapcar (lambda (pair)
+			      (cons (car pair) (org-babel-read (cdr pair))))
+			    props))
+		  header-props))
+	 ;; collect all property names
+	 (prop-names
+	  (mapcar 'intern (delete-dups
+			   (apply 'append (mapcar (lambda (header)
+						    (mapcar 'car header))
+						  header-props))))))
+    (append
+     (list
+      (if colnames colnames (mapcar (lambda (el) (format stringformat el)) cols))
+       'hline) ;; ------------------------------------------------
+     (mapcar ;; calculate the value of the column for each header
+      (lambda (props) (mapcar (lambda (col)
+			   (let ((result (org-propview-eval-w-props props col)))
+			     (if result result org-propview-default-value)))
+			 cols))
+      (if conds
+	  ;; eliminate the headers which don't satisfy the property
+	  (delq nil
+		(mapcar
+		 (lambda (props)
+		   (if (and-rest (mapcar
+				  (lambda (col)
+				    (org-propview-eval-w-props props col))
+				  conds))
+		       props))
+		 header-props))
+	  header-props)))))
+
+(defun org-propview-to-table (results stringformat)
+  ;; (message (format "cols:%S" cols))
+  (orgtbl-to-orgtbl
+   (mapcar
+    (lambda (row)
+      (if (equal row 'hline)
+	  'hline
+	(mapcar (lambda (el) (format stringformat el)) row)))
+    (delq nil results)) '()))
+
+(provide 'org-collector)
+;;; org-collector ends here
diff --git a/contrib/lisp/org-contacts.el b/contrib/lisp/org-contacts.el
new file mode 100644
index 0000000..bc52648
--- /dev/null
+++ b/contrib/lisp/org-contacts.el
@@ -0,0 +1,621 @@
+;;; org-contacts.el --- Contacts management
+
+;; Copyright (C) 2010-2012 Julien Danjou 
+
+;; Author: Julien Danjou 
+;; Keywords: outlines, hypermedia, calendar
+;;
+;; This file is NOT part of GNU Emacs.
+;;
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs.  If not, see .
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;; Commentary:
+
+;; This file contains the code for managing your contacts into Org-mode.
+
+;; To enter new contacts, you can use `org-capture' and a template just like
+;; this:
+
+;;         ("c" "Contacts" entry (file "~/Org/contacts.org")
+;;          "* %(org-contacts-template-name)
+;; :PROPERTIES:
+;; :EMAIL: %(org-contacts-template-email)
+;; :END:")))
+;;
+;;; Code:
+
+(eval-when-compile
+  (require 'cl))
+
+(eval-and-compile
+  (require 'org))
+(require 'gnus-util)
+
+(defgroup org-contacts nil
+  "Options concerning contacts management."
+  :group 'org)
+
+(defcustom org-contacts-files nil
+  "List of Org files to use as contacts source.
+If set to nil, all your Org files will be used."
+  :type '(repeat file)
+  :group 'org-contacts)
+
+(defcustom org-contacts-email-property "EMAIL"
+  "Name of the property for contact email address."
+  :type 'string
+  :group 'org-contacts)
+
+(defcustom org-contacts-address-property "ADDRESS"
+  "Name of the property for contact address."
+  :type 'string
+  :group 'org-contacts)
+
+(defcustom org-contacts-birthday-property "BIRTHDAY"
+  "Name of the property for contact birthday date."
+  :type 'string
+  :group 'org-contacts)
+
+(defcustom org-contacts-birthday-format "Birthday: %l (%Y)"
+  "Format of the anniversary agenda entry. The following replacements are available:
+
+  %h - Heading name
+  %l - Link to the heading
+  %y - Number of year
+  %Y - Number of year (ordinal)"
+  :type 'string
+  :group 'org-contacts)
+
+(defcustom org-contacts-last-read-mail-property "LAST_READ_MAIL"
+  "Name of the property for contact last read email link storage."
+  :type 'string
+  :group 'org-contacts)
+
+(defcustom org-contacts-icon-property "ICON"
+  "Name of the property for contact icon."
+  :type 'string
+  :group 'org-contacts)
+
+(defcustom org-contacts-nickname-property "NICKNAME"
+  "Name of the property for IRC nickname match."
+  :type 'string
+  :group 'org-contacts)
+
+(defcustom org-contacts-icon-size 32
+  "Size of the contacts icons."
+  :type 'string
+  :group 'org-contacts)
+
+(defcustom org-contacts-icon-use-gravatar (fboundp 'gravatar-retrieve)
+  "Whether use Gravatar to fetch contact icons."
+  :type 'boolean
+  :group 'org-contacts)
+
+(defcustom org-contacts-completion-ignore-case t
+  "Ignore case when completing contacts."
+  :type 'boolean
+  :group 'org-contacts)
+
+(defcustom org-contacts-group-prefix "+"
+  "Group prefix."
+  :type 'string
+  :group 'org-contacts)
+
+(defcustom org-contacts-matcher (concat org-contacts-email-property "<>\"\"")
+  "Matching rule for finding heading that are contacts.
+This can be a tag name, or a property check."
+  :type 'string
+  :group 'org-contacts)
+
+(defcustom org-contacts-email-link-description-format "%s (%d)"
+  "Format used to store links to email.
+This overrides `org-email-link-description-format' if set."
+  :group 'org-contacts
+  :type 'string)
+
+(defcustom org-contacts-vcard-file "contacts.vcf"
+  "Default file for vcard export."
+  :group 'org-contacts
+  :type 'file)
+
+(defvar org-contacts-keymap
+  (let ((map (make-sparse-keymap)))
+    (define-key map "M" 'org-contacts-view-send-email)
+    (define-key map "i" 'org-contacts-view-switch-to-irc-buffer)
+    map)
+  "The keymap used in `org-contacts' result list.")
+
+(defun org-contacts-files ()
+  "Return list of Org files to use for contact management."
+  (or org-contacts-files (org-agenda-files t 'ifmode)))
+
+(defun org-contacts-filter (&optional name-match tags-match)
+  "Search for a contact maching NAME-MATCH and TAGS-MATCH.
+If both match values are nil, return all contacts."
+  (let* (todo-only
+	(tags-matcher
+         (if tags-match
+             (cdr (org-make-tags-matcher tags-match))
+           t))
+        (name-matcher
+         (if name-match
+             '(org-string-match-p name-match (org-get-heading t))
+           t))
+        (contacts-matcher
+         (cdr (org-make-tags-matcher org-contacts-matcher)))
+        markers result)
+    (dolist (file (org-contacts-files))
+      (org-check-agenda-file file)
+      (with-current-buffer (org-get-agenda-file-buffer file)
+        (unless (eq major-mode 'org-mode)
+          (error "File %s is no in `org-mode'" file))
+        (org-scan-tags
+         '(add-to-list 'markers (set-marker (make-marker) (point)))
+         `(and ,contacts-matcher ,tags-matcher ,name-matcher)
+	 todo-only)))
+    (dolist (marker markers result)
+      (org-with-point-at marker
+        (add-to-list 'result
+                     (list (org-get-heading t) marker (org-entry-properties marker 'all)))))))
+
+(when (not (fboundp 'completion-table-case-fold))
+  ;; That function is new in Emacs 24...
+  (defun completion-table-case-fold (table &optional dont-fold)
+    (lambda (string pred action)
+      (let ((completion-ignore-case (not dont-fold)))
+	(complete-with-action action table string pred)))))
+
+(defun org-contacts-complete-name (&optional start)
+  "Complete text at START with a user name and email."
+  (let* ((end (point))
+         (start (or start
+                    (save-excursion
+                      (re-search-backward "\\(\\`\\|[\n:,]\\)[ \t]*")
+                      (goto-char (match-end 0))
+                      (point))))
+         (orig (buffer-substring start end))
+         (completion-ignore-case org-contacts-completion-ignore-case)
+         (group-completion-p (org-string-match-p (concat "^" org-contacts-group-prefix) orig))
+         (completion-list
+          (if group-completion-p
+              (mapcar (lambda (group) (propertize (concat org-contacts-group-prefix group) 'org-contacts-group group))
+                      (org-uniquify
+                       (loop for contact in (org-contacts-filter)
+                             with group-list
+                             nconc (org-split-string
+                                    (or (cdr (assoc-string "ALLTAGS" (caddr contact))) "") ":"))))
+            (loop for contact in (org-contacts-filter)
+                  ;; The contact name is always the car of the assoc-list
+                  ;; returned by `org-contacts-filter'.
+                  for contact-name = (car contact)
+                  ;; Build the list of the user email addresses.
+                  for email-list = (split-string (or
+                                                  (cdr (assoc-string org-contacts-email-property (caddr contact)))
+                                                  ""))
+                  ;; If the user has email addresses…
+                  if email-list
+                  ;; … append a list of USER .
+                  nconc (loop for email in email-list
+                              collect (org-contacts-format-email contact-name email)))))
+         (completion-list (all-completions orig completion-list)))
+    ;; If we are completing a group, and that's the only group, just return
+    ;; the real result.
+    (when (and group-completion-p
+               (= (length completion-list) 1))
+      (setq completion-list
+            (list (concat (car completion-list) ";: "
+                          (mapconcat 'identity
+                                     (loop for contact in (org-contacts-filter
+                                                           nil
+                                                           (get-text-property 0 'org-contacts-group (car completion-list)))
+                                           ;; The contact name is always the car of the assoc-list
+                                           ;; returned by `org-contacts-filter'.
+                                           for contact-name = (car contact)
+                                           ;; Grab the first email of the contact
+                                           for email = (car (split-string (or
+                                                                           (cdr (assoc-string org-contacts-email-property (caddr contact)))
+                                                                           "")))
+                                           ;; If the user has an email address, append USER .
+                                           if email collect (org-contacts-format-email contact-name email))
+                                     ", ")))))
+    (list start end (completion-table-case-fold completion-list (not org-contacts-completion-ignore-case)))))
+
+(defun org-contacts-message-complete-function ()
+  "Function used in `completion-at-point-functions' in `message-mode'."
+  (let ((mail-abbrev-mode-regexp
+         "^\\(Resent-To\\|To\\|B?Cc\\|Reply-To\\|From\\|Mail-Followup-To\\|Mail-Copies-To\\|Disposition-Notification-To\\|Return-Receipt-To\\):"))
+        (when (mail-abbrev-in-expansion-header-p)
+          (org-contacts-complete-name))))
+
+(defun org-contacts-gnus-get-name-email ()
+  "Get name and email address from Gnus message."
+  (if (gnus-alive-p)
+      (gnus-with-article-headers
+        (mail-extract-address-components
+         (or (mail-fetch-field "From") "")))))
+
+(defun org-contacts-gnus-article-from-get-marker ()
+  "Return a marker for a contact based on From."
+  (let* ((address (org-contacts-gnus-get-name-email))
+         (name (car address))
+         (email (cadr address)))
+    (cadar (or (org-contacts-filter
+                nil
+                (concat org-contacts-email-property "={\\b" (regexp-quote email) "\\b}"))
+               (when name
+                 (org-contacts-filter
+                  (concat "^" name "$")))))))
+
+(defun org-contacts-gnus-article-from-goto ()
+  "Go to contact in the From address of current Gnus message."
+  (interactive)
+  (let ((marker (org-contacts-gnus-article-from-get-marker)))
+    (when marker
+      (switch-to-buffer-other-window (marker-buffer marker))
+      (goto-char marker)
+      (when (eq major-mode 'org-mode)
+        (org-show-context 'agenda)
+        (save-excursion
+          (and (outline-next-heading)
+               ;; show the next heading
+               (org-flag-heading nil)))))))
+
+(defun org-contacts-anniversaries (&optional field format)
+  "Compute FIELD anniversary for each contact, returning FORMAT.
+Default FIELD value is \"BIRTHDAY\".
+
+Format is a string matching the following format specification:
+
+  %h - Heading name
+  %l - Link to the heading
+  %y - Number of year
+  %Y - Number of year (ordinal)"
+  (let ((calendar-date-style 'american)
+        (entry ""))
+    (unless format (setq format org-contacts-birthday-format))
+    (loop for contact in (org-contacts-filter)
+          for anniv = (let ((anniv (cdr (assoc-string
+                                         (or field org-contacts-birthday-property)
+                                         (caddr contact)))))
+                        (when anniv
+                          (calendar-gregorian-from-absolute
+                           (org-time-string-to-absolute anniv))))
+          ;; Use `diary-anniversary' to compute anniversary.
+          if (and anniv (apply 'diary-anniversary anniv))
+          collect (format-spec format
+                               `((?l . ,(org-with-point-at (cadr contact) (org-store-link nil)))
+                                 (?h . ,(car contact))
+                                 (?y . ,(- (calendar-extract-year date)
+                                           (calendar-extract-year anniv)))
+                                 (?Y . ,(let ((years (- (calendar-extract-year date)
+                                                        (calendar-extract-year anniv))))
+                                          (format "%d%s" years (diary-ordinal-suffix years)))))))))
+
+(defun org-completing-read-date (prompt collection
+                                        &optional predicate require-match initial-input
+                                        hist def inherit-input-method)
+  "Like `completing-read' but reads a date.
+Only PROMPT and DEF are really used."
+  (org-read-date nil nil nil prompt nil def))
+
+(add-to-list 'org-property-set-functions-alist
+             `(,org-contacts-birthday-property . org-completing-read-date))
+
+(defun org-contacts-template-name (&optional return-value)
+  "Try to return the contact name for a template.
+If not found return RETURN-VALUE or something that would ask the user."
+  (or (car (org-contacts-gnus-get-name-email))
+      return-value
+      "%^{Name}"))
+
+(defun org-contacts-template-email (&optional return-value)
+  "Try to return the contact email for a template.
+If not found return RETURN-VALUE or something that would ask the user."
+  (or (cadr (org-contacts-gnus-get-name-email))
+      return-value
+      (concat "%^{" org-contacts-email-property "}p")))
+
+(defun org-contacts-gnus-store-last-mail ()
+  "Store a link between mails and contacts.
+
+This function should be called from `gnus-article-prepare-hook'."
+  (let ((marker (org-contacts-gnus-article-from-get-marker)))
+    (when marker
+      (with-current-buffer (marker-buffer marker)
+        (save-excursion
+          (goto-char marker)
+          (let* ((org-email-link-description-format (or org-contacts-email-link-description-format
+                                                        org-email-link-description-format))
+                 (link (gnus-with-article-buffer (org-store-link nil))))
+            (org-set-property org-contacts-last-read-mail-property link)))))))
+
+(defun org-contacts-icon-as-string ()
+  (let ((image (org-contacts-get-icon)))
+    (concat
+     (propertize "-" 'display
+                 (append
+                  (if image
+                      image
+                    `'(space :width (,org-contacts-icon-size)))
+                  '(:ascent center)))
+     " ")))
+
+;;;###autoload
+(defun org-contacts (name)
+  "Create agenda view for contacts matching NAME."
+  (interactive (list (read-string "Name: ")))
+  (let ((org-agenda-files (org-contacts-files))
+        (org-agenda-skip-function
+         (lambda () (org-agenda-skip-if nil `(notregexp ,name))))
+        (org-agenda-format (propertize
+                            "%(org-contacts-icon-as-string)% p% s%(org-contacts-irc-number-of-unread-messages)%+T"
+                            'keymap org-contacts-keymap))
+        (org-agenda-overriding-header
+         (or org-agenda-overriding-header
+             (concat "List of contacts matching `" name "':"))))
+    (setq org-agenda-skip-regexp name)
+    (org-tags-view nil org-contacts-matcher)
+    (with-current-buffer org-agenda-buffer-name
+      (setq org-agenda-redo-command
+            (list 'org-contacts name)))))
+
+(defun org-contacts-completing-read (prompt
+                                     &optional predicate
+                                     initial-input hist def inherit-input-method)
+  "Call `completing-read' with contacts name as collection."
+  (org-completing-read
+   prompt (org-contacts-filter) predicate t initial-input hist def inherit-input-method))
+
+(defun org-contacts-format-email (name email)
+  "Format a mail address."
+  (unless email
+    (error "`email' cannot be nul"))
+  (if name
+      (concat name " <" email ">")
+    email))
+
+(defun org-contacts-check-mail-address (mail)
+  "Add MAIL address to contact at point if it does not have it."
+  (let ((mails (org-entry-get (point) org-contacts-email-property)))
+    (unless (member mail (split-string mails))
+      (when (yes-or-no-p
+             (format "Do you want to add this address to %s?" (org-get-heading t)))
+        (org-set-property org-contacts-email-property (concat mails " " mail))))))
+
+(defun org-contacts-gnus-check-mail-address ()
+  "Check that contact has the current address recorded.
+This function should be called from `gnus-article-prepare-hook'."
+  (let ((marker (org-contacts-gnus-article-from-get-marker)))
+    (when marker
+      (org-with-point-at marker
+        (org-contacts-check-mail-address (cadr (org-contacts-gnus-get-name-email)))))))
+
+(defun org-contacts-gnus-insinuate ()
+  "Add some hooks for Gnus user.
+This adds `org-contacts-gnus-check-mail-address' and
+`org-contacts-gnus-store-last-mail' to
+`gnus-article-prepare-hook'. It also adds a binding on `;' in
+`gnus-summary-mode-map' to `org-contacts-gnus-article-from-goto'"
+  (require 'gnus)
+  (require 'gnus-art)
+  (define-key gnus-summary-mode-map ";" 'org-contacts-gnus-article-from-goto)
+  (add-hook 'gnus-article-prepare-hook 'org-contacts-gnus-check-mail-address)
+  (add-hook 'gnus-article-prepare-hook 'org-contacts-gnus-store-last-mail))
+
+(when (boundp 'completion-at-point-functions)
+  (add-hook 'message-mode-hook
+	    (lambda ()
+	      (add-to-list 'completion-at-point-functions
+			   'org-contacts-message-complete-function))))
+
+(defun org-contacts-wl-get-from-header-content ()
+  "Retrieve the content of the `From' header of an email.
+Works from wl-summary-mode and mime-view-mode - that is while viewing email.
+Depends on Wanderlust been loaded."
+  (with-current-buffer (org-capture-get :original-buffer)
+    (cond
+     ((eq major-mode 'wl-summary-mode) (when wl-summary-buffer-elmo-folder
+                                         (elmo-message-field
+                                          wl-summary-buffer-elmo-folder
+                                          (wl-summary-message-number)
+                                          'from)))
+     ((eq major-mode 'mime-view-mode) (std11-narrow-to-header)
+                                      (prog1
+                                          (std11-fetch-field "From")
+                                        (widen))))))
+
+(defun org-contacts-wl-get-name-email ()
+  "Get name and email address from wanderlust email.
+See `org-contacts-wl-get-from-header-content' for limitations."
+  (let ((from (org-contacts-wl-get-from-header-content)))
+    (when from
+      (list (wl-address-header-extract-realname from)
+	    (wl-address-header-extract-address from)))))
+
+(defun org-contacts-template-wl-name (&optional return-value)
+  "Try to return the contact name for a template from wl.
+If not found return RETURN-VALUE or something that would ask the user."
+  (or (car (org-contacts-wl-get-name-email))
+      return-value
+      "%^{Name}"))
+
+(defun org-contacts-template-wl-email (&optional return-value)
+  "Try to return the contact email for a template from wl.
+If not found return RETURN-VALUE or something that would ask the user."
+  (or (cadr (org-contacts-wl-get-name-email))
+      return-value
+      (concat "%^{" org-contacts-email-property "}p")))
+
+(defun org-contacts-view-send-email (&optional ask)
+  "Send email to the contact at point.
+If ASK is set, ask for the email address even if there's only one address."
+  (interactive "P")
+  (let ((marker (org-get-at-bol 'org-hd-marker)))
+    (org-with-point-at marker
+      (let ((emails (org-entry-get (point) org-contacts-email-property)))
+        (if emails
+            (let ((email-list (split-string emails)))
+              (if (and (= (length email-list) 1) (not ask))
+                  (compose-mail (org-contacts-format-email
+                                 (org-get-heading t) emails))
+                (let ((email (completing-read "Send mail to which address: " email-list)))
+                  (org-contacts-check-mail-address email)
+                  (compose-mail (org-contacts-format-email (org-get-heading t) email)))))
+          (error (format "This contact has no mail address set (no %s property)."
+                         org-contacts-email-property)))))))
+
+(defun org-contacts-get-icon (&optional pom)
+  "Get icon for contact at POM."
+  (setq pom (or pom (point)))
+  (catch 'icon
+    ;; Use `org-contacts-icon-property'
+    (let ((image-data (org-entry-get pom org-contacts-icon-property)))
+      (when image-data
+        (throw 'icon
+               (if (fboundp 'gnus-rescale-image)
+                   (gnus-rescale-image (create-image image-data)
+                                       (cons org-contacts-icon-size org-contacts-icon-size))
+                 (create-image image-data)))))
+    ;; Next, try Gravatar
+    (when org-contacts-icon-use-gravatar
+      (let* ((gravatar-size org-contacts-icon-size)
+             (email-list (org-entry-get pom org-contacts-email-property))
+             (gravatar
+              (when email-list
+                (loop for email in (split-string email-list)
+                      for gravatar = (gravatar-retrieve-synchronously email)
+                      if (and gravatar
+                              (not (eq gravatar 'error)))
+                      return gravatar))))
+        (when gravatar (throw 'icon gravatar))))))
+
+(defun org-contacts-irc-buffer (&optional pom)
+  "Get the IRC buffer associated with the entry at POM."
+  (setq pom (or pom (point)))
+  (let ((nick (org-entry-get pom org-contacts-nickname-property)))
+    (when nick
+      (let ((buffer (get-buffer nick)))
+        (when buffer
+          (with-current-buffer buffer
+            (when (eq major-mode 'erc-mode)
+              buffer)))))))
+
+(defun org-contacts-irc-number-of-unread-messages (&optional pom)
+  "Return the number of unread messages for contact at POM."
+  (when (boundp 'erc-modified-channels-alist)
+    (let ((number (cadr (assoc (org-contacts-irc-buffer pom) erc-modified-channels-alist))))
+      (if number
+          (format (concat "%3d unread message" (if (> number 1) "s" " ") " ") number)
+        (make-string 21 ? )))))
+
+(defun org-contacts-view-switch-to-irc-buffer ()
+  "Switch to the IRC buffer of the current contact if it has one."
+  (interactive)
+  (let ((marker (org-get-at-bol 'org-hd-marker)))
+    (org-with-point-at marker
+      (switch-to-buffer-other-window (org-contacts-irc-buffer)))))
+
+(defun org-contacts-completing-read-nickname (prompt collection
+                                                     &optional predicate require-match initial-input
+                                                     hist def inherit-input-method)
+  "Like `completing-read' but reads a nickname."
+  (org-completing-read prompt (append collection (erc-nicknames-list)) predicate require-match
+                       initial-input hist def inherit-input-method))
+
+(defun erc-nicknames-list ()
+  "Return all nicknames of all ERC buffers."
+  (if (fboundp 'erc-buffer-list)
+      (loop for buffer in (erc-buffer-list)
+            nconc (with-current-buffer buffer
+                    (loop for user-entry in (mapcar 'car (erc-get-channel-user-list))
+                          collect (elt user-entry 1))))))
+
+(add-to-list 'org-property-set-functions-alist
+             `(,org-contacts-nickname-property . org-contacts-completing-read-nickname))
+
+(defun org-contacts-vcard-escape (str)
+  "Escape ; , and \n in STR for use in the VCard format.
+Thanks to http://www.emacswiki.org/cgi-bin/wiki/bbdb-vcard-export.el for the regexp."
+  (when str
+    (replace-regexp-in-string "\n" "\\\\n" (replace-regexp-in-string "\\(;\\|,\\|\\\\\\)" "\\\\\\1" str))))
+
+(defun org-contacts-vcard-encode-name (name)
+  "Try to encode NAME as VCard's N property. The N property expects FamilyName;GivenName;AdditionalNames;Prefix;Postfix.
+Org-contacts does not specify how to encode the name. So we try to do our best."
+  (concat (replace-regexp-in-string "\\(\\w+\\) \\(.*\\)" "\\2;\\1" name) ";;;"))
+
+(defun org-contacts-vcard-format (contact)
+  "Formats CONTACT in VCard 3.0 format."
+  (let* ((properties (caddr contact))
+	 (name (org-contacts-vcard-escape (car contact)))
+	 (n (org-contacts-vcard-encode-name name))
+	 (email (org-contacts-vcard-escape (cdr (assoc-string org-contacts-email-property properties))))
+	 (bday (org-contacts-vcard-escape (cdr (assoc-string org-contacts-birthday-property properties))))
+	 (addr (cdr (assoc-string org-contacts-address-property properties)))
+	 (nick (org-contacts-vcard-escape (cdr (assoc-string org-contacts-nickname-property properties))))
+
+	 (head (format "BEGIN:VCARD\nVERSION:3.0\nN:%s\nFN:%s\n" n name)))
+    (concat head
+	    (when email (format "EMAIL:%s\n" email))
+	    (when addr
+	      (format "ADR:;;%s\n" (replace-regexp-in-string "\\, ?" ";" addr)))
+	    (when bday
+	      (let ((cal-bday (calendar-gregorian-from-absolute (org-time-string-to-absolute bday))))
+		(format "BDAY:%04d-%02d-%02d\n"
+			(calendar-extract-year cal-bday)
+			(calendar-extract-month cal-bday)
+			(calendar-extract-day cal-bday))))
+	    (when nick (format "NICKNAME:%s\n" nick))
+	    "END:VCARD\n\n")))
+
+(defun org-contacts-export-as-vcard (&optional name file to-buffer)
+  "Export all contacts matching NAME as VCard 3.0. It TO-BUFFER is nil, the content is written to FILE or `org-contacts-vcard-file'. If TO-BUFFER is non-nil, the buffer is created and the VCard is written into that buffer."
+  (interactive) ; TODO ask for name?
+  (let* ((filename (or file org-contacts-vcard-file))
+	 (buffer (if to-buffer
+		     (get-buffer-create to-buffer)
+		     (find-file-noselect filename))))
+
+    (message "Exporting...")
+
+    (set-buffer buffer)
+    (let ((inhibit-read-only t)) (erase-buffer))
+    (fundamental-mode)
+    (org-install-letbind)
+
+    (when (fboundp 'set-buffer-file-coding-system)
+      (set-buffer-file-coding-system coding-system-for-write))
+
+    (loop for contact in (org-contacts-filter name)
+	 do (insert (org-contacts-vcard-format contact)))
+
+    (if to-buffer
+	(current-buffer)
+	(progn (save-buffer) (kill-buffer)))))
+
+(defun org-contacts-show-map (&optional name)
+  "Show contacts on a map. Requires google-maps-el."
+  (interactive)
+  (unless (fboundp 'google-maps-static-show)
+    (error "`org-contacts-show-map' requires `google-maps-el'"))
+  (google-maps-static-show
+   :markers
+   (loop
+      for contact in (org-contacts-filter name)
+      for addr = (cdr (assoc-string org-contacts-address-property (caddr contact)))
+      if addr
+      collect (cons (list addr) (list :label (string-to-char (car contact)))))))
+
+(provide 'org-contacts)
diff --git a/contrib/lisp/org-contribdir.el b/contrib/lisp/org-contribdir.el
new file mode 100644
index 0000000..37b06a4
--- /dev/null
+++ b/contrib/lisp/org-contribdir.el
@@ -0,0 +1,38 @@
+;;; org-contribdir.el --- Mark the location of the contrib directory
+;; Copyright (C) 2009-2012 Free Software Foundation, Inc.
+;;
+;; Author: Carsten Dominik 
+;; Keywords: outlines, hypermedia, calendar, wp
+;; Homepage: http://orgmode.org
+;; Version: 0.01
+;;
+;; This file is not yet part of GNU Emacs.
+;;
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 3, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;; Commentary:
+;;
+
+;; The sole purpose of this file is to be located in the same place
+;; as where the contributed Org files are located, typically in the
+;; contrib/lisp directory of the Org-mode distribution.  This is to
+;; make sure that the command `org-reload' can reliably locate
+;; contributed org files.
+
+(provide 'org-contribdir)
+
+;;; org-contribdir.el ends here
diff --git a/contrib/lisp/org-depend.el b/contrib/lisp/org-depend.el
new file mode 100644
index 0000000..d741dbe
--- /dev/null
+++ b/contrib/lisp/org-depend.el
@@ -0,0 +1,420 @@
+;;; org-depend.el --- TODO dependencies for Org-mode
+;; Copyright (C) 2008-2012 Free Software Foundation, Inc.
+;;
+;; Author: Carsten Dominik 
+;; Keywords: outlines, hypermedia, calendar, wp
+;; Homepage: http://orgmode.org
+;; Version: 0.08
+;;
+;; This file is not part of GNU Emacs.
+;;
+;; This file is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 3, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;; Commentary:
+;;
+;; WARNING: This file is just a PROOF OF CONCEPT, not a supported part
+;;          of Org-mode.
+;;
+;; This is an example implementation of TODO dependencies in Org-mode.
+;; It uses the new hooks in version 5.13 of Org-mode,
+;; `org-trigger-hook' and `org-blocker-hook'.
+;;
+;; It implements the following:
+;;
+;; Triggering
+;; ----------
+;;
+;; 1) If an entry contains a TRIGGER property that contains the string
+;;    "chain-siblings(KEYWORD)", then switching that entry to DONE does
+;;    do the following:
+;;    - The sibling following this entry switched to todo-state KEYWORD.
+;;    - The sibling also gets a TRIGGER property "chain-sibling(KEYWORD)",
+;;      property, to make sure that, when *it* is DONE, the chain will
+;;      continue.
+;;
+;; 2) If an entry contains a TRIGGER property that contains the string
+;;    "chain-siblings-scheduled", then switching that entry to DONE does
+;;    the following actions, similarly to "chain-siblings(KEYWORD)":
+;;    - The sibling receives the same scheduled time as the entry
+;;      marked as DONE (or, in the case, in which there is no scheduled
+;;      time, the sibling does not get any either).
+;;    - The sibling also gets the same TRIGGER property
+;;      "chain-siblings-scheduled", so the chain can continue.
+;;
+;; 3) If the TRIGGER property contains the string
+;;    "chain-find-next(KEYWORD[,OPTIONS])", then switching that entry
+;;    to DONE do the following:
+;;    - All siblings are of the entry are collected into a temporary
+;;      list and then filtered and sorted according to OPTIONS
+;;    - The first sibling on the list is changed into KEYWORD state
+;;    - The sibling also gets the same TRIGGER property
+;;      "chain-find-next", so the chain can continue.
+;;
+;;    OPTIONS should be a comma separated string without spaces, and
+;;    can contain following options:
+;;
+;;    - from-top      the candidate list is all of the siblings in
+;;                    the current subtree
+;;
+;;    - from-bottom   candidate list are all siblings from bottom up
+;;
+;;    - from-current  candidate list are all siblings from current item
+;;                    until end of subtree, then wrapped around from
+;;                    first sibling
+;;
+;;    - no-wrap       candidate list are siblings from current one down
+;;
+;;    - todo-only     Only consider siblings that have a todo keyword
+;;    -
+;;    - todo-and-done-only
+;;                    Same as above but also include done items.
+;;
+;;    - priority-up   sort by highest priority
+;;    - priority-down sort by lowest priority
+;;    - effort-up     sort by highest effort
+;;    - effort-down   sort by lowest effort
+;;
+;;    Default OPTIONS are from-top
+;;
+;;
+;; 4) If the TRIGGER property contains any other words like
+;;    XYZ(KEYWORD), these are treated as entry id's with keywords.  That
+;;    means Org-mode will search for an entry with the ID property XYZ
+;;    and switch that entry to KEYWORD as well.
+;;
+;; Blocking
+;; --------
+;;
+;; 1) If an entry contains a BLOCKER property that contains the word
+;;    "previous-sibling", the sibling above the current entry is
+;;    checked when you try to mark it DONE.  If it is still in a TODO
+;;    state, the current state change is blocked.
+;;
+;; 2) If the BLOCKER property contains any other words, these are
+;;    treated as entry id's.  That means Org-mode will search for an
+;;    entry with the ID property exactly equal to this word.  If any
+;;    of these entries is not yet marked DONE, the current state change
+;;    will be blocked.
+;;
+;; 3) Whenever a state change is blocked, an org-mark is pushed, so that
+;;    you can find the offending entry with `C-c &'.
+;;
+;;; Example:
+;;
+;; When trying this example, make sure that the settings for TODO keywords
+;; have been activated, i.e. include the following line and press C-c C-c
+;; on the line before working with the example:
+;;
+;; #+TYP_TODO: TODO NEXT | DONE
+;;
+;; * TODO Win a million in Las Vegas
+;;   The "third" TODO (see above) cannot become a TODO without this money.
+;;
+;;   :PROPERTIES:
+;;     :ID: I-cannot-do-it-without-money
+;;   :END:
+;;
+;; * Do this by doing a chain of TODO's
+;; ** NEXT This is the first in this chain
+;;    :PROPERTIES:
+;;      :TRIGGER: chain-siblings(NEXT)
+;;    :END:
+;;
+;; ** This is the second in this chain
+;;
+;; ** This is the third in this chain
+;;    :PROPERTIES:
+;;      :BLOCKER: I-cannot-do-it-without-money
+;;    :END:
+;;
+;; ** This is the forth in this chain
+;;    When this is DONE, we will also trigger entry XYZ-is-my-id
+;;   :PROPERTIES:
+;;     :TRIGGER: XYZ-is-my-id(TODO)
+;;   :END:
+;;
+;; ** This is the fifth in this chain
+;;
+;; * Start writing report
+;;   :PROPERTIES:
+;;     :ID: XYZ-is-my-id
+;;   :END:
+;;
+;;
+
+(require 'org)
+(eval-when-compile
+  (require 'cl))
+
+(defcustom org-depend-tag-blocked t
+  "Whether to indicate blocked TODO items by a special tag."
+  :group 'org
+  :type 'boolean)
+
+(defcustom org-depend-find-next-options
+  "from-current,todo-only,priority-up"
+  "Default options for chain-find-next trigger"
+  :group 'org
+  :type 'string)
+
+(defmacro org-depend-act-on-sibling (trigger-val &rest rest)
+  "Perform a set of actions on the next sibling, if it exists,
+copying the sibling spec TRIGGER-VAL to the next sibling."
+  `(catch 'exit
+     (save-excursion
+       (goto-char pos)
+       ;; find the sibling, exit if no more siblings
+       (condition-case nil
+           (outline-forward-same-level 1)
+         (error (throw 'exit t)))
+       ;; mark the sibling TODO
+       ,@rest
+       ;; make sure the sibling will continue the chain
+       (org-entry-add-to-multivalued-property
+        nil "TRIGGER" ,trigger-val))))
+
+(defvar org-depend-doing-chain-find-next nil)
+
+(defun org-depend-trigger-todo (change-plist)
+  "Trigger new TODO entries after the current is switched to DONE.
+This does two different kinds of triggers:
+
+- If the current entry contains a TRIGGER property that contains
+  \"chain-siblings(KEYWORD)\", it goes to the next sibling, marks it
+  KEYWORD and also installs the \"chain-sibling\" trigger to continue
+  the chain.
+- If the current entry contains a TRIGGER property that contains
+  \"chain-siblings-scheduled\", we go to the next sibling and copy
+  the scheduled time from the current task, also installing the property
+  in the sibling.
+- Any other word (space-separated) like XYZ(KEYWORD) in the TRIGGER
+  property is seen as an entry id.  Org-mode finds the entry with the
+  corresponding ID property and switches it to the state TODO as well."
+
+  ;; Get information from the plist
+  (let* ((type (plist-get change-plist :type))
+	       (pos (plist-get change-plist :position))
+	 (from (plist-get change-plist :from))
+	 (to (plist-get change-plist :to))
+	 (org-log-done nil) ; IMPROTANT!: no logging during automatic trigger!
+	 trigger triggers tr p1 kwd)
+    (catch 'return
+      (unless (eq type 'todo-state-change)
+	;; We are only handling todo-state-change....
+	(throw 'return t))
+      (unless (and (member from org-not-done-keywords)
+		   (member to org-done-keywords))
+	;; This is not a change from TODO to DONE, ignore it
+	(throw 'return t))
+
+      ;; OK, we just switched from a TODO state to a DONE state
+      ;; Lets see if this entry has a TRIGGER property.
+      ;; If yes, split it up on whitespace.
+      (setq trigger (org-entry-get pos "TRIGGER")
+	    triggers (and trigger (org-split-string trigger "[ \t]+")))
+
+      ;; Go through all the triggers
+      (while (setq tr (pop triggers))
+	(cond
+	 ((and (not org-depend-doing-chain-find-next)
+	       (string-match "\\`chain-find-next(\\b\\(.+?\\)\\b\\(.*\\))\\'" tr))
+	  ;; smarter sibling selection
+	  (let* ((org-depend-doing-chain-find-next t)
+		 (kwd (match-string 1 tr))
+		 (options (match-string 2 tr))
+		 (options (if (or (null options)
+				  (equal options ""))
+			      org-depend-find-next-options
+			    options))
+		 (todo-only (string-match "todo-only" options))
+		 (todo-and-done-only (string-match "todo-and-done-only"
+						   options))
+		 (from-top (string-match "from-top" options))
+		 (from-bottom (string-match "from-bottom" options))
+		 (from-current (string-match "from-current" options))
+		 (no-wrap (string-match "no-wrap" options))
+		 (priority-up (string-match "priority-up" options))
+		 (priority-down (string-match "priority-down" options))
+		 (effort-up (string-match "effort-up" options))
+		 (effort-down (string-match "effort-down" options)))
+	    (save-excursion
+	      (org-back-to-heading t)
+	      (let ((this-item (point)))
+		;; go up to the parent headline, then advance to next child
+		(org-up-heading-safe)
+		(let ((end (save-excursion (org-end-of-subtree t)
+					   (point)))
+		      (done nil)
+		      (items '()))
+		  (outline-next-heading)
+		  (while (not done)
+		    (if (not (looking-at org-complex-heading-regexp))
+			(setq done t)
+		      (let ((todo-kwd (match-string 2))
+			    (tags (match-string 5))
+			    (priority (org-get-priority (or (match-string 3) "")))
+			    (effort (when (or effort-up effort-down)
+				      (let ((effort (org-get-effort)))
+					(when effort
+					  (org-duration-string-to-minutes effort))))))
+			(push (list (point) todo-kwd priority tags effort)
+			      items))
+		      (unless (org-goto-sibling)
+			(setq done t))))
+		  ;; massage the list according to options
+		  (setq items
+			(cond (from-top (nreverse items))
+			      (from-bottom items)
+			      ((or from-current no-wrap)
+			       (let* ((items (nreverse items))
+				      (pos (position this-item items :key #'first))
+				      (items-before (subseq items 0 pos))
+				      (items-after (subseq items pos)))
+				 (if no-wrap items-after
+				   (append items-after items-before))))
+			      (t (nreverse items))))
+		  (setq items (remove-if
+			       (lambda (item)
+				 (or (equal (first item) this-item)
+				     (and (not todo-and-done-only)
+					  (member (second item) org-done-keywords))
+				     (and (or todo-only
+					      todo-and-done-only)
+					  (null (second item)))))
+			       items))
+		  (setq items
+			(sort
+			 items
+			 (lambda (item1 item2)
+			   (let* ((p1 (third item1))
+				  (p2 (third item2))
+				  (e1 (fifth item1))
+				  (e2 (fifth item2))
+				  (p1-lt (< p1 p2))
+				  (p1-gt (> p1 p2))
+				  (e1-lt (and e1 (or (not e2) (< e1 e2))))
+				  (e2-gt (and e2 (or (not e1) (> e1 e2)))))
+			     (cond (priority-up
+				    (or p1-gt
+					(and (equal p1 p2)
+					     (or (and effort-up e1-gt)
+						 (and effort-down e1-lt)))))
+				   (priority-down
+				    (or p1-lt
+					(and (equal p1 p2)
+					     (or (and effort-up e1-gt)
+						 (and effort-down e1-lt)))))
+				   (effort-up
+				    (or e1-gt (and (equal e1 e2) p1-gt)))
+				   (effort-down
+				    (or e1-lt (and (equal e1 e2) p1-gt))))))))
+		  (when items
+		    (goto-char (first (first items)))
+		    (org-entry-add-to-multivalued-property nil "TRIGGER" tr)
+		    (org-todo kwd)))))))
+	 ((string-match "\\`chain-siblings(\\(.*?\\))\\'" tr)
+	  ;; This is a TODO chain of siblings
+	  (setq kwd (match-string 1 tr))
+          (org-depend-act-on-sibling (format "chain-siblings(%s)" kwd)
+                                     (org-todo kwd)))
+	 ((string-match "\\`\\(\\S-+\\)(\\(.*?\\))\\'" tr)
+	  ;; This seems to be ENTRY_ID(KEYWORD)
+	  (setq id (match-string 1 tr)
+		kwd (match-string 2 tr)
+		p1 (org-find-entry-with-id id))
+	  (when p1
+	    ;; there is an entry with this ID, mark it TODO
+	    (save-excursion
+	      (goto-char p1)
+	      (org-todo kwd))))
+         ((string-match "\\`chain-siblings-scheduled\\'" tr)
+          (let ((time (org-get-scheduled-time pos)))
+            (when time
+              (org-depend-act-on-sibling
+               "chain-siblings-scheduled"
+               (org-schedule nil time))))))))))
+
+(defun org-depend-block-todo (change-plist)
+  "Block turning an entry into a TODO.
+This checks for a BLOCKER property in an entry and checks
+all the entries listed there.  If any of them is not done,
+block changing the current entry into a TODO entry.  If the property contains
+the word \"previous-sibling\", the sibling above the current entry is checked.
+Any other words are treated as entry id's. If an entry exists with the
+this ID property, that entry is also checked."
+  ;; Get information from the plist
+  (let* ((type (plist-get change-plist :type))
+	       (pos (plist-get change-plist :position))
+	 (from (plist-get change-plist :from))
+	 (to (plist-get change-plist :to))
+	 (org-log-done nil) ; IMPROTANT!: no logging during automatic trigger
+	 blocker blockers bl p1
+	 (proceed-p
+	  (catch 'return
+            ;; If this is not a todo state change, or if this entry is
+            ;; DONE, do not block
+            (when (or (not (eq type 'todo-state-change))
+                      (member from (cons 'done org-done-keywords))
+                      (member to (cons 'todo org-not-done-keywords))
+                      (not to))
+              (throw 'return t))
+
+	    ;; OK, the plan is to switch from nothing to TODO
+	    ;; Lets see if we will allow it.  Find the BLOCKER property
+	    ;; and split it on whitespace.
+	    (setq blocker (org-entry-get pos "BLOCKER")
+		  blockers (and blocker (org-split-string blocker "[ \t]+")))
+
+	    ;; go through all the blockers
+	    (while (setq bl (pop blockers))
+	      (cond
+	       ((equal bl "previous-sibling")
+		;; the sibling is required to be DONE.
+		(catch 'ignore
+		  (save-excursion
+		    (goto-char pos)
+		    ;; find the older sibling, exit if no more siblings
+		    (condition-case nil
+			(outline-backward-same-level 1)
+		      (error (throw 'ignore t)))
+		    ;; Check if this entry is not yet done and block
+		    (unless (org-entry-is-done-p)
+		      ;; return nil, to indicate that we block the change!
+		      (org-mark-ring-push)
+		      (throw 'return nil)))))
+
+	       ((setq p1 (org-find-entry-with-id bl))
+		;; there is an entry with this ID, check it out
+		(save-excursion
+		  (goto-char p1)
+		  (unless (org-entry-is-done-p)
+		    ;; return nil, to indicate that we block the change!
+		    (org-mark-ring-push)
+		    (throw 'return nil))))))
+	    t ; return t to indicate that we are not blocking
+	    )))
+    (when org-depend-tag-blocked
+      (org-toggle-tag "blocked" (if proceed-p 'off 'on)))
+
+    proceed-p))
+
+(add-hook 'org-trigger-hook 'org-depend-trigger-todo)
+(add-hook 'org-blocker-hook 'org-depend-block-todo)
+
+(provide 'org-depend)
+
+;;; org-depend.el ends here
diff --git a/contrib/lisp/org-drill.el b/contrib/lisp/org-drill.el
new file mode 100644
index 0000000..2ffc201
--- /dev/null
+++ b/contrib/lisp/org-drill.el
@@ -0,0 +1,3001 @@
+;;; -*- coding: utf-8-unix -*-
+;;; org-drill.el - Self-testing using spaced repetition
+;;;
+;;; Author: Paul Sexton 
+;;; Version: 2.3.6
+;;; Repository at http://bitbucket.org/eeeickythump/org-drill/
+;;;
+;;;
+;;; Synopsis
+;;; ========
+;;;
+;;; Uses the SuperMemo spaced repetition algorithms to conduct interactive
+;;; "drill sessions", where the material to be remembered is presented to the
+;;; student in random order. The student rates his or her recall of each item,
+;;; and this information is used to schedule the item for later revision.
+;;;
+;;; Each drill session can be restricted to topics in the current buffer
+;;; (default), one or several files, all agenda files, or a subtree. A single
+;;; topic can also be drilled.
+;;;
+;;; Different "card types" can be defined, which present their information to
+;;; the student in different ways.
+;;;
+;;; See the file README.org for more detailed documentation.
+
+
+(eval-when-compile (require 'cl))
+(eval-when-compile (require 'hi-lock))
+(require 'org)
+(require 'org-id)
+(require 'org-learn)
+
+
+(defgroup org-drill nil
+  "Options concerning interactive drill sessions in Org mode (org-drill)."
+  :tag "Org-Drill"
+  :group 'org-link)
+
+
+
+(defcustom org-drill-question-tag
+  "drill"
+  "Tag which topics must possess in order to be identified as review topics
+by `org-drill'."
+  :group 'org-drill
+  :type 'string)
+
+
+(defcustom org-drill-maximum-items-per-session
+  30
+  "Each drill session will present at most this many topics for review.
+Nil means unlimited."
+  :group 'org-drill
+  :type '(choice integer (const nil)))
+
+
+
+(defcustom org-drill-maximum-duration
+  20
+  "Maximum duration of a drill session, in minutes.
+Nil means unlimited."
+  :group 'org-drill
+  :type '(choice integer (const nil)))
+
+
+(defcustom org-drill-failure-quality
+  2
+  "If the quality of recall for an item is this number or lower,
+it is regarded as an unambiguous failure, and the repetition
+interval for the card is reset to 0 days.  If the quality is higher
+than this number, it is regarded as successfully recalled, but the
+time interval to the next repetition will be lowered if the quality
+was near to a fail.
+
+By default this is 2, for SuperMemo-like behaviour. For
+Mnemosyne-like behaviour, set it to 1.  Other values are not
+really sensible."
+  :group 'org-drill
+  :type '(choice (const 2) (const 1)))
+
+
+(defcustom org-drill-forgetting-index
+  10
+  "What percentage of items do you consider it is 'acceptable' to
+forget each drill session? The default is 10%. A warning message
+is displayed at the end of the session if the percentage forgotten
+climbs above this number."
+  :group 'org-drill
+  :type 'integer)
+
+
+(defcustom org-drill-leech-failure-threshold
+  15
+  "If an item is forgotten more than this many times, it is tagged
+as a 'leech' item."
+  :group 'org-drill
+  :type '(choice integer (const nil)))
+
+
+(defcustom org-drill-leech-method
+  'skip
+  "How should 'leech items' be handled during drill sessions?
+Possible values:
+- nil :: Leech items are treated the same as normal items.
+- skip :: Leech items are not included in drill sessions.
+- warn :: Leech items are still included in drill sessions,
+  but a warning message is printed when each leech item is
+  presented."
+  :group 'org-drill
+  :type '(choice (const 'warn) (const 'skip) (const nil)))
+
+
+(defface org-drill-visible-cloze-face
+  '((t (:foreground "darkseagreen")))
+  "The face used to hide the contents of cloze phrases."
+  :group 'org-drill)
+
+
+(defface org-drill-visible-cloze-hint-face
+  '((t (:foreground "dark slate blue")))
+  "The face used to hide the contents of cloze phrases."
+  :group 'org-drill)
+
+
+(defface org-drill-hidden-cloze-face
+  '((t (:foreground "deep sky blue" :background "blue")))
+  "The face used to hide the contents of cloze phrases."
+  :group 'org-drill)
+
+
+(defcustom org-drill-use-visible-cloze-face-p
+  nil
+  "Use a special face to highlight cloze-deleted text in org mode
+buffers?"
+  :group 'org-drill
+  :type 'boolean)
+
+
+(defcustom org-drill-hide-item-headings-p
+  nil
+  "Conceal the contents of the main heading of each item during drill
+sessions? You may want to enable this behaviour if item headings or tags
+contain information that could 'give away' the answer."
+  :group 'org-drill
+  :type 'boolean)
+
+
+(defcustom org-drill-new-count-color
+  "royal blue"
+  "Foreground colour used to display the count of remaining new items
+during a drill session."
+  :group 'org-drill
+  :type 'color)
+
+(defcustom org-drill-mature-count-color
+  "green"
+  "Foreground colour used to display the count of remaining mature items
+during a drill session. Mature items are due for review, but are not new."
+  :group 'org-drill
+  :type 'color)
+
+(defcustom org-drill-failed-count-color
+  "red"
+  "Foreground colour used to display the count of remaining failed items
+during a drill session."
+  :group 'org-drill
+  :type 'color)
+
+(defcustom org-drill-done-count-color
+  "sienna"
+  "Foreground colour used to display the count of reviewed items
+during a drill session."
+  :group 'org-drill
+  :type 'color)
+
+
+(setplist 'org-drill-cloze-overlay-defaults
+          '(display "[...]"
+                    face org-drill-hidden-cloze-face
+                    window t))
+
+(setplist 'org-drill-hidden-text-overlay
+          '(invisible t))
+
+(setplist 'org-drill-replaced-text-overlay
+          '(display "Replaced text"
+                    face default
+                    window t))
+
+
+(defvar org-drill-cloze-regexp
+  ;; ver 1   "[^][]\\(\\[[^][][^]]*\\]\\)"
+  ;; ver 2   "\\(\\[.*?\\]\\|^[^[[:cntrl:]]*?\\]\\|\\[.*?$\\)"
+  ;; ver 3!  "\\(\\[.*?\\]\\|\\[.*?[[:cntrl:]]+.*?\\]\\)"
+  "\\(\\[[[:cntrl:][:graph:][:space:]]*?\\)\\(\\||.+?\\)\\(\\]\\)")
+
+
+(defvar org-drill-cloze-keywords
+  `((,org-drill-cloze-regexp
+     (1 'org-drill-visible-cloze-face nil)
+     (2 'org-drill-visible-cloze-hint-face t)
+     (3 'org-drill-visible-cloze-face nil)
+     )))
+
+
+(defcustom org-drill-card-type-alist
+  '((nil . org-drill-present-simple-card)
+    ("simple" . org-drill-present-simple-card)
+    ("twosided" . org-drill-present-two-sided-card)
+    ("multisided" . org-drill-present-multi-sided-card)
+    ("hide1cloze" . org-drill-present-multicloze-hide1)
+    ("hide2cloze" . org-drill-present-multicloze-hide2)
+    ("show1cloze" . org-drill-present-multicloze-show1)
+    ("show2cloze" . org-drill-present-multicloze-show2)
+    ("multicloze" . org-drill-present-multicloze-hide1)
+    ("hidefirst" . org-drill-present-multicloze-hide-first)
+    ("hidelast" . org-drill-present-multicloze-hide-last)
+    ("hide1_firstmore" . org-drill-present-multicloze-hide1-firstmore)
+    ("show1_lastmore" . org-drill-present-multicloze-show1-lastmore)
+    ("show1_firstless" . org-drill-present-multicloze-show1-firstless)
+    ("conjugate" org-drill-present-verb-conjugation
+     org-drill-show-answer-verb-conjugation)
+    ("spanish_verb" . org-drill-present-spanish-verb)
+    ("translate_number" org-drill-present-translate-number
+     org-drill-show-answer-translate-number))
+  "Alist associating card types with presentation functions. Each entry in the
+alist takes one of two forms:
+1. (CARDTYPE . QUESTION-FN), where CARDTYPE is a string or nil (for default),
+   and QUESTION-FN is a function which takes no arguments and returns a boolean
+   value.
+2. (CARDTYPE QUESTION-FN ANSWER-FN), where ANSWER-FN is a function that takes
+   one argument -- the argument is a function that itself takes no arguments.
+   ANSWER-FN is called with the point on the active item's
+   heading, just prior to displaying the item's 'answer'. It can therefore be
+   used to modify the appearance of the answer. ANSWER-FN must call its argument
+   before returning. (Its argument is a function that prompts the user and
+   performs rescheduling)."
+  :group 'org-drill
+  :type '(alist :key-type (choice string (const nil)) :value-type function))
+
+
+(defcustom org-drill-scope
+  'file
+  "The scope in which to search for drill items when conducting a
+drill session. This can be any of:
+
+file                 The current buffer, respecting the restriction if any.
+                     This is the default.
+tree                 The subtree started with the entry at point
+file-no-restriction  The current buffer, without restriction
+file-with-archives   The current buffer, and any archives associated with it.
+agenda               All agenda files
+agenda-with-archives All agenda files with any archive files associated
+                     with them.
+directory            All files with the extension '.org' in the same
+                     directory as the current file (includes the current
+                     file if it is an .org file.)
+ (FILE1 FILE2 ...)   If this is a list, all files in the list will be scanned.
+"
+  ;; Note -- meanings differ slightly from the argument to org-map-entries:
+  ;; 'file' means current file/buffer, respecting any restriction
+  ;; 'file-no-restriction' means current file/buffer, ignoring restrictions
+  ;; 'directory' means all *.org files in current directory
+  :group 'org-drill
+  :type '(choice (const 'file) (const 'tree) (const 'file-no-restriction)
+                 (const 'file-with-archives) (const 'agenda)
+                 (const 'agenda-with-archives) (const 'directory)
+                 list))
+
+
+(defcustom org-drill-save-buffers-after-drill-sessions-p
+  t
+  "If non-nil, prompt to save all modified buffers after a drill session
+finishes."
+  :group 'org-drill
+  :type 'boolean)
+
+
+(defcustom org-drill-spaced-repetition-algorithm
+  'sm5
+  "Which SuperMemo spaced repetition algorithm to use for scheduling items.
+Available choices are:
+- SM2 :: the SM2 algorithm, used in SuperMemo 2.0
+- SM5 :: the SM5 algorithm, used in SuperMemo 5.0
+- Simple8 :: a modified version of the SM8 algorithm. SM8 is used in
+  SuperMemo 98. The version implemented here is simplified in that while it
+  'learns' the difficulty of each item using quality grades and number of
+  failures, it does not modify the matrix of values that
+  governs how fast the inter-repetition intervals increase. A method for
+  adjusting intervals when items are reviewed early or late has been taken
+  from SM11, a later version of the algorithm, and included in Simple8."
+  :group 'org-drill
+  :type '(choice (const 'sm2) (const 'sm5) (const 'simple8)))
+
+
+(defcustom org-drill-optimal-factor-matrix
+  nil
+  "DO NOT CHANGE THE VALUE OF THIS VARIABLE.
+
+Persistent matrix of optimal factors, used by the SuperMemo SM5 algorithm.
+The matrix is saved (using the 'customize' facility) at the end of each
+drill session.
+
+Over time, values in the matrix will adapt to the individual user's
+pace of learning."
+  :group 'org-drill
+  :type 'sexp)
+
+
+(defcustom org-drill-sm5-initial-interval
+  4.0
+  "In the SM5 algorithm, the initial interval after the first
+successful presentation of an item is always 4 days. If you wish to change
+this, you can do so here."
+  :group 'org-drill
+  :type 'float)
+
+
+(defcustom org-drill-add-random-noise-to-intervals-p
+  nil
+  "If true, the number of days until an item's next repetition
+will vary slightly from the interval calculated by the SM2
+algorithm. The variation is very small when the interval is
+small, but scales up with the interval."
+  :group 'org-drill
+  :type 'boolean)
+
+
+(defcustom org-drill-adjust-intervals-for-early-and-late-repetitions-p
+  nil
+  "If true, when the student successfully reviews an item 1 or more days
+before or after the scheduled review date, this will affect that date of
+the item's next scheduled review, according to the algorithm presented at
+ [[http://www.supermemo.com/english/algsm11.htm#Advanced%20repetitions]].
+
+Items that were reviewed early will have their next review date brought
+forward. Those that were reviewed late will have their next review
+date postponed further.
+
+Note that this option currently has no effect if the SM2 algorithm
+is used."
+  :group 'org-drill
+  :type 'boolean)
+
+
+(defcustom org-drill-cloze-text-weight
+  4
+  "For card types 'hide1_firstmore', 'show1_lastmore' and 'show1_firstless',
+this number determines how often the 'less favoured' situation
+should arise. It will occur 1 in every N trials, where N is the
+value of the variable.
+
+For example, with the hide1_firstmore card type, the first piece
+of clozed text should be hidden more often than the other
+pieces. If this variable is set to 4 (default), the first item
+will only be shown 25% of the time (1 in 4 trials). Similarly for
+show1_lastmore, the last item will be shown 75% of the time, and
+for show1_firstless, the first item would only be shown 25% of the
+time.
+
+If the value of this variable is NIL, then weighting is disabled, and
+all weighted card types are treated as their unweighted equivalents."
+  :group 'org-drill
+  :type '(choice integer (const nil)))
+
+
+(defcustom org-drill-cram-hours
+  12
+  "When in cram mode, items are considered due for review if
+they were reviewed at least this many hours ago."
+  :group 'org-drill
+  :type 'integer)
+
+
+;;; NEW items have never been presented in a drill session before.
+;;; MATURE items HAVE been presented at least once before.
+;;; - YOUNG mature items were scheduled no more than
+;;;   ORG-DRILL-DAYS-BEFORE-OLD days after their last
+;;;   repetition. These items will have been learned 'recently' and will have a
+;;;   low repetition count.
+;;; - OLD mature items have intervals greater than
+;;;   ORG-DRILL-DAYS-BEFORE-OLD.
+;;; - OVERDUE items are past their scheduled review date by more than
+;;;   LAST-INTERVAL * (ORG-DRILL-OVERDUE-INTERVAL-FACTOR - 1) days,
+;;;   regardless of young/old status.
+
+
+(defcustom org-drill-days-before-old
+  10
+  "When an item's inter-repetition interval rises above this value in days,
+it is no longer considered a 'young' (recently learned) item."
+  :group 'org-drill
+  :type 'integer)
+
+
+(defcustom org-drill-overdue-interval-factor
+  1.2
+  "An item is considered overdue if its scheduled review date is
+more than (ORG-DRILL-OVERDUE-INTERVAL-FACTOR - 1) * LAST-INTERVAL
+days in the past. For example, a value of 1.2 means an additional
+20% of the last scheduled interval is allowed to elapse before
+the item is overdue. A value of 1.0 means no extra time is
+allowed at all - items are immediately considered overdue if
+there is even one day's delay in reviewing them. This variable
+should never be less than 1.0."
+  :group 'org-drill
+  :type 'float)
+
+
+(defcustom org-drill-learn-fraction
+  0.5
+  "Fraction between 0 and 1 that governs how quickly the spaces
+between successive repetitions increase, for all items. The
+default value is 0.5. Higher values make spaces increase more
+quickly with each successful repetition. You should only change
+this in small increments (for example 0.05-0.1) as it has an
+exponential effect on inter-repetition spacing."
+  :group 'org-drill
+  :type 'float)
+
+
+(defvar *org-drill-session-qualities* nil)
+(defvar *org-drill-start-time* 0)
+(defvar *org-drill-new-entries* nil)
+(defvar *org-drill-dormant-entry-count* 0)
+(defvar *org-drill-due-entry-count* 0)
+(defvar *org-drill-overdue-entry-count* 0)
+(defvar *org-drill-due-tomorrow-count* 0)
+(defvar *org-drill-overdue-entries* nil
+  "List of markers for items that are considered 'overdue', based on
+the value of ORG-DRILL-OVERDUE-INTERVAL-FACTOR.")
+(defvar *org-drill-young-mature-entries* nil
+  "List of markers for mature entries whose last inter-repetition
+interval was <= ORG-DRILL-DAYS-BEFORE-OLD days.")
+(defvar *org-drill-old-mature-entries* nil
+  "List of markers for mature entries whose last inter-repetition
+interval was greater than ORG-DRILL-DAYS-BEFORE-OLD days.")
+(defvar *org-drill-failed-entries* nil)
+(defvar *org-drill-again-entries* nil)
+(defvar *org-drill-done-entries* nil)
+(defvar *org-drill-current-item* nil
+  "Set to the marker for the item currently being tested.")
+(defvar *org-drill-cram-mode* nil
+  "Are we in 'cram mode', where all items are considered due
+for review unless they were already reviewed in the recent past?")
+(defvar org-drill-scheduling-properties
+  '("LEARN_DATA" "DRILL_LAST_INTERVAL" "DRILL_REPEATS_SINCE_FAIL"
+    "DRILL_TOTAL_REPEATS" "DRILL_FAILURE_COUNT" "DRILL_AVERAGE_QUALITY"
+    "DRILL_EASE" "DRILL_LAST_QUALITY" "DRILL_LAST_REVIEWED"))
+
+
+;;; Make the above settings safe as file-local variables.
+
+
+(put 'org-drill-question-tag 'safe-local-variable 'stringp)
+(put 'org-drill-maximum-items-per-session 'safe-local-variable
+     '(lambda (val) (or (integerp val) (null val))))
+(put 'org-drill-maximum-duration 'safe-local-variable
+     '(lambda (val) (or (integerp val) (null val))))
+(put 'org-drill-failure-quality 'safe-local-variable 'integerp)
+(put 'org-drill-forgetting-index 'safe-local-variable 'integerp)
+(put 'org-drill-leech-failure-threshold 'safe-local-variable 'integerp)
+(put 'org-drill-leech-method 'safe-local-variable
+     '(lambda (val) (memq val '(nil skip warn))))
+(put 'org-drill-use-visible-cloze-face-p 'safe-local-variable 'booleanp)
+(put 'org-drill-hide-item-headings-p 'safe-local-variable 'booleanp)
+(put 'org-drill-spaced-repetition-algorithm 'safe-local-variable
+     '(lambda (val) (memq val '(simple8 sm5 sm2))))
+(put 'org-drill-sm5-initial-interval 'safe-local-variable 'floatp)
+(put 'org-drill-add-random-noise-to-intervals-p 'safe-local-variable 'booleanp)
+(put 'org-drill-adjust-intervals-for-early-and-late-repetitions-p
+     'safe-local-variable 'booleanp)
+(put 'org-drill-cram-hours 'safe-local-variable 'integerp)
+(put 'org-drill-learn-fraction 'safe-local-variable 'floatp)
+(put 'org-drill-days-before-old 'safe-local-variable 'integerp)
+(put 'org-drill-overdue-interval-factor 'safe-local-variable 'floatp)
+(put 'org-drill-scope 'safe-local-variable
+     '(lambda (val) (or (symbolp val) (listp val))))
+(put 'org-drill-save-buffers-after-drill-sessions-p 'safe-local-variable 'booleanp)
+(put 'org-drill-cloze-text-weight 'safe-local-variable
+     '(lambda (val) (or (null val) (integerp val))))
+
+
+;;;; Utilities ================================================================
+
+
+(defun free-marker (m)
+  (set-marker m nil))
+
+
+(defmacro pop-random (place)
+  (let ((idx (gensym)))
+    `(if (null ,place)
+         nil
+       (let ((,idx (random* (length ,place))))
+         (prog1 (nth ,idx ,place)
+           (setq ,place (append (subseq ,place 0 ,idx)
+                                (subseq ,place (1+ ,idx)))))))))
+
+
+(defmacro push-end (val place)
+  "Add VAL to the end of the sequence stored in PLACE. Return the new
+value."
+  `(setq ,place (append ,place (list ,val))))
+
+
+(defun shuffle-list (list)
+  "Randomly permute the elements of LIST (all permutations equally likely)."
+  ;; Adapted from 'shuffle-vector' in cookie1.el
+  (let ((i 0)
+	j
+	temp
+	(len (length list)))
+    (while (< i len)
+      (setq j (+ i (random* (- len i))))
+      (setq temp (nth i list))
+      (setf (nth i list) (nth j list))
+      (setf (nth j list) temp)
+      (setq i (1+ i))))
+  list)
+
+
+(defun round-float (floatnum fix)
+  "Round the floating point number FLOATNUM to FIX decimal places.
+Example: (round-float 3.56755765 3) -> 3.568"
+  (let ((n (expt 10 fix)))
+    (/ (float (round (* floatnum n))) n)))
+
+
+(defun command-keybinding-to-string (cmd)
+  "Return a human-readable description of the key/keys to which the command
+CMD is bound, or nil if it is not bound to a key."
+  (let ((key (where-is-internal cmd overriding-local-map t)))
+    (if key (key-description key))))
+
+
+(defun time-to-inactive-org-timestamp (time)
+  (format-time-string
+   (concat "[" (substring (cdr org-time-stamp-formats) 1 -1) "]")
+   time))
+
+
+(defun org-map-drill-entries (func &optional scope &rest skip)
+  "Like `org-map-entries', but only drill entries are processed."
+  (let ((org-drill-scope (or scope org-drill-scope)))
+    (apply 'org-map-entries func
+           (concat "+" org-drill-question-tag)
+           (case org-drill-scope
+             (file nil)
+             (file-no-restriction 'file)
+             (directory
+              (directory-files (file-name-directory (buffer-file-name))
+                               t "\\.org$"))
+             (t org-drill-scope))
+           skip)))
+
+
+(defmacro with-hidden-cloze-text (&rest body)
+  `(progn
+     (org-drill-hide-clozed-text)
+     (unwind-protect
+         (progn
+           ,@body)
+       (org-drill-unhide-clozed-text))))
+
+
+(defmacro with-hidden-cloze-hints (&rest body)
+  `(progn
+     (org-drill-hide-cloze-hints)
+     (unwind-protect
+         (progn
+           ,@body)
+       (org-drill-unhide-text))))
+
+
+(defmacro with-hidden-comments (&rest body)
+  `(progn
+     (if org-drill-hide-item-headings-p
+         (org-drill-hide-heading-at-point))
+     (org-drill-hide-comments)
+     (unwind-protect
+         (progn
+           ,@body)
+       (org-drill-unhide-text))))
+
+
+(defun org-drill-days-since-last-review ()
+  "Nil means a last review date has not yet been stored for
+the item.
+Zero means it was reviewed today.
+A positive number means it was reviewed that many days ago.
+A negative number means the date of last review is in the future --
+this should never happen."
+  (let ((datestr (org-entry-get (point) "DRILL_LAST_REVIEWED")))
+    (when datestr
+      (- (time-to-days (current-time))
+         (time-to-days (apply 'encode-time
+                              (org-parse-time-string datestr)))))))
+
+
+(defun org-drill-hours-since-last-review ()
+  "Like `org-drill-days-since-last-review', but return value is
+in hours rather than days."
+  (let ((datestr (org-entry-get (point) "DRILL_LAST_REVIEWED")))
+    (when datestr
+      (floor
+       (/ (- (time-to-seconds (current-time))
+             (time-to-seconds (apply 'encode-time
+                                     (org-parse-time-string datestr))))
+          (* 60 60))))))
+
+
+(defun org-drill-entry-p (&optional marker)
+  "Is MARKER, or the point, in a 'drill item'? This will return nil if
+the point is inside a subheading of a drill item -- to handle that
+situation use `org-part-of-drill-entry-p'."
+  (save-excursion
+    (when marker
+      (org-drill-goto-entry marker))
+    (member org-drill-question-tag (org-get-local-tags))))
+
+
+(defun org-drill-goto-entry (marker)
+  (switch-to-buffer (marker-buffer marker))
+  (goto-char marker))
+
+
+(defun org-part-of-drill-entry-p ()
+  "Is the current entry either the main heading of a 'drill item',
+or a subheading within a drill item?"
+  (or (org-drill-entry-p)
+      ;; Does this heading INHERIT the drill tag
+      (member org-drill-question-tag (org-get-tags-at))))
+
+
+(defun org-drill-goto-drill-entry-heading ()
+  "Move the point to the heading which holds the :drill: tag for this
+drill entry."
+  (unless (org-at-heading-p)
+    (org-back-to-heading))
+  (unless (org-part-of-drill-entry-p)
+    (error "Point is not inside a drill entry"))
+  (while (not (org-drill-entry-p))
+    (unless (org-up-heading-safe)
+      (error "Cannot find a parent heading that is marked as a drill entry"))))
+
+
+
+(defun org-drill-entry-leech-p ()
+  "Is the current entry a 'leech item'?"
+  (and (org-drill-entry-p)
+       (member "leech" (org-get-local-tags))))
+
+
+;; (defun org-drill-entry-due-p ()
+;;   (cond
+;;    (*org-drill-cram-mode*
+;;     (let ((hours (org-drill-hours-since-last-review)))
+;;       (and (org-drill-entry-p)
+;;            (or (null hours)
+;;                (>= hours org-drill-cram-hours)))))
+;;    (t
+;;     (let ((item-time (org-get-scheduled-time (point))))
+;;       (and (org-drill-entry-p)
+;;            (or (not (eql 'skip org-drill-leech-method))
+;;                (not (org-drill-entry-leech-p)))
+;;            (or (null item-time)         ; not scheduled
+;;                (not (minusp             ; scheduled for today/in past
+;;                      (- (time-to-days (current-time))
+;;                         (time-to-days item-time))))))))))
+
+
+(defun org-drill-entry-days-overdue ()
+  "Returns:
+- NIL if the item is not to be regarded as scheduled for review at all.
+  This is the case if it is not a drill item, or if it is a leech item
+  that we wish to skip, or if we are in cram mode and have already reviewed
+  the item within the last few hours.
+- 0 if the item is new, or if it scheduled for review today.
+- A negative integer - item is scheduled that many days in the future.
+- A positive integer - item is scheduled that many days in the past."
+  (cond
+   (*org-drill-cram-mode*
+    (let ((hours (org-drill-hours-since-last-review)))
+      (and (org-drill-entry-p)
+           (or (null hours)
+               (>= hours org-drill-cram-hours))
+           0)))
+   (t
+    (let ((item-time (org-get-scheduled-time (point))))
+      (cond
+       ((or (not (org-drill-entry-p))
+            (and (eql 'skip org-drill-leech-method)
+                 (org-drill-entry-leech-p)))
+        nil)
+       ((null item-time)                ; not scheduled -> due now
+        0)
+       (t
+        (- (time-to-days (current-time))
+           (time-to-days item-time))))))))
+
+
+(defun org-drill-entry-overdue-p (&optional days-overdue last-interval)
+  "Returns true if entry that is scheduled DAYS-OVERDUE dasy in the past,
+and whose last inter-repetition interval was LAST-INTERVAL, should be
+considered 'overdue'. If the arguments are not given they are extracted
+from the entry at point."
+  (unless days-overdue
+    (setq days-overdue (org-drill-entry-days-overdue)))
+  (unless last-interval
+    (setq last-interval (org-drill-entry-last-interval 1)))
+  (and (numberp days-overdue)
+       (> days-overdue 1)               ; enforce a sane minimum 'overdue' gap
+       ;;(> due org-drill-days-before-overdue)
+       (> (/ (+ days-overdue last-interval 1.0) last-interval)
+          org-drill-overdue-interval-factor)))
+
+
+
+(defun org-drill-entry-due-p ()
+  (let ((due (org-drill-entry-days-overdue)))
+    (and (not (null due))
+         (not (minusp due)))))
+
+
+(defun org-drill-entry-new-p ()
+  (and (org-drill-entry-p)
+       (let ((item-time (org-get-scheduled-time (point))))
+         (null item-time))))
+
+
+(defun org-drill-entry-last-quality (&optional default)
+  (let ((quality (org-entry-get (point) "DRILL_LAST_QUALITY")))
+    (if quality
+        (string-to-number quality)
+      default)))
+
+
+(defun org-drill-entry-failure-count ()
+  (let ((quality (org-entry-get (point) "DRILL_FAILURE_COUNT")))
+    (if quality
+        (string-to-number quality)
+      0)))
+
+
+(defun org-drill-entry-average-quality (&optional default)
+  (let ((val (org-entry-get (point) "DRILL_AVERAGE_QUALITY")))
+    (if val
+        (string-to-number val)
+      (or default nil))))
+
+(defun org-drill-entry-last-interval (&optional default)
+  (let ((val (org-entry-get (point) "DRILL_LAST_INTERVAL")))
+    (if val
+        (string-to-number val)
+      (or default 0))))
+
+(defun org-drill-entry-repeats-since-fail (&optional default)
+  (let ((val (org-entry-get (point) "DRILL_REPEATS_SINCE_FAIL")))
+    (if val
+        (string-to-number val)
+      (or default 0))))
+
+(defun org-drill-entry-total-repeats (&optional default)
+  (let ((val (org-entry-get (point) "DRILL_TOTAL_REPEATS")))
+    (if val
+        (string-to-number val)
+      (or default 0))))
+
+(defun org-drill-entry-ease (&optional default)
+  (let ((val (org-entry-get (point) "DRILL_EASE")))
+    (if val
+        (string-to-number val)
+      default)))
+
+
+;;; From http://www.supermemo.com/english/ol/sm5.htm
+(defun org-drill-random-dispersal-factor ()
+  "Returns a random number between 0.5 and 1.5."
+  (let ((a 0.047)
+        (b 0.092)
+        (p (- (random* 1.0) 0.5)))
+    (flet ((sign (n)
+                 (cond ((zerop n) 0)
+                       ((plusp n) 1)
+                       (t -1))))
+      (/ (+ 100 (* (* (/ -1 b) (log (- 1 (* (/ b a ) (abs p)))))
+                   (sign p)))
+         100.0))))
+
+(defun pseudonormal (mean variation)
+  "Random numbers in a pseudo-normal distribution with mean MEAN, range
+    MEAN-VARIATION to MEAN+VARIATION"
+  (+  (random* variation)
+      (random* variation)
+      (- variation)
+      mean))
+
+
+(defun org-drill-early-interval-factor (optimal-factor
+                                                optimal-interval
+                                                days-ahead)
+  "Arguments:
+- OPTIMAL-FACTOR: interval-factor if the item had been tested
+exactly when it was supposed to be.
+- OPTIMAL-INTERVAL: interval for next repetition (days) if the item had been
+tested exactly when it was supposed to be.
+- DAYS-AHEAD: how many days ahead of time the item was reviewed.
+
+Returns an adjusted optimal factor which should be used to
+calculate the next interval, instead of the optimal factor found
+in the matrix."
+  (let ((delta-ofmax (* (1- optimal-factor)
+                    (/ (+ optimal-interval
+                          (* 0.6 optimal-interval) -1) (1- optimal-interval)))))
+    (- optimal-factor
+       (* delta-ofmax (/ days-ahead (+ days-ahead (* 0.6 optimal-interval)))))))
+
+
+(defun org-drill-get-item-data ()
+  "Returns a list of 6 items, containing all the stored recall
+  data for the item at point:
+- LAST-INTERVAL is the interval in days that was used to schedule the item's
+  current review date.
+- REPEATS is the number of items the item has been successfully recalled without
+  without any failures. It is reset to 0 upon failure to recall the item.
+- FAILURES is the total number of times the user has failed to recall the item.
+- TOTAL-REPEATS includes both successful and unsuccessful repetitions.
+- AVERAGE-QUALITY is the mean quality of recall of the item over
+  all its repetitions, successful and unsuccessful.
+- EASE is a number reflecting how easy the item is to learn. Higher is easier.
+"
+  (let ((learn-str (org-entry-get (point) "LEARN_DATA"))
+        (repeats (org-drill-entry-total-repeats :missing)))
+    (cond
+     (learn-str
+      (let ((learn-data (or (and learn-str
+                                 (read learn-str))
+                            (copy-list initial-repetition-state))))
+        (list (nth 0 learn-data)        ; last interval
+              (nth 1 learn-data)        ; repetitions
+              (org-drill-entry-failure-count)
+              (nth 1 learn-data)
+              (org-drill-entry-last-quality)
+              (nth 2 learn-data)        ; EF
+              )))
+     ((not (eql :missing repeats))
+      (list (org-drill-entry-last-interval)
+            (org-drill-entry-repeats-since-fail)
+            (org-drill-entry-failure-count)
+            (org-drill-entry-total-repeats)
+            (org-drill-entry-average-quality)
+            (org-drill-entry-ease)))
+     (t  ; virgin item
+      (list 0 0 0 0 nil nil)))))
+
+
+(defun org-drill-store-item-data (last-interval repeats failures
+                                                total-repeats meanq
+                                                ease)
+  "Stores the given data in the item at point."
+  (org-entry-delete (point) "LEARN_DATA")
+  (org-set-property "DRILL_LAST_INTERVAL"
+                    (number-to-string (round-float last-interval 4)))
+  (org-set-property "DRILL_REPEATS_SINCE_FAIL" (number-to-string repeats))
+  (org-set-property "DRILL_TOTAL_REPEATS" (number-to-string total-repeats))
+  (org-set-property "DRILL_FAILURE_COUNT" (number-to-string failures))
+  (org-set-property "DRILL_AVERAGE_QUALITY"
+                    (number-to-string (round-float meanq 3)))
+  (org-set-property "DRILL_EASE"
+                    (number-to-string (round-float ease 3))))
+
+
+
+;;; SM2 Algorithm =============================================================
+
+
+(defun determine-next-interval-sm2 (last-interval n ef quality
+                                                  failures meanq total-repeats)
+  "Arguments:
+- LAST-INTERVAL -- the number of days since the item was last reviewed.
+- REPEATS -- the number of times the item has been successfully reviewed
+- EF -- the 'easiness factor'
+- QUALITY -- 0 to 5
+
+Returns a list: (INTERVAL REPEATS EF FAILURES MEAN TOTAL-REPEATS OFMATRIX), where:
+- INTERVAL is the number of days until the item should next be reviewed
+- REPEATS is incremented by 1.
+- EF is modified based on the recall quality for the item.
+- OF-MATRIX is not modified."
+  (assert (> n 0))
+  (assert (and (>= quality 0) (<= quality 5)))
+  (if (<= quality org-drill-failure-quality)
+      ;; When an item is failed, its interval is reset to 0,
+      ;; but its EF is unchanged
+      (list -1 1 ef (1+ failures) meanq (1+ total-repeats)
+            org-drill-optimal-factor-matrix)
+    ;; else:
+    (let* ((next-ef (modify-e-factor ef quality))
+           (interval
+            (cond
+             ((<= n 1) 1)
+             ((= n 2)
+              (cond
+               (org-drill-add-random-noise-to-intervals-p
+                (case quality
+                  (5 6)
+                  (4 4)
+                  (3 3)
+                  (2 1)
+                  (t -1)))
+               (t 6)))
+             (t (* last-interval next-ef)))))
+      (list (if org-drill-add-random-noise-to-intervals-p
+                (+ last-interval (* (- interval last-interval)
+                                    (org-drill-random-dispersal-factor)))
+              interval)
+            (1+ n)
+            next-ef
+            failures meanq (1+ total-repeats)
+            org-drill-optimal-factor-matrix))))
+
+
+;;; SM5 Algorithm =============================================================
+
+
+
+(defun initial-optimal-factor-sm5 (n ef)
+  (if (= 1 n)
+      org-drill-sm5-initial-interval
+    ef))
+
+(defun get-optimal-factor-sm5 (n ef of-matrix)
+  (let ((factors (assoc n of-matrix)))
+    (or (and factors
+	     (let ((ef-of (assoc ef (cdr factors))))
+	       (and ef-of (cdr ef-of))))
+	(initial-optimal-factor-sm5 n ef))))
+
+
+(defun inter-repetition-interval-sm5 (last-interval n ef &optional of-matrix)
+  (let ((of (get-optimal-factor-sm5 n ef (or of-matrix
+                                             org-drill-optimal-factor-matrix))))
+    (if (= 1 n)
+	of
+      (* of last-interval))))
+
+
+(defun determine-next-interval-sm5 (last-interval n ef quality
+                                                  failures meanq total-repeats
+                                                  of-matrix &optional delta-days)
+  (if (zerop n) (setq n 1))
+  (if (null ef) (setq ef 2.5))
+  (assert (> n 0))
+  (assert (and (>= quality 0) (<= quality 5)))
+  (unless of-matrix
+    (setq of-matrix org-drill-optimal-factor-matrix))
+  (setq of-matrix (cl-copy-tree of-matrix))
+
+  (setq meanq (if meanq
+                  (/ (+ quality (* meanq total-repeats 1.0))
+                     (1+ total-repeats))
+                quality))
+
+  (let ((next-ef (modify-e-factor ef quality))
+        (old-ef ef)
+        (new-of (modify-of (get-optimal-factor-sm5 n ef of-matrix)
+                           quality org-drill-learn-fraction))
+        (interval nil))
+    (when (and org-drill-adjust-intervals-for-early-and-late-repetitions-p
+               delta-days (minusp delta-days))
+      (setq new-of (org-drill-early-interval-factor
+                    (get-optimal-factor-sm5 n ef of-matrix)
+                    (inter-repetition-interval-sm5
+                     last-interval n ef of-matrix)
+                    delta-days)))
+
+    (setq of-matrix
+          (set-optimal-factor n next-ef of-matrix
+                              (round-float new-of 3))) ; round OF to 3 d.p.
+
+    (setq ef next-ef)
+
+    (cond
+     ;; "Failed" -- reset repetitions to 0,
+     ((<= quality org-drill-failure-quality)
+      (list -1 1 old-ef (1+ failures) meanq (1+ total-repeats)
+            of-matrix))     ; Not clear if OF matrix is supposed to be
+                                        ; preserved
+     ;; For a zero-based quality of 4 or 5, don't repeat
+     ;; ((and (>= quality 4)
+     ;;       (not org-learn-always-reschedule))
+     ;;  (list 0 (1+ n) ef failures meanq
+     ;;        (1+ total-repeats) of-matrix))     ; 0 interval = unschedule
+     (t
+      (setq interval (inter-repetition-interval-sm5
+                      last-interval n ef of-matrix))
+      (if org-drill-add-random-noise-to-intervals-p
+          (setq interval (* interval (org-drill-random-dispersal-factor))))
+      (list interval
+            (1+ n)
+            ef
+            failures
+            meanq
+            (1+ total-repeats)
+            of-matrix)))))
+
+
+;;; Simple8 Algorithm =========================================================
+
+
+(defun org-drill-simple8-first-interval (failures)
+  "Arguments:
+- FAILURES: integer >= 0. The total number of times the item has
+  been forgotten, ever.
+
+Returns the optimal FIRST interval for an item which has previously been
+forgotten on FAILURES occasions."
+  (* 2.4849 (exp (* -0.057 failures))))
+
+
+(defun org-drill-simple8-interval-factor (ease repetition)
+  "Arguments:
+- EASE: floating point number >= 1.2. Corresponds to `AF' in SM8 algorithm.
+- REPETITION: the number of times the item has been tested.
+1 is the first repetition (ie the second trial).
+Returns:
+The factor by which the last interval should be
+multiplied to give the next interval. Corresponds to `RF' or `OF'."
+  (+ 1.2 (* (- ease 1.2) (expt org-drill-learn-fraction (log repetition 2)))))
+
+
+(defun org-drill-simple8-quality->ease (quality)
+  "Returns the ease (`AF' in the SM8 algorithm) which corresponds
+to a mean item quality of QUALITY."
+  (+ (* 0.0542 (expt quality 4))
+     (* -0.4848 (expt quality 3))
+     (* 1.4916 (expt quality 2))
+     (* -1.2403 quality)
+     1.4515))
+
+
+(defun determine-next-interval-simple8 (last-interval repeats quality
+                                                      failures meanq totaln
+                                                      &optional delta-days)
+  "Arguments:
+- LAST-INTERVAL -- the number of days since the item was last reviewed.
+- REPEATS -- the number of times the item has been successfully reviewed
+- EASE -- the 'easiness factor'
+- QUALITY -- 0 to 5
+- DELTA-DAYS -- how many days overdue was the item when it was reviewed.
+  0 = reviewed on the scheduled day. +N = N days overdue.
+  -N = reviewed N days early.
+
+Returns the new item data, as a list of 6 values:
+- NEXT-INTERVAL
+- REPEATS
+- EASE
+- FAILURES
+- AVERAGE-QUALITY
+- TOTAL-REPEATS.
+See the documentation for `org-drill-get-item-data' for a description of these."
+  (assert (>= repeats 0))
+  (assert (and (>= quality 0) (<= quality 5)))
+  (assert (or (null meanq) (and (>= meanq 0) (<= meanq 5))))
+  (let ((next-interval nil))
+    (setf meanq (if meanq
+                    (/ (+ quality (* meanq totaln 1.0)) (1+ totaln))
+                  quality))
+    (cond
+     ((<= quality org-drill-failure-quality)
+      (incf failures)
+      (setf repeats 0
+            next-interval -1))
+     ((or (zerop repeats)
+          (zerop last-interval))
+      (setf next-interval (org-drill-simple8-first-interval failures))
+      (incf repeats)
+      (incf totaln))
+     (t
+      (let* ((use-n
+              (if (and
+                   org-drill-adjust-intervals-for-early-and-late-repetitions-p
+                   (numberp delta-days) (plusp delta-days)
+                   (plusp last-interval))
+                  (+ repeats (min 1 (/ delta-days last-interval 1.0)))
+                repeats))
+             (factor (org-drill-simple8-interval-factor
+                      (org-drill-simple8-quality->ease meanq) use-n))
+             (next-int (* last-interval factor)))
+        (when (and org-drill-adjust-intervals-for-early-and-late-repetitions-p
+                   (numberp delta-days) (minusp delta-days))
+          ;; The item was reviewed earlier than scheduled.
+          (setf factor (org-drill-early-interval-factor
+                        factor next-int (abs delta-days))
+                next-int (* last-interval factor)))
+        (setf next-interval next-int)
+        (incf repeats)
+        (incf totaln))))
+    (list
+     (if (and org-drill-add-random-noise-to-intervals-p
+              (plusp next-interval))
+         (* next-interval (org-drill-random-dispersal-factor))
+       next-interval)
+     repeats
+     (org-drill-simple8-quality->ease meanq)
+     failures
+     meanq
+     totaln
+     )))
+
+
+
+
+;;; Essentially copied from `org-learn.el', but modified to
+;;; optionally call the SM2 or simple8 functions.
+(defun org-drill-smart-reschedule (quality &optional days-ahead)
+  "If DAYS-AHEAD is supplied it must be a positive integer. The
+item will be scheduled exactly this many days into the future."
+  (let ((delta-days (- (time-to-days (current-time))
+                   (time-to-days (or (org-get-scheduled-time (point))
+                                     (current-time)))))
+        (ofmatrix org-drill-optimal-factor-matrix)
+        ;; Entries can have weights, 1 by default. Intervals are divided by the
+        ;; item's weight, so an item with a weight of 2 will have all intervals
+        ;; halved, meaning you will end up reviewing it twice as often.
+        ;; Useful for entries which randomly present any of several facts.
+        (weight (org-entry-get (point) "DRILL_CARD_WEIGHT")))
+    (if (stringp weight)
+        (setq weight (read weight)))
+    (destructuring-bind (last-interval repetitions failures
+                                       total-repeats meanq ease)
+        (org-drill-get-item-data)
+      (destructuring-bind (next-interval repetitions ease
+                                         failures meanq total-repeats
+                                         &optional new-ofmatrix)
+          (case org-drill-spaced-repetition-algorithm
+            (sm5 (determine-next-interval-sm5 last-interval repetitions
+                                              ease quality failures
+                                              meanq total-repeats ofmatrix))
+            (sm2 (determine-next-interval-sm2 last-interval repetitions
+                                              ease quality failures
+                                              meanq total-repeats))
+            (simple8 (determine-next-interval-simple8 last-interval repetitions
+                                                      quality failures meanq
+                                                      total-repeats
+                                                      delta-days)))
+        (if (numberp days-ahead)
+            (setq next-interval days-ahead))
+
+        (if (and (null days-ahead)
+                 (numberp weight) (plusp weight)
+                 (not (minusp next-interval)))
+            (setq next-interval
+                  (max 1.0 (+ last-interval
+                              (/ (- next-interval last-interval) weight)))))
+
+        (org-drill-store-item-data next-interval repetitions failures
+                                   total-repeats meanq ease)
+
+        (if (eql 'sm5 org-drill-spaced-repetition-algorithm)
+            (setq org-drill-optimal-factor-matrix new-ofmatrix))
+
+        (cond
+         ((= 0 days-ahead)
+          (org-schedule t))
+         ((minusp days-ahead)
+          (org-schedule nil (current-time)))
+         (t
+          (org-schedule nil (time-add (current-time)
+                                      (days-to-time
+                                       (round next-interval))))))))))
+
+
+(defun org-drill-hypothetical-next-review-date (quality)
+  "Returns an integer representing the number of days into the future
+that the current item would be scheduled, based on a recall quality
+of QUALITY."
+  (let ((weight (org-entry-get (point) "DRILL_CARD_WEIGHT")))
+    (destructuring-bind (last-interval repetitions failures
+                                       total-repeats meanq ease)
+        (org-drill-get-item-data)
+      (if (stringp weight)
+          (setq weight (read weight)))
+      (destructuring-bind (next-interval repetitions ease
+                                         failures meanq total-repeats
+                                         &optional ofmatrix)
+          (case org-drill-spaced-repetition-algorithm
+            (sm5 (determine-next-interval-sm5 last-interval repetitions
+                                              ease quality failures
+                                              meanq total-repeats
+                                              org-drill-optimal-factor-matrix))
+            (sm2 (determine-next-interval-sm2 last-interval repetitions
+                                              ease quality failures
+                                              meanq total-repeats))
+            (simple8 (determine-next-interval-simple8 last-interval repetitions
+                                                      quality failures meanq
+                                                      total-repeats)))
+        (cond
+         ((not (plusp next-interval))
+          0)
+         ((and (numberp weight) (plusp weight))
+          (+ last-interval
+             (max 1.0 (/ (- next-interval last-interval) weight))))
+         (t
+          next-interval))))))
+
+
+(defun org-drill-hypothetical-next-review-dates ()
+  (let ((intervals nil))
+    (dotimes (q 6)
+      (push (max (or (car intervals) 0)
+                 (org-drill-hypothetical-next-review-date q))
+            intervals))
+    (reverse intervals)))
+
+
+(defun org-drill-reschedule ()
+  "Returns quality rating (0-5), or nil if the user quit."
+  (let ((ch nil)
+        (input nil)
+        (next-review-dates (org-drill-hypothetical-next-review-dates)))
+    (save-excursion
+      (while (not (memq ch '(?q ?e ?0 ?1 ?2 ?3 ?4 ?5)))
+        (setq input (read-key-sequence
+                     (if (eq ch ??)
+                         (format "0-2 Means you have forgotten the item.
+3-5 Means you have remembered the item.
+
+0 - Completely forgot.
+1 - Even after seeing the answer, it still took a bit to sink in.
+2 - After seeing the answer, you remembered it.
+3 - It took you awhile, but you finally remembered. (+%s days)
+4 - After a little bit of thought you remembered. (+%s days)
+5 - You remembered the item really easily. (+%s days)
+
+How well did you do? (0-5, ?=help, e=edit, t=tags, q=quit)"
+                                 (round (nth 3 next-review-dates))
+                                 (round (nth 4 next-review-dates))
+                                 (round (nth 5 next-review-dates)))
+                       "How well did you do? (0-5, ?=help, e=edit, t=tags, q=quit)")))
+        (cond
+         ((stringp input)
+          (setq ch (elt input 0)))
+         ((and (vectorp input) (symbolp (elt input 0)))
+          (case (elt input 0)
+            (up (ignore-errors (forward-line -1)))
+            (down (ignore-errors (forward-line 1)))
+            (left (ignore-errors (backward-char)))
+            (right (ignore-errors (forward-char)))
+            (prior (ignore-errors (scroll-down))) ; pgup
+            (next (ignore-errors (scroll-up)))))  ; pgdn
+         ((and (vectorp input) (listp (elt input 0))
+               (eventp (elt input 0)))
+          (case (car (elt input 0))
+            (wheel-up (ignore-errors (mwheel-scroll (elt input 0))))
+            (wheel-down (ignore-errors (mwheel-scroll (elt input 0)))))))
+        (if (eql ch ?t)
+            (org-set-tags-command))))
+    (cond
+     ((and (>= ch ?0) (<= ch ?5))
+      (let ((quality (- ch ?0))
+            (failures (org-drill-entry-failure-count)))
+        (save-excursion
+          (org-drill-smart-reschedule quality
+                                      (nth quality next-review-dates)))
+        (push quality *org-drill-session-qualities*)
+        (cond
+         ((<= quality org-drill-failure-quality)
+          (when org-drill-leech-failure-threshold
+            ;;(setq failures (if failures (string-to-number failures) 0))
+            ;; (org-set-property "DRILL_FAILURE_COUNT"
+            ;;                   (format "%d" (1+ failures)))
+            (if (> (1+ failures) org-drill-leech-failure-threshold)
+                (org-toggle-tag "leech" 'on))))
+         (t
+          (let ((scheduled-time (org-get-scheduled-time (point))))
+            (when scheduled-time
+              (message "Next review in %d days"
+                       (- (time-to-days scheduled-time)
+                          (time-to-days (current-time))))
+              (sit-for 0.5)))))
+        (org-set-property "DRILL_LAST_QUALITY" (format "%d" quality))
+        (org-set-property "DRILL_LAST_REVIEWED"
+                          (time-to-inactive-org-timestamp (current-time)))
+        quality))
+     ((= ch ?e)
+      'edit)
+     (t
+      nil))))
+
+
+;; (defun org-drill-hide-all-subheadings-except (heading-list)
+;;   "Returns a list containing the position of each immediate subheading of
+;; the current topic."
+;;   (let ((drill-entry-level (org-current-level))
+;;         (drill-sections nil)
+;;         (drill-heading nil))
+;;     (org-show-subtree)
+;;     (save-excursion
+;;       (org-map-entries
+;;        (lambda ()
+;;          (when (and (not (outline-invisible-p))
+;;                     (> (org-current-level) drill-entry-level))
+;;            (setq drill-heading (org-get-heading t))
+;;            (unless (and (= (org-current-level) (1+ drill-entry-level))
+;;                         (member drill-heading heading-list))
+;;              (hide-subtree))
+;;            (push (point) drill-sections)))
+;;        "" 'tree))
+;;     (reverse drill-sections)))
+
+
+
+(defun org-drill-hide-subheadings-if (test)
+  "TEST is a function taking no arguments. TEST will be called for each
+of the immediate subheadings of the current drill item, with the point
+on the relevant subheading. TEST should return nil if the subheading is
+to be revealed, non-nil if it is to be hidden.
+Returns a list containing the position of each immediate subheading of
+the current topic."
+  (let ((drill-entry-level (org-current-level))
+        (drill-sections nil))
+    (org-show-subtree)
+    (save-excursion
+      (org-map-entries
+       (lambda ()
+         (when (and (not (outline-invisible-p))
+                    (> (org-current-level) drill-entry-level))
+           (when (or (/= (org-current-level) (1+ drill-entry-level))
+                        (funcall test))
+             (hide-subtree))
+           (push (point) drill-sections)))
+       "" 'tree))
+    (reverse drill-sections)))
+
+
+(defun org-drill-hide-all-subheadings-except (heading-list)
+  (org-drill-hide-subheadings-if
+   (lambda () (let ((drill-heading (org-get-heading t)))
+           (not (member drill-heading heading-list))))))
+
+
+(defun org-drill-presentation-prompt (&rest fmt-and-args)
+  (let* ((item-start-time (current-time))
+         (input nil)
+         (ch nil)
+         (last-second 0)
+         (mature-entry-count (+ (length *org-drill-young-mature-entries*)
+                                (length *org-drill-old-mature-entries*)
+                                (length *org-drill-overdue-entries*)))
+         (status (first (org-drill-entry-status)))
+         (prompt
+          (if fmt-and-args
+              (apply 'format
+                     (first fmt-and-args)
+                     (rest fmt-and-args))
+            (concat "Press key for answer, "
+                    "e=edit, t=tags, s=skip, q=quit."))))
+    (setq prompt
+          (format "%s %s %s %s %s %s"
+                  (propertize
+                   (char-to-string
+                    (case status
+                      (:new ?N) (:young ?Y) (:old ?o) (:overdue ?!)
+                      (:failed ?F) (t ??)))
+                   'face `(:foreground
+                           ,(case status
+                              (:new org-drill-new-count-color)
+                              ((:young :old) org-drill-mature-count-color)
+                              ((:overdue :failed) org-drill-failed-count-color)
+                              (t org-drill-done-count-color))))
+                  (propertize
+                   (number-to-string (length *org-drill-done-entries*))
+                   'face `(:foreground ,org-drill-done-count-color)
+                   'help-echo "The number of items you have reviewed this session.")
+                  (propertize
+                   (number-to-string (+ (length *org-drill-again-entries*)
+                                        (length *org-drill-failed-entries*)))
+                   'face `(:foreground ,org-drill-failed-count-color)
+                   'help-echo (concat "The number of items that you failed, "
+                                      "and need to review again."))
+                  (propertize
+                   (number-to-string mature-entry-count)
+                   'face `(:foreground ,org-drill-mature-count-color)
+                   'help-echo "The number of old items due for review.")
+                  (propertize
+                   (number-to-string (length *org-drill-new-entries*))
+                   'face `(:foreground ,org-drill-new-count-color)
+                   'help-echo (concat "The number of new items that you "
+                                      "have never reviewed."))
+                  prompt))
+    (if (and (eql 'warn org-drill-leech-method)
+             (org-drill-entry-leech-p))
+        (setq prompt (concat
+                      (propertize "!!! LEECH ITEM !!!
+You seem to be having a lot of trouble memorising this item.
+Consider reformulating the item to make it easier to remember.\n"
+                                  'face '(:foreground "red"))
+                      prompt)))
+    (while (memq ch '(nil ?t))
+      (setq ch nil)
+      (while (not (input-pending-p))
+        (let ((elapsed (time-subtract (current-time) item-start-time)))
+          (message (concat (if (>= (time-to-seconds elapsed) (* 60 60))
+                               "++:++ "
+                             (format-time-string "%M:%S " elapsed))
+                           prompt))
+          (sit-for 1)))
+      (setq input (read-key-sequence nil))
+      (if (stringp input) (setq ch (elt input 0)))
+      (if (eql ch ?t)
+          (org-set-tags-command)))
+    (case ch
+      (?q nil)
+      (?e 'edit)
+      (?s 'skip)
+      (otherwise t))))
+
+
+(defun org-pos-in-regexp (pos regexp &optional nlines)
+  (save-excursion
+    (goto-char pos)
+    (org-in-regexp regexp nlines)))
+
+
+(defun org-drill-hide-region (beg end &optional text)
+  "Hide the buffer region between BEG and END with an 'invisible text'
+visual overlay, or with the string TEXT if it is supplied."
+  (let ((ovl (make-overlay beg end)))
+    (overlay-put ovl 'category
+                 'org-drill-hidden-text-overlay)
+    (when (stringp text)
+      (overlay-put ovl 'invisible nil)
+      (overlay-put ovl 'face 'default)
+      (overlay-put ovl 'display text))))
+
+
+(defun org-drill-hide-heading-at-point (&optional text)
+  (unless (org-at-heading-p)
+    (error "Point is not on a heading"))
+  (save-excursion
+    (let ((beg (point)))
+      (end-of-line)
+      (org-drill-hide-region beg (point) text))))
+
+
+(defun org-drill-hide-comments ()
+  (save-excursion
+    (while (re-search-forward "^#.*$" nil t)
+      (org-drill-hide-region (match-beginning 0) (match-end 0)))))
+
+
+(defun org-drill-unhide-text ()
+  ;; This will also unhide the item's heading.
+  (save-excursion
+    (dolist (ovl (overlays-in (point-min) (point-max)))
+      (when (eql 'org-drill-hidden-text-overlay (overlay-get ovl 'category))
+        (delete-overlay ovl)))))
+
+
+(defun org-drill-hide-clozed-text ()
+  (save-excursion
+    (while (re-search-forward org-drill-cloze-regexp nil t)
+      ;; Don't hide org links, partly because they might contain inline
+      ;; images which we want to keep visible
+      (unless (save-match-data
+                (org-pos-in-regexp (match-beginning 0)
+                                   org-bracket-link-regexp 1))
+        (org-drill-hide-matched-cloze-text)))))
+
+
+(defun org-drill-hide-matched-cloze-text ()
+  "Hide the current match with a 'cloze' visual overlay."
+  (let ((ovl (make-overlay (match-beginning 0) (match-end 0))))
+    (overlay-put ovl 'category
+                 'org-drill-cloze-overlay-defaults)
+    (when (find ?| (match-string 0))
+      (let ((hint (substring-no-properties
+                   (match-string 0)
+                   (1+ (position ?| (match-string 0)))
+                   (1- (length (match-string 0))))))
+        (overlay-put
+         ovl 'display
+         ;; If hint is like `X...' then display [X...]
+         ;; otherwise display [...X]
+         (format (if (string-match-p "\\.\\.\\." hint) "[%s]" "[%s...]")
+                 hint))))))
+
+
+(defun org-drill-hide-cloze-hints ()
+  (save-excursion
+    (while (re-search-forward org-drill-cloze-regexp nil t)
+      (unless (or (save-match-data
+                    (org-pos-in-regexp (match-beginning 0)
+                                       org-bracket-link-regexp 1))
+                  (null (match-beginning 2))) ; hint subexpression matched
+        (org-drill-hide-region (match-beginning 2) (match-end 2))))))
+
+
+(defmacro with-replaced-entry-text (text &rest body)
+  "During the execution of BODY, the entire text of the current entry is
+concealed by an overlay that displays the string TEXT."
+  `(progn
+     (org-drill-replace-entry-text ,text)
+     (unwind-protect
+         (progn
+           ,@body)
+       (org-drill-unreplace-entry-text))))
+
+
+(defmacro with-replaced-entry-text-multi (replacements &rest body)
+  "During the execution of BODY, the entire text of the current entry is
+concealed by an overlay that displays the overlays in REPLACEMENTS."
+  `(progn
+     (org-drill-replace-entry-text ,replacements t)
+     (unwind-protect
+         (progn
+           ,@body)
+       (org-drill-unreplace-entry-text))))
+
+
+(defun org-drill-replace-entry-text (text &optional multi-p)
+  "Make an overlay that conceals the entire text of the item, not
+including properties or the contents of subheadings. The overlay shows
+the string TEXT.
+If MULTI-P is non-nil, TEXT must be a list of values which are legal
+for the `display' text property. The text of the item will be temporarily
+replaced by all of these items, in the order in which they appear in
+the list.
+Note: does not actually alter the item."
+  (cond
+   ((and multi-p
+         (listp text))
+    (org-drill-replace-entry-text-multi text))
+   (t
+    (let ((ovl (make-overlay (point-min)
+                             (save-excursion
+                               (outline-next-heading)
+                               (point)))))
+      (overlay-put ovl 'category
+                   'org-drill-replaced-text-overlay)
+      (overlay-put ovl 'display text)))))
+
+
+(defun org-drill-unreplace-entry-text ()
+  (save-excursion
+    (dolist (ovl (overlays-in (point-min) (point-max)))
+      (when (eql 'org-drill-replaced-text-overlay (overlay-get ovl 'category))
+        (delete-overlay ovl)))))
+
+
+(defun org-drill-replace-entry-text-multi (replacements)
+  "Make overlays that conceal the entire text of the item, not
+including properties or the contents of subheadings. The overlay shows
+the string TEXT.
+Note: does not actually alter the item."
+  (let ((ovl nil)
+        (p-min (point-min))
+        (p-max (save-excursion
+                 (outline-next-heading)
+                 (point))))
+    (assert (>= (- p-max p-min) (length replacements)))
+    (dotimes (i (length replacements))
+      (setq ovl (make-overlay (+ p-min (* 2 i))
+                              (if (= i (1- (length replacements)))
+                                  p-max
+                                (+ p-min (* 2 i) 1))))
+      (overlay-put ovl 'category
+                   'org-drill-replaced-text-overlay)
+      (overlay-put ovl 'display (nth i replacements)))))
+
+
+(defmacro with-replaced-entry-heading (heading &rest body)
+  `(progn
+     (org-drill-replace-entry-heading ,heading)
+     (unwind-protect
+         (progn
+           ,@body)
+       (org-drill-unhide-text))))
+
+
+(defun org-drill-replace-entry-heading (heading)
+  "Make an overlay that conceals the heading of the item. The overlay shows
+the string TEXT.
+Note: does not actually alter the item."
+  (org-drill-hide-heading-at-point heading))
+
+
+(defun org-drill-unhide-clozed-text ()
+  (save-excursion
+    (dolist (ovl (overlays-in (point-min) (point-max)))
+      (when (eql 'org-drill-cloze-overlay-defaults (overlay-get ovl 'category))
+        (delete-overlay ovl)))))
+
+
+(defun org-drill-get-entry-text (&optional keep-properties-p)
+  (let ((text (org-agenda-get-some-entry-text (point-marker) 100)))
+    (if keep-properties-p
+        text
+      (substring-no-properties text))))
+
+
+(defun org-drill-entry-empty-p ()
+  (zerop (length (org-drill-get-entry-text))))
+
+
+
+;;; Presentation functions ====================================================
+
+;; Each of these is called with point on topic heading.  Each needs to show the
+;; topic in the form of a 'question' or with some information 'hidden', as
+;; appropriate for the card type. The user should then be prompted to press a
+;; key. The function should then reveal either the 'answer' or the entire
+;; topic, and should return t if the user chose to see the answer and rate their
+;; recall, nil if they chose to quit.
+
+(defun org-drill-present-simple-card ()
+  (with-hidden-comments
+   (with-hidden-cloze-hints
+    (with-hidden-cloze-text
+     (org-drill-hide-all-subheadings-except nil)
+     (ignore-errors
+       (org-display-inline-images t))
+     (org-cycle-hide-drawers 'all)
+     (prog1 (org-drill-presentation-prompt)
+       (org-drill-hide-subheadings-if 'org-drill-entry-p))))))
+
+
+(defun org-drill-present-default-answer (reschedule-fn)
+  (org-drill-hide-subheadings-if 'org-drill-entry-p)
+  (org-drill-unhide-clozed-text)
+  (ignore-errors
+    (org-display-inline-images t))
+  (with-hidden-cloze-hints
+   (funcall reschedule-fn)))
+
+
+(defun org-drill-present-two-sided-card ()
+  (with-hidden-comments
+   (with-hidden-cloze-hints
+    (with-hidden-cloze-text
+     (let ((drill-sections (org-drill-hide-all-subheadings-except nil)))
+       (when drill-sections
+         (save-excursion
+           (goto-char (nth (random* (min 2 (length drill-sections)))
+                           drill-sections))
+           (org-show-subtree)))
+       (ignore-errors
+         (org-display-inline-images t))
+       (org-cycle-hide-drawers 'all)
+       (prog1 (org-drill-presentation-prompt)
+         (org-drill-hide-subheadings-if 'org-drill-entry-p)))))))
+
+
+
+(defun org-drill-present-multi-sided-card ()
+  (with-hidden-comments
+   (with-hidden-cloze-hints
+    (with-hidden-cloze-text
+     (let ((drill-sections (org-drill-hide-all-subheadings-except nil)))
+       (when drill-sections
+         (save-excursion
+           (goto-char (nth (random* (length drill-sections)) drill-sections))
+           (org-show-subtree)))
+       (ignore-errors
+         (org-display-inline-images t))
+       (org-cycle-hide-drawers 'all)
+       (prog1 (org-drill-presentation-prompt)
+         (org-drill-hide-subheadings-if 'org-drill-entry-p)))))))
+
+
+(defun org-drill-present-multicloze-hide-n (number-to-hide
+                                            &optional
+                                            force-show-first
+                                            force-show-last
+                                            force-hide-first)
+  "Hides NUMBER-TO-HIDE pieces of text that are marked for cloze deletion,
+chosen at random.
+If NUMBER-TO-HIDE is negative, show only (ABS NUMBER-TO-HIDE) pieces,
+hiding all the rest.
+If FORCE-HIDE-FIRST is non-nil, force the first piece of text to be one of
+the hidden items.
+If FORCE-SHOW-FIRST is non-nil, never hide the first piece of text.
+If FORCE-SHOW-LAST is non-nil, never hide the last piece of text.
+If the number of text pieces in the item is less than
+NUMBER-TO-HIDE, then all text pieces will be hidden (except the first or last
+items if FORCE-SHOW-FIRST or FORCE-SHOW-LAST is non-nil)."
+  (with-hidden-comments
+   (with-hidden-cloze-hints
+    (let ((item-end nil)
+          (match-count 0)
+          (body-start (or (cdr (org-get-property-block))
+                          (point))))
+      (if (and force-hide-first force-show-first)
+          (error "FORCE-HIDE-FIRST and FORCE-SHOW-FIRST are mutually exclusive"))
+      (org-drill-hide-all-subheadings-except nil)
+      (save-excursion
+        (outline-next-heading)
+        (setq item-end (point)))
+      (save-excursion
+        (goto-char body-start)
+        (while (re-search-forward org-drill-cloze-regexp item-end t)
+          (let ((in-regexp? (save-match-data
+                              (org-pos-in-regexp (match-beginning 0)
+                                                 org-bracket-link-regexp 1))))
+            (unless in-regexp?
+              (incf match-count)))))
+      (if (minusp number-to-hide)
+          (setq number-to-hide (+ match-count number-to-hide)))
+      (when (plusp match-count)
+        (let* ((positions (shuffle-list (loop for i from 1
+                                              to match-count
+                                              collect i)))
+               (match-nums nil)
+               (cnt nil))
+          (if force-hide-first
+              ;; Force '1' to be in the list, and to be the first item
+              ;; in the list.
+              (setq positions (cons 1 (remove 1 positions))))
+          (if force-show-first
+              (setq positions (remove 1 positions)))
+          (if force-show-last
+              (setq positions (remove match-count positions)))
+          (setq match-nums
+                (subseq positions
+                        0 (min number-to-hide (length positions))))
+          ;; (dolist (pos-to-hide match-nums)
+          (save-excursion
+            (goto-char body-start)
+            (setq cnt 0)
+            (while (re-search-forward org-drill-cloze-regexp item-end t)
+              (unless (save-match-data
+                        (org-pos-in-regexp (match-beginning 0)
+                                           org-bracket-link-regexp 1))
+                (incf cnt)
+                (if (memq cnt match-nums)
+                    (org-drill-hide-matched-cloze-text)))))))
+      ;; (loop
+      ;;  do (re-search-forward org-drill-cloze-regexp
+      ;;                        item-end t pos-to-hide)
+      ;;  while (org-pos-in-regexp (match-beginning 0)
+      ;;                           org-bracket-link-regexp 1))
+      ;; (org-drill-hide-matched-cloze-text)))))
+      (ignore-errors
+        (org-display-inline-images t))
+      (org-cycle-hide-drawers 'all)
+      (prog1 (org-drill-presentation-prompt)
+        (org-drill-hide-subheadings-if 'org-drill-entry-p)
+        (org-drill-unhide-clozed-text))))))
+
+
+(defun org-drill-present-multicloze-hide-nth (to-hide)
+  "Hide the TO-HIDE'th piece of clozed text. 1 is the first piece. If
+TO-HIDE is negative, count backwards, so -1 means the last item, -2
+the second to last, etc."
+  (with-hidden-comments
+   (with-hidden-cloze-hints
+    (let ((item-end nil)
+          (match-count 0)
+          (body-start (or (cdr (org-get-property-block))
+                          (point)))
+          (cnt 0))
+      (org-drill-hide-all-subheadings-except nil)
+      (save-excursion
+        (outline-next-heading)
+        (setq item-end (point)))
+      (save-excursion
+        (goto-char body-start)
+        (while (re-search-forward org-drill-cloze-regexp item-end t)
+          (let ((in-regexp? (save-match-data
+                              (org-pos-in-regexp (match-beginning 0)
+                                                 org-bracket-link-regexp 1))))
+            (unless in-regexp?
+              (incf match-count)))))
+      (if (minusp to-hide)
+          (setq to-hide (+ 1 to-hide match-count)))
+      (cond
+       ((or (not (plusp match-count))
+            (> to-hide match-count))
+        nil)
+       (t
+        (save-excursion
+          (goto-char body-start)
+          (setq cnt 0)
+          (while (re-search-forward org-drill-cloze-regexp item-end t)
+            (unless (save-match-data
+                      (org-pos-in-regexp (match-beginning 0)
+                                         org-bracket-link-regexp 1))
+              (incf cnt)
+              (if (= cnt to-hide)
+                  (org-drill-hide-matched-cloze-text)))))))
+      (ignore-errors
+        (org-display-inline-images t))
+      (org-cycle-hide-drawers 'all)
+      (prog1 (org-drill-presentation-prompt)
+        (org-drill-hide-subheadings-if 'org-drill-entry-p)
+        (org-drill-unhide-clozed-text))))))
+
+
+(defun org-drill-present-multicloze-hide1 ()
+  "Hides one of the pieces of text that are marked for cloze deletion,
+chosen at random."
+  (org-drill-present-multicloze-hide-n 1))
+
+
+(defun org-drill-present-multicloze-hide2 ()
+  "Hides two of the pieces of text that are marked for cloze deletion,
+chosen at random."
+  (org-drill-present-multicloze-hide-n 2))
+
+
+(defun org-drill-present-multicloze-hide-first ()
+  "Hides the first piece of text that is marked for cloze deletion."
+  (org-drill-present-multicloze-hide-nth 1))
+
+
+(defun org-drill-present-multicloze-hide-last ()
+  "Hides the last piece of text that is marked for cloze deletion."
+  (org-drill-present-multicloze-hide-nth -1))
+
+
+(defun org-drill-present-multicloze-hide1-firstmore ()
+  "Commonly, hides the FIRST piece of text that is marked for
+cloze deletion. Uncommonly, hide one of the other pieces of text,
+chosen at random.
+
+The definitions of 'commonly' and 'uncommonly' are determined by
+the value of `org-drill-cloze-text-weight'."
+  ;; The 'firstmore' and 'lastmore' functions used to randomly choose whether
+  ;; to hide the 'favoured' piece of text. However even when the chance of
+  ;; hiding it was set quite high (80%), the outcome was too unpredictable over
+  ;; the small number of repetitions where most learning takes place for each
+  ;; item. In other words, the actual frequency during the first 10 repetitions
+  ;; was often very different from 80%. Hence we use modulo instead.
+  (cond
+   ((null org-drill-cloze-text-weight)
+    ;; Behave as hide1cloze
+    (org-drill-present-multicloze-hide1))
+   ((not (and (integerp org-drill-cloze-text-weight)
+              (plusp org-drill-cloze-text-weight)))
+    (error "Illegal value for org-drill-cloze-text-weight: %S"
+           org-drill-cloze-text-weight))
+   ((zerop (mod (1+ (org-drill-entry-total-repeats 0))
+                org-drill-cloze-text-weight))
+    ;; Uncommonly, hide any item except the first
+    (org-drill-present-multicloze-hide-n 1 t))
+   (t
+    ;; Commonly, hide first item
+    (org-drill-present-multicloze-hide-first))))
+
+
+(defun org-drill-present-multicloze-show1-lastmore ()
+  "Commonly, hides all pieces except the last. Uncommonly, shows
+any random piece. The effect is similar to 'show1cloze' except
+that the last item is much less likely to be the item that is
+visible.
+
+The definitions of 'commonly' and 'uncommonly' are determined by
+the value of `org-drill-cloze-text-weight'."
+  (cond
+   ((null org-drill-cloze-text-weight)
+    ;; Behave as show1cloze
+    (org-drill-present-multicloze-show1))
+   ((not (and (integerp org-drill-cloze-text-weight)
+              (plusp org-drill-cloze-text-weight)))
+    (error "Illegal value for org-drill-cloze-text-weight: %S"
+           org-drill-cloze-text-weight))
+   ((zerop (mod (1+ (org-drill-entry-total-repeats 0))
+                org-drill-cloze-text-weight))
+    ;; Uncommonly, show any item except the last
+    (org-drill-present-multicloze-hide-n -1 nil nil t))
+   (t
+    ;; Commonly, show the LAST item
+    (org-drill-present-multicloze-hide-n -1 nil t))))
+
+
+(defun org-drill-present-multicloze-show1-firstless ()
+  "Commonly, hides all pieces except one, where the shown piece
+is guaranteed NOT to be the first piece. Uncommonly, shows any
+random piece. The effect is similar to 'show1cloze' except that
+the first item is much less likely to be the item that is
+visible.
+
+The definitions of 'commonly' and 'uncommonly' are determined by
+the value of `org-drill-cloze-text-weight'."
+  (cond
+   ((null org-drill-cloze-text-weight)
+    ;; Behave as show1cloze
+    (org-drill-present-multicloze-show1))
+   ((not (and (integerp org-drill-cloze-text-weight)
+              (plusp org-drill-cloze-text-weight)))
+    (error "Illegal value for org-drill-cloze-text-weight: %S"
+           org-drill-cloze-text-weight))
+   ((zerop (mod (1+ (org-drill-entry-total-repeats 0))
+                org-drill-cloze-text-weight))
+    ;; Uncommonly, show the first item
+    (org-drill-present-multicloze-hide-n -1 t))
+   (t
+    ;; Commonly, show any item, except the first
+    (org-drill-present-multicloze-hide-n -1 nil nil t))))
+
+
+(defun org-drill-present-multicloze-show1 ()
+  "Similar to `org-drill-present-multicloze-hide1', but hides all
+the pieces of text that are marked for cloze deletion, except for one
+piece which is chosen at random."
+  (org-drill-present-multicloze-hide-n -1))
+
+
+(defun org-drill-present-multicloze-show2 ()
+  "Similar to `org-drill-present-multicloze-show1', but reveals two
+pieces rather than one."
+  (org-drill-present-multicloze-hide-n -2))
+
+
+;; (defun org-drill-present-multicloze-show1 ()
+;;   "Similar to `org-drill-present-multicloze-hide1', but hides all
+;; the pieces of text that are marked for cloze deletion, except for one
+;; piece which is chosen at random."
+;;   (with-hidden-comments
+;;    (with-hidden-cloze-hints
+;;     (let ((item-end nil)
+;;           (match-count 0)
+;;           (body-start (or (cdr (org-get-property-block))
+;;                           (point))))
+;;       (org-drill-hide-all-subheadings-except nil)
+;;       (save-excursion
+;;         (outline-next-heading)
+;;         (setq item-end (point)))
+;;       (save-excursion
+;;         (goto-char body-start)
+;;         (while (re-search-forward org-drill-cloze-regexp item-end t)
+;;           (incf match-count)))
+;;       (when (plusp match-count)
+;;         (let ((match-to-hide (random* match-count)))
+;;           (save-excursion
+;;             (goto-char body-start)
+;;             (dotimes (n match-count)
+;;               (re-search-forward org-drill-cloze-regexp
+;;                                  item-end t)
+;;               (unless (= n match-to-hide)
+;;                 (org-drill-hide-matched-cloze-text))))))
+;;       (org-display-inline-images t)
+;;       (org-cycle-hide-drawers 'all)
+;;       (prog1 (org-drill-presentation-prompt)
+;;         (org-drill-hide-subheadings-if 'org-drill-entry-p)
+;;         (org-drill-unhide-clozed-text))))))
+
+
+(defun org-drill-present-card-using-text (question &optional answer)
+  "Present the string QUESTION as the only visible content of the card."
+  (with-hidden-comments
+   (with-replaced-entry-text
+    question
+    (org-drill-hide-all-subheadings-except nil)
+    (org-cycle-hide-drawers 'all)
+    (ignore-errors
+      (org-display-inline-images t))
+    (prog1 (org-drill-presentation-prompt)
+      (org-drill-hide-subheadings-if 'org-drill-entry-p)))))
+
+
+(defun org-drill-present-card-using-multiple-overlays (replacements &optional answer)
+  "TEXTS is a list of valid values for the 'display' text property.
+Present these overlays, in sequence, as the only
+visible content of the card."
+  (with-hidden-comments
+   (with-replaced-entry-text-multi
+    replacements
+    (org-drill-hide-all-subheadings-except nil)
+    (org-cycle-hide-drawers 'all)
+    (ignore-errors
+      (org-display-inline-images t))
+    (prog1 (org-drill-presentation-prompt)
+      (org-drill-hide-subheadings-if 'org-drill-entry-p)))))
+
+
+(defun org-drill-entry ()
+  "Present the current topic for interactive review, as in `org-drill'.
+Review will occur regardless of whether the topic is due for review or whether
+it meets the definition of a 'review topic' used by `org-drill'.
+
+Returns a quality rating from 0 to 5, or nil if the user quit, or the symbol
+EDIT if the user chose to exit the drill and edit the current item. Choosing
+the latter option leaves the drill session suspended; it can be resumed
+later using `org-drill-resume'.
+
+See `org-drill' for more details."
+  (interactive)
+  (org-drill-goto-drill-entry-heading)
+  ;;(unless (org-part-of-drill-entry-p)
+  ;;  (error "Point is not inside a drill entry"))
+  ;;(unless (org-at-heading-p)
+  ;;  (org-back-to-heading))
+  (let ((card-type (org-entry-get (point) "DRILL_CARD_TYPE"))
+        (answer-fn 'org-drill-present-default-answer)
+        (cont nil)
+        ;; fontification functions in `outline-view-change-hook' can cause big
+        ;; slowdowns, so we temporarily bind this variable to nil here.
+        (outline-view-change-hook nil))
+    (org-save-outline-visibility t
+      (save-restriction
+        (org-narrow-to-subtree)
+        (org-show-subtree)
+        (org-cycle-hide-drawers 'all)
+
+        (let ((presentation-fn (cdr (assoc card-type org-drill-card-type-alist))))
+          (if (listp presentation-fn)
+              (psetq answer-fn (or (second presentation-fn)
+                                   'org-drill-present-default-answer)
+                     presentation-fn (first presentation-fn)))
+          (cond
+           ((null presentation-fn)
+            (message "%s:%d: Unrecognised card type '%s', skipping..."
+                     (buffer-name) (point) card-type)
+            (sit-for 0.5)
+            'skip)
+           (t
+            (setq cont (funcall presentation-fn))
+            (cond
+             ((not cont)
+              (message "Quit")
+              nil)
+             ((eql cont 'edit)
+              'edit)
+             ((eql cont 'skip)
+              'skip)
+             (t
+              (save-excursion
+                (funcall answer-fn
+                         (lambda () (org-drill-reschedule)))))))))))))
+
+
+(defun org-drill-entries-pending-p ()
+  (or *org-drill-again-entries*
+      (and (not (org-drill-maximum-item-count-reached-p))
+           (not (org-drill-maximum-duration-reached-p))
+           (or *org-drill-new-entries*
+               *org-drill-failed-entries*
+               *org-drill-young-mature-entries*
+               *org-drill-old-mature-entries*
+               *org-drill-overdue-entries*
+               *org-drill-again-entries*))))
+
+
+(defun org-drill-pending-entry-count ()
+  (+ (length *org-drill-new-entries*)
+     (length *org-drill-failed-entries*)
+     (length *org-drill-young-mature-entries*)
+     (length *org-drill-old-mature-entries*)
+     (length *org-drill-overdue-entries*)
+     (length *org-drill-again-entries*)))
+
+
+(defun org-drill-maximum-duration-reached-p ()
+  "Returns true if the current drill session has continued past its
+maximum duration."
+  (and org-drill-maximum-duration
+       *org-drill-start-time*
+       (> (- (float-time (current-time)) *org-drill-start-time*)
+          (* org-drill-maximum-duration 60))))
+
+
+(defun org-drill-maximum-item-count-reached-p ()
+  "Returns true if the current drill session has reached the
+maximum number of items."
+  (and org-drill-maximum-items-per-session
+       (>= (length *org-drill-done-entries*)
+           org-drill-maximum-items-per-session)))
+
+
+(defun org-drill-pop-next-pending-entry ()
+  (block org-drill-pop-next-pending-entry
+    (let ((m nil))
+      (while (or (null m)
+                 (not (org-drill-entry-p m)))
+        (setq
+         m
+         (cond
+          ;; First priority is items we failed in a prior session.
+          ((and *org-drill-failed-entries*
+                (not (org-drill-maximum-item-count-reached-p))
+                (not (org-drill-maximum-duration-reached-p)))
+           (pop-random *org-drill-failed-entries*))
+          ;; Next priority is overdue items.
+          ((and *org-drill-overdue-entries*
+                (not (org-drill-maximum-item-count-reached-p))
+                (not (org-drill-maximum-duration-reached-p)))
+           ;; We use `pop', not `pop-random', because we have already
+           ;; sorted overdue items into a random order which takes
+           ;; number of days overdue into account.
+           (pop *org-drill-overdue-entries*))
+          ;; Next priority is 'young' items.
+          ((and *org-drill-young-mature-entries*
+                (not (org-drill-maximum-item-count-reached-p))
+                (not (org-drill-maximum-duration-reached-p)))
+           (pop-random *org-drill-young-mature-entries*))
+          ;; Next priority is newly added items, and older entries.
+          ;; We pool these into a single group.
+          ((and (or *org-drill-new-entries*
+                    *org-drill-old-mature-entries*)
+                (not (org-drill-maximum-item-count-reached-p))
+                (not (org-drill-maximum-duration-reached-p)))
+           (cond
+            ((< (random* (+ (length *org-drill-new-entries*)
+                            (length *org-drill-old-mature-entries*)))
+                (length *org-drill-new-entries*))
+             (pop-random *org-drill-new-entries*))
+            (t
+             (pop-random *org-drill-old-mature-entries*))))
+          ;; After all the above are done, last priority is items
+          ;; that were failed earlier THIS SESSION.
+          (*org-drill-again-entries*
+           (pop *org-drill-again-entries*))
+          (t                            ; nothing left -- return nil
+           (return-from org-drill-pop-next-pending-entry nil)))))
+      m)))
+
+
+(defun org-drill-entries (&optional resuming-p)
+  "Returns nil, t, or a list of markers representing entries that were
+'failed' and need to be presented again before the session ends.
+
+RESUMING-P is true if we are resuming a suspended drill session."
+  (block org-drill-entries
+    (while (org-drill-entries-pending-p)
+      (let ((m (cond
+                ((or (not resuming-p)
+                     (null *org-drill-current-item*)
+                     (not (org-drill-entry-p *org-drill-current-item*)))
+                 (org-drill-pop-next-pending-entry))
+                (t                      ; resuming a suspended session.
+                 (setq resuming-p nil)
+                 *org-drill-current-item*))))
+        (setq *org-drill-current-item* m)
+        (unless m
+          (error "Unexpectedly ran out of pending drill items"))
+        (save-excursion
+          (org-drill-goto-entry m)
+          (cond
+           ((not (org-drill-entry-due-p))
+            ;; The entry is not due anymore. This could arise if the user
+            ;; suspends a drill session, then drills an individual entry,
+            ;; then resumes the session.
+            (message "Entry no longer due, skipping...")
+            (sit-for 0.3)
+            nil)
+           (t
+            (setq result (org-drill-entry))
+            (cond
+             ((null result)
+              (message "Quit")
+              (setq end-pos :quit)
+              (return-from org-drill-entries nil))
+             ((eql result 'edit)
+              (setq end-pos (point-marker))
+              (return-from org-drill-entries nil))
+             ((eql result 'skip)
+              nil)                      ; skip this item
+             (t
+              (cond
+               ((<= result org-drill-failure-quality)
+                (if *org-drill-again-entries*
+                    (setq *org-drill-again-entries*
+                          (shuffle-list *org-drill-again-entries*)))
+                (push-end m *org-drill-again-entries*))
+               (t
+                (push m *org-drill-done-entries*))))))))))))
+
+
+
+(defun org-drill-final-report ()
+  (let ((pass-percent
+         (round (* 100 (count-if (lambda (qual)
+                                   (> qual org-drill-failure-quality))
+                                 *org-drill-session-qualities*))
+                (max 1 (length *org-drill-session-qualities*))))
+        (prompt nil))
+    (setq prompt
+          (format
+           "%d items reviewed. Session duration %s.
+Recall of reviewed items:
+ Excellent (5):     %3d%%   |   Near miss (2):      %3d%%
+ Good (4):          %3d%%   |   Failure (1):        %3d%%
+ Hard (3):          %3d%%   |   Abject failure (0): %3d%%
+
+You successfully recalled %d%% of reviewed items (quality > %s)
+%d/%d items still await review (%s, %s, %s, %s, %s).
+Tomorrow, %d more items will become due for review.
+Session finished. Press a key to continue..."
+           (length *org-drill-done-entries*)
+           (format-seconds "%h:%.2m:%.2s"
+                           (- (float-time (current-time)) *org-drill-start-time*))
+           (round (* 100 (count 5 *org-drill-session-qualities*))
+                  (max 1 (length *org-drill-session-qualities*)))
+           (round (* 100 (count 2 *org-drill-session-qualities*))
+                  (max 1 (length *org-drill-session-qualities*)))
+           (round (* 100 (count 4 *org-drill-session-qualities*))
+                  (max 1 (length *org-drill-session-qualities*)))
+           (round (* 100 (count 1 *org-drill-session-qualities*))
+                  (max 1 (length *org-drill-session-qualities*)))
+           (round (* 100 (count 3 *org-drill-session-qualities*))
+                  (max 1 (length *org-drill-session-qualities*)))
+           (round (* 100 (count 0 *org-drill-session-qualities*))
+                  (max 1 (length *org-drill-session-qualities*)))
+           pass-percent
+           org-drill-failure-quality
+           (org-drill-pending-entry-count)
+           (+ (org-drill-pending-entry-count)
+              *org-drill-dormant-entry-count*)
+           (propertize
+            (format "%d failed"
+                    (+ (length *org-drill-failed-entries*)
+                       (length *org-drill-again-entries*)))
+            'face `(:foreground ,org-drill-failed-count-color))
+           (propertize
+            (format "%d overdue"
+                    (length *org-drill-overdue-entries*))
+            'face `(:foreground ,org-drill-failed-count-color))
+           (propertize
+            (format "%d new"
+                    (length *org-drill-new-entries*))
+            'face `(:foreground ,org-drill-new-count-color))
+           (propertize
+            (format "%d young"
+                    (length *org-drill-young-mature-entries*))
+            'face `(:foreground ,org-drill-mature-count-color))
+           (propertize
+            (format "%d old"
+                    (length *org-drill-old-mature-entries*))
+            'face `(:foreground ,org-drill-mature-count-color))
+           *org-drill-due-tomorrow-count*
+           ))
+
+    (while (not (input-pending-p))
+      (message "%s" prompt)
+      (sit-for 0.5))
+    (read-char-exclusive)
+
+    (if (and *org-drill-session-qualities*
+             (< pass-percent (- 100 org-drill-forgetting-index)))
+        (read-char-exclusive
+         (format
+          "%s
+You failed %d%% of the items you reviewed during this session.
+%d (%d%%) of all items scanned were overdue.
+
+Are you keeping up with your items, and reviewing them
+when they are scheduled? If so, you may want to consider
+lowering the value of `org-drill-learn-fraction' slightly in
+order to make items appear more frequently over time."
+          (propertize "WARNING!" 'face 'org-warning)
+          (- 100 pass-percent)
+          *org-drill-overdue-entry-count*
+          (round (* 100 *org-drill-overdue-entry-count*)
+                 (+ *org-drill-dormant-entry-count*
+                    *org-drill-due-entry-count*)))
+         ))))
+
+
+
+(defun org-drill-free-markers (markers)
+  "MARKERS is a list of markers, all of which will be freed (set to
+point nowhere). Alternatively, MARKERS can be 't', in which case
+all the markers used by Org-Drill will be freed."
+  (dolist (m (if (eql t markers)
+                 (append  *org-drill-done-entries*
+                          *org-drill-new-entries*
+                          *org-drill-failed-entries*
+                          *org-drill-again-entries*
+                          *org-drill-overdue-entries*
+                          *org-drill-young-mature-entries*
+                          *org-drill-old-mature-entries*)
+               markers))
+    (free-marker m)))
+
+
+(defun org-drill-order-overdue-entries (overdue-data)
+  (setq *org-drill-overdue-entries*
+        (mapcar 'car
+                (sort (shuffle-list overdue-data)
+                      (lambda (a b) (> (cdr a) (cdr b)))))))
+
+
+(defun org-drill-entry-status ()
+  "Returns a list (STATUS DUE) where DUE is the number of days overdue,
+zero being due today, -1 being scheduled 1 day in the future. STATUS is
+one of the following values:
+- nil, if the item is not a drill entry, or has an empty body
+- :unscheduled
+- :future
+- :new
+- :failed
+- :overdue
+- :young
+- :old
+"
+  (save-excursion
+    (unless (org-at-heading-p)
+      (org-back-to-heading))
+    (let ((due (org-drill-entry-days-overdue))
+          (last-int (org-drill-entry-last-interval 1)))
+      (list
+       (cond
+        ((not (org-drill-entry-p))
+         nil)
+        ((org-drill-entry-empty-p)
+         nil)                           ; skip -- item body is empty
+        ((null due)                     ; unscheduled - usually a skipped leech
+         :unscheduled)
+        ;; ((eql -1 due)
+        ;;  :tomorrow)
+        ((minusp due)                   ; scheduled in the future
+         :future)
+        ;; The rest of the stati all denote 'due' items ==========================
+        ((<= (org-drill-entry-last-quality 9999)
+             org-drill-failure-quality)
+         ;; Mature entries that were failed last time are
+         ;; FAILED, regardless of how young, old or overdue
+         ;; they are.
+         :failed)
+        ((org-drill-entry-new-p)
+         :new)
+        ((org-drill-entry-overdue-p due last-int)
+         ;; Overdue status overrides young versus old
+         ;; distinction.
+         ;; Store marker + due, for sorting of overdue entries
+         :overdue)
+        ((<= (org-drill-entry-last-interval 9999)
+             org-drill-days-before-old)
+         :young)
+        (t
+         :old))
+       due))))
+
+
+(defun org-drill-progress-message (collected scanned)
+  (when (zerop (% scanned 50))
+    (let* ((meter-width 40)
+           (sym1 (if (oddp (floor scanned (* 50 meter-width))) ?| ?.))
+           (sym2 (if (eql sym1 ?.) ?| ?.)))
+      (message "Collecting due drill items:%4d %s%s"
+              collected
+              (make-string (% (ceiling scanned 50) meter-width)
+                           sym2)
+              (make-string (- meter-width (% (ceiling scanned 50) meter-width))
+                           sym1)))))
+
+
+(defun org-drill (&optional scope resume-p)
+  "Begin an interactive 'drill session'. The user is asked to
+review a series of topics (headers). Each topic is initially
+presented as a 'question', often with part of the topic content
+hidden. The user attempts to recall the hidden information or
+answer the question, then presses a key to reveal the answer. The
+user then rates his or her recall or performance on that
+topic. This rating information is used to reschedule the topic
+for future review.
+
+Org-drill proceeds by:
+
+- Finding all topics (headings) in SCOPE which have either been
+  used and rescheduled before, or which have a tag that matches
+  `org-drill-question-tag'.
+
+- All matching topics which are either unscheduled, or are
+  scheduled for the current date or a date in the past, are
+  considered to be candidates for the drill session.
+
+- If `org-drill-maximum-items-per-session' is set, a random
+  subset of these topics is presented. Otherwise, all of the
+  eligible topics will be presented.
+
+SCOPE determines the scope in which to search for
+questions.  It accepts the same values as `org-drill-scope',
+which see.
+
+If RESUME-P is non-nil, resume a suspended drill session rather
+than starting a new one."
+
+  (interactive)
+  (let ((end-pos nil)
+        (overdue-data nil)
+        (cnt 0))
+    (block org-drill
+      (unless resume-p
+        (org-drill-free-markers t)
+        (setq *org-drill-current-item* nil
+              *org-drill-done-entries* nil
+              *org-drill-dormant-entry-count* 0
+              *org-drill-due-entry-count* 0
+              *org-drill-due-tomorrow-count* 0
+              *org-drill-overdue-entry-count* 0
+              *org-drill-new-entries* nil
+              *org-drill-overdue-entries* nil
+              *org-drill-young-mature-entries* nil
+              *org-drill-old-mature-entries* nil
+              *org-drill-failed-entries* nil
+              *org-drill-again-entries* nil)
+        (setq *org-drill-session-qualities* nil)
+        (setq *org-drill-start-time* (float-time (current-time))))
+      (setq *random-state* (make-random-state t)) ; reseed RNG
+      (unwind-protect
+          (save-excursion
+            (unless resume-p
+              (let ((org-trust-scanner-tags t)
+                    (warned-about-id-creation nil))
+                (org-map-drill-entries
+                 (lambda ()
+                   (org-drill-progress-message
+                    (+ (length *org-drill-new-entries*)
+                       (length *org-drill-overdue-entries*)
+                       (length *org-drill-young-mature-entries*)
+                       (length *org-drill-old-mature-entries*)
+                       (length *org-drill-failed-entries*))
+                    (incf cnt))
+                   (cond
+                    ((not (org-drill-entry-p))
+                     nil)               ; skip
+                    (t
+                     (when (and (not warned-about-id-creation)
+                                (null (org-id-get)))
+                       (message (concat "Creating unique IDs for items "
+                                        "(slow, but only happens once)"))
+                       (sit-for 0.5)
+                       (setq warned-about-id-creation t))
+                     (org-id-get-create) ; ensure drill entry has unique ID
+                     (destructuring-bind (status due) (org-drill-entry-status)
+                       (case status
+                         (:unscheduled
+                          (incf *org-drill-dormant-entry-count*))
+                         ;; (:tomorrow
+                         ;;  (incf *org-drill-dormant-entry-count*)
+                         ;;  (incf *org-drill-due-tomorrow-count*))
+                         (:future
+                          (incf *org-drill-dormant-entry-count*)
+                          (if (eq -1 due)
+                              (incf *org-drill-due-tomorrow-count*)))
+                         (:new
+                          (push (point-marker) *org-drill-new-entries*))
+                         (:failed
+                          (push (point-marker) *org-drill-failed-entries*))
+                         (:young
+                          (push (point-marker) *org-drill-young-mature-entries*))
+                         (:overdue
+                          (push (cons (point-marker) due) overdue-data))
+                         (:old
+                          (push (point-marker) *org-drill-old-mature-entries*)))))))
+                 scope)
+                ;; (let ((due (org-drill-entry-days-overdue))
+                ;;       (last-int (org-drill-entry-last-interval 1)))
+                ;;   (cond
+                ;;    ((org-drill-entry-empty-p)
+                ;;     nil)           ; skip -- item body is empty
+                ;;    ((or (null due) ; unscheduled - usually a skipped leech
+                ;;         (minusp due)) ; scheduled in the future
+                ;;     (incf *org-drill-dormant-entry-count*)
+                ;;     (if (eq -1 due)
+                ;;         (incf *org-drill-due-tomorrow-count*)))
+                ;;    ((org-drill-entry-new-p)
+                ;;     (push (point-marker) *org-drill-new-entries*))
+                ;;    ((<= (org-drill-entry-last-quality 9999)
+                ;;         org-drill-failure-quality)
+                ;;     ;; Mature entries that were failed last time are
+                ;;     ;; FAILED, regardless of how young, old or overdue
+                ;;     ;; they are.
+                ;;     (push (point-marker) *org-drill-failed-entries*))
+                ;;    ((org-drill-entry-overdue-p due last-int)
+                ;;     ;; Overdue status overrides young versus old
+                ;;     ;; distinction.
+                ;;     ;; Store marker + due, for sorting of overdue entries
+                ;;     (push (cons (point-marker) due) overdue-data))
+                ;;    ((<= (org-drill-entry-last-interval 9999)
+                ;;         org-drill-days-before-old)
+                ;;     ;; Item is 'young'.
+                ;;     (push (point-marker)
+                ;;           *org-drill-young-mature-entries*))
+                ;;    (t
+                ;;     (push (point-marker)
+                ;;           *org-drill-old-mature-entries*))))
+                ;; Order 'overdue' items so that the most overdue will tend to
+                ;; come up for review first, while keeping exact order random
+                (org-drill-order-overdue-entries overdue-data)
+                (setq *org-drill-overdue-entry-count*
+                      (length *org-drill-overdue-entries*))))
+            (setq *org-drill-due-entry-count* (org-drill-pending-entry-count))
+            (cond
+             ((and (null *org-drill-new-entries*)
+                   (null *org-drill-failed-entries*)
+                   (null *org-drill-overdue-entries*)
+                   (null *org-drill-young-mature-entries*)
+                   (null *org-drill-old-mature-entries*))
+              (message "I did not find any pending drill items."))
+             (t
+              (org-drill-entries resume-p)
+              (message "Drill session finished!"))))
+        (progn
+          (unless end-pos
+            (org-drill-free-markers *org-drill-done-entries*)))))
+    (cond
+     (end-pos
+      (when (markerp end-pos)
+        (org-drill-goto-entry end-pos)
+        (org-reveal)
+        (org-show-entry))
+      (let ((keystr (command-keybinding-to-string 'org-drill-resume)))
+        (message
+         "You can continue the drill session with the command `org-drill-resume'.%s"
+         (if keystr (format "\nYou can run this command by pressing %s." keystr)
+           ""))))
+     (t
+      (org-drill-final-report)
+      (if (eql 'sm5 org-drill-spaced-repetition-algorithm)
+          (org-drill-save-optimal-factor-matrix))
+      (if org-drill-save-buffers-after-drill-sessions-p
+          (save-some-buffers))
+      (message "Drill session finished!")
+      ))))
+
+
+(defun org-drill-save-optimal-factor-matrix ()
+  (message "Saving optimal factor matrix...")
+  (customize-save-variable 'org-drill-optimal-factor-matrix
+                           org-drill-optimal-factor-matrix))
+
+
+(defun org-drill-cram (&optional scope)
+  "Run an interactive drill session in 'cram mode'. In cram mode,
+all drill items are considered to be due for review, unless they
+have been reviewed within the last `org-drill-cram-hours'
+hours."
+  (interactive)
+  (let ((*org-drill-cram-mode* t))
+    (org-drill scope)))
+
+
+(defun org-drill-tree ()
+  "Run an interactive drill session using drill items within the
+subtree at point."
+  (interactive)
+  (org-drill 'tree))
+
+
+(defun org-drill-directory ()
+  "Run an interactive drill session using drill items from all org
+files in the same directory as the current file."
+  (interactive)
+  (org-drill 'directory))
+
+
+(defun org-drill-again (&optional scope)
+  "Run a new drill session, but try to use leftover due items that
+were not reviewed during the last session, rather than scanning for
+unreviewed items. If there are no leftover items in memory, a full
+scan will be performed."
+  (interactive)
+  (cond
+   ((plusp (org-drill-pending-entry-count))
+    (org-drill-free-markers *org-drill-done-entries*)
+    (if (markerp *org-drill-current-item*)
+        (free-marker *org-drill-current-item*))
+    (setq *org-drill-start-time* (float-time (current-time))
+          *org-drill-done-entries* nil
+          *org-drill-current-item* nil)
+    (org-drill scope t))
+   (t
+    (org-drill scope))))
+
+
+
+(defun org-drill-resume ()
+  "Resume a suspended drill session. Sessions are suspended by
+exiting them with the `edit' or `quit' options."
+  (interactive)
+  (cond
+   ((org-drill-entries-pending-p)
+    (org-drill nil t))
+   ((and (plusp (org-drill-pending-entry-count))
+         ;; Current drill session is finished, but there are still
+         ;; more items which need to be reviewed.
+         (y-or-n-p (format
+                    "You have finished the drill session. However, %d items still
+need reviewing. Start a new drill session? "
+                    (org-drill-pending-entry-count))))
+    (org-drill-again))
+   (t
+    (message "You have finished the drill session."))))
+
+
+(defun org-drill-strip-entry-data ()
+  (dolist (prop org-drill-scheduling-properties)
+    (org-delete-property prop))
+  (org-schedule t))
+
+
+(defun org-drill-strip-all-data (&optional scope)
+  "Delete scheduling data from every drill entry in scope. This
+function may be useful if you want to give your collection of
+entries to someone else.  Scope defaults to the current buffer,
+and is specified by the argument SCOPE, which accepts the same
+values as `org-drill-scope'."
+  (interactive)
+  (when (yes-or-no-p
+         "Delete scheduling data from ALL items in scope: are you sure?")
+    (cond
+     ((null scope)
+      ;; Scope is the current buffer. This means we can use
+      ;; `org-delete-property-globally', which is faster.
+      (dolist (prop org-drill-scheduling-properties)
+        (org-delete-property-globally prop))
+      (org-map-drill-entries (lambda () (org-schedule t)) scope))
+     (t
+      (org-map-drill-entries 'org-drill-strip-entry-data scope)))
+    (message "Done.")))
+
+
+
+(defun org-drill-add-cloze-fontification ()
+  (when org-drill-use-visible-cloze-face-p
+    (font-lock-add-keywords 'org-mode
+                            org-drill-cloze-keywords
+                            nil)))
+
+(add-hook 'org-mode-hook 'org-drill-add-cloze-fontification)
+
+(org-drill-add-cloze-fontification)
+
+
+;;; Synching card collections =================================================
+
+
+(defvar *org-drill-dest-id-table* (make-hash-table :test 'equal))
+
+
+(defun org-drill-copy-entry-to-other-buffer (dest &optional path)
+  "Copy the subtree at point to the buffer DEST. The copy will receive
+the tag 'imported'."
+  (block org-drill-copy-entry-to-other-buffer
+    (save-excursion
+      (let ((src (current-buffer))
+            (m nil))
+        (flet ((paste-tree-here (&optional level)
+                                (org-paste-subtree level)
+                                (org-drill-strip-entry-data)
+                                (org-toggle-tag "imported" 'on)
+                                (org-map-drill-entries
+                                 (lambda ()
+                                   (let ((id (org-id-get)))
+                                     (org-drill-strip-entry-data)
+                                     (unless (gethash id *org-drill-dest-id-table*)
+                                       (puthash id (point-marker)
+                                                *org-drill-dest-id-table*))))
+                                 'tree)))
+          (unless path
+            (setq path (org-get-outline-path)))
+          (org-copy-subtree)
+          (switch-to-buffer dest)
+          (setq m
+                (condition-case nil
+                    (org-find-olp path t)
+                  (error                ; path does not exist in DEST
+                   (return-from org-drill-copy-entry-to-other-buffer
+                     (cond
+                      ((cdr path)
+                       (org-drill-copy-entry-to-other-buffer
+                        dest (butlast path)))
+                      (t
+                       ;; We've looked all the way up the path
+                       ;; Default to appending to the end of DEST
+                       (goto-char (point-max))
+                       (newline)
+                       (paste-tree-here)))))))
+          (goto-char m)
+          (outline-next-heading)
+          (newline)
+          (forward-line -1)
+          (paste-tree-here (1+ (or (org-current-level) 0)))
+          )))))
+
+
+
+(defun org-drill-merge-buffers (src &optional dest ignore-new-items-p)
+  "SRC and DEST are two org mode buffers containing drill items.
+For each drill item in DEST that shares an ID with an item in SRC,
+overwrite scheduling data in DEST with data taken from the item in SRC.
+This is intended for use when two people are sharing a set of drill items,
+one person has made some updates to the item set, and the other person
+wants to migrate to the updated set without losing their scheduling data.
+
+By default, any drill items in SRC which do not exist in DEST are
+copied into DEST. We attempt to place the copied item in the
+equivalent location in DEST to its location in SRC, by matching
+the heading hierarchy. However if IGNORE-NEW-ITEMS-P is non-nil,
+we simply ignore any items that do not exist in DEST, and do not
+copy them across."
+  (interactive "bImport scheduling info from which buffer?")
+  (unless dest
+    (setq dest (current-buffer)))
+  (setq src (get-buffer src)
+        dest (get-buffer dest))
+  (when (yes-or-no-p
+         (format
+          (concat "About to overwrite all scheduling data for drill items in `%s' "
+                  "with information taken from matching items in `%s'. Proceed? ")
+          (buffer-name dest) (buffer-name src)))
+    ;; Compile list of all IDs in the destination buffer.
+    (clrhash *org-drill-dest-id-table*)
+    (with-current-buffer dest
+      (org-map-drill-entries
+       (lambda ()
+         (let ((this-id (org-id-get)))
+           (when this-id
+             (puthash this-id (point-marker) *org-drill-dest-id-table*))))
+       'file))
+    ;; Look through all entries in source buffer.
+    (with-current-buffer src
+      (org-map-drill-entries
+       (lambda ()
+         (let ((id (org-id-get))
+               (last-quality nil) (last-reviewed nil)
+               (scheduled-time nil))
+           (cond
+            ((or (null id)
+                 (not (org-drill-entry-p)))
+             nil)
+            ((gethash id *org-drill-dest-id-table*)
+             ;; This entry matches an entry in dest. Retrieve all its
+             ;; scheduling data, then go to the matching location in dest
+             ;; and write the data.
+             (let ((marker (gethash id *org-drill-dest-id-table*)))
+               (destructuring-bind (last-interval repetitions failures
+                                                  total-repeats meanq ease)
+                   (org-drill-get-item-data)
+                 (setq last-reviewed (org-entry-get (point) "DRILL_LAST_REVIEWED")
+                       last-quality (org-entry-get (point) "DRILL_LAST_QUALITY")
+                       scheduled-time (org-get-scheduled-time (point)))
+                 (save-excursion
+                   ;; go to matching entry in destination buffer
+                   (switch-to-buffer (marker-buffer marker))
+                   (goto-char marker)
+                   (org-drill-strip-entry-data)
+                   (unless (zerop total-repeats)
+                     (org-drill-store-item-data last-interval repetitions failures
+                                                total-repeats meanq ease)
+                     (if last-quality
+                         (org-set-property "LAST_QUALITY" last-quality)
+                       (org-delete-property "LAST_QUALITY"))
+                     (if last-reviewed
+                         (org-set-property "LAST_REVIEWED" last-reviewed)
+                       (org-delete-property "LAST_REVIEWED"))
+                     (if scheduled-time
+                         (org-schedule nil scheduled-time)))))
+               (remhash id *org-drill-dest-id-table*)
+               (free-marker marker)))
+            (t
+             ;; item in SRC has ID, but no matching ID in DEST.
+             ;; It must be a new item that does not exist in DEST.
+             ;; Copy the entire item to the *end* of DEST.
+             (unless ignore-new-items-p
+               (org-drill-copy-entry-to-other-buffer dest))))))
+       'file))
+    ;; Finally: there may be some items in DEST which are not in SRC, and
+    ;; which have been scheduled by another user of DEST. Clear out the
+    ;; scheduling info from all the unmatched items in DEST.
+    (with-current-buffer dest
+      (maphash (lambda (id m)
+                 (goto-char m)
+                 (org-drill-strip-entry-data)
+                 (free-marker m))
+               *org-drill-dest-id-table*))))
+
+
+
+;;; Card types for learning languages =========================================
+
+;;; Get spell-number.el from:
+;;; http://www.emacswiki.org/emacs/spell-number.el
+(autoload 'spelln-integer-in-words "spell-number")
+
+
+;;; `conjugate' card type =====================================================
+;;; See spanish.org for usage
+
+(defvar org-drill-verb-tense-alist
+  '(("present" "tomato")
+    ("simple present" "tomato")
+    ("present indicative" "tomato")
+    ;; past tenses
+    ("past" "purple")
+    ("simple past" "purple")
+    ("preterite" "purple")
+    ("imperfect" "darkturquoise")
+    ("present perfect" "royalblue")
+    ;; future tenses
+    ("future" "green")
+    ;; moods (backgrounds).
+    ("indicative" nil)                  ; default
+    ("subjunctive" "medium blue")
+    ("conditional" "grey30")
+    ("negative imperative" "red4")
+    ("positive imperative" "darkgreen")
+    )
+  "Alist where each entry has the form (TENSE COLOUR), where
+TENSE is a string naming a tense in which verbs can be
+conjugated, and COLOUR is a string specifying a foreground colour
+which will be used by `org-drill-present-verb-conjugation' and
+`org-drill-show-answer-verb-conjugation' to fontify the verb and
+the name of the tense.")
+
+
+(defun org-drill-get-verb-conjugation-info ()
+  "Auxiliary function used by `org-drill-present-verb-conjugation' and
+`org-drill-show-answer-verb-conjugation'."
+  (let ((infinitive (org-entry-get (point) "VERB_INFINITIVE" t))
+        (inf-hint (org-entry-get (point) "VERB_INFINITIVE_HINT" t))
+        (translation (org-entry-get (point) "VERB_TRANSLATION" t))
+        (tense (org-entry-get (point) "VERB_TENSE" nil))
+        (mood (org-entry-get (point) "VERB_MOOD" nil))
+        (highlight-face nil))
+    (unless (and infinitive translation (or tense mood))
+      (error "Missing information for verb conjugation card (%s, %s, %s, %s) at %s"
+             infinitive translation tense mood (point)))
+    (setq tense (if tense (downcase (car (read-from-string tense))))
+          mood (if mood (downcase (car (read-from-string mood))))
+          infinitive (car (read-from-string infinitive))
+          inf-hint (if inf-hint (car (read-from-string inf-hint)))
+          translation (car (read-from-string translation)))
+    (setq highlight-face
+          (list :foreground
+                (or (second (assoc-string tense org-drill-verb-tense-alist t))
+                    "hotpink")
+                :background
+                (second (assoc-string mood org-drill-verb-tense-alist t))))
+    (setq infinitive (propertize infinitive 'face highlight-face))
+    (setq translation (propertize translation 'face highlight-face))
+    (if tense (setq tense (propertize tense 'face highlight-face)))
+    (if mood (setq mood (propertize mood 'face highlight-face)))
+    (list infinitive inf-hint translation tense mood)))
+
+
+(defun org-drill-present-verb-conjugation ()
+  "Present a drill entry whose card type is 'conjugate'."
+  (flet ((tense-and-mood-to-string
+          (tense mood)
+          (cond
+           ((and tense mood)
+            (format "%s tense, %s mood" tense mood))
+           (tense
+            (format "%s tense" tense))
+           (mood
+            (format "%s mood" mood)))))
+    (destructuring-bind (infinitive inf-hint translation tense mood)
+        (org-drill-get-verb-conjugation-info)
+      (org-drill-present-card-using-text
+       (cond
+        ((zerop (random* 2))
+         (format "\nTranslate the verb\n\n%s\n\nand conjugate for the %s.\n\n"
+                 infinitive (tense-and-mood-to-string tense mood)))
+
+        (t
+         (format "\nGive the verb that means\n\n%s %s\n
+and conjugate for the %s.\n\n"
+                 translation
+                 (if inf-hint (format "  [HINT: %s]" inf-hint) "")
+                 (tense-and-mood-to-string tense mood))))))))
+
+
+(defun org-drill-show-answer-verb-conjugation (reschedule-fn)
+  "Show the answer for a drill item whose card type is 'conjugate'.
+RESCHEDULE-FN must be a function that calls `org-drill-reschedule' and
+returns its return value."
+  (destructuring-bind (infinitive inf-hint translation tense mood)
+      (org-drill-get-verb-conjugation-info)
+    (with-replaced-entry-heading
+     (format "%s of %s ==> %s\n\n"
+             (capitalize
+              (cond
+               ((and tense mood)
+                (format "%s tense, %s mood" tense mood))
+               (tense
+                (format "%s tense" tense))
+               (mood
+                (format "%s mood" mood))))
+             infinitive translation)
+     (funcall reschedule-fn))))
+
+
+;;; `translate_number' card type ==============================================
+;;; See spanish.org for usage
+
+(defvar *drilled-number* 0)
+(defvar *drilled-number-direction* 'to-english)
+
+(defun org-drill-present-translate-number ()
+  (let ((num-min (read (org-entry-get (point) "DRILL_NUMBER_MIN")))
+        (num-max (read (org-entry-get (point) "DRILL_NUMBER_MAX")))
+        (language (read (org-entry-get (point) "DRILL_LANGUAGE" t)))
+        (highlight-face 'font-lock-warning-face))
+    (cond
+     ((not (fboundp 'spelln-integer-in-words))
+      (message "`spell-number.el' not loaded, skipping 'translate_number' card...")
+      (sit-for 0.5)
+      'skip)
+     ((not (and (numberp num-min) (numberp num-max) language))
+      (error "Missing language or minimum or maximum numbers for number card"))
+     (t
+      (if (> num-min num-max)
+          (psetf num-min num-max
+                 num-max num-min))
+      (setq *drilled-number*
+            (+ num-min (random* (abs (1+ (- num-max num-min))))))
+      (setq *drilled-number-direction*
+            (if (zerop (random* 2)) 'from-english 'to-english))
+      (org-drill-present-card-using-text
+       (if (eql 'to-english *drilled-number-direction*)
+           (format "\nTranslate into English:\n\n%s\n"
+                   (let ((spelln-language language))
+                     (propertize
+                      (spelln-integer-in-words *drilled-number*)
+                      'face highlight-face)))
+         (format "\nTranslate into %s:\n\n%s\n"
+                 (capitalize (format "%s" language))
+                 (let ((spelln-language 'english-gb))
+                   (propertize
+                    (spelln-integer-in-words *drilled-number*)
+                    'face highlight-face)))))))))
+
+
+(defun org-drill-show-answer-translate-number (reschedule-fn)
+  (let* ((language (read (org-entry-get (point) "DRILL_LANGUAGE" t)))
+         (highlight-face 'font-lock-warning-face)
+         (non-english
+          (let ((spelln-language language))
+            (propertize (spelln-integer-in-words *drilled-number*)
+                        'face highlight-face)))
+         (english
+          (let ((spelln-language 'english-gb))
+            (propertize (spelln-integer-in-words *drilled-number*)
+                        'face 'highlight-face))))
+    (with-replaced-entry-text
+     (cond
+      ((eql 'to-english *drilled-number-direction*)
+       (format "\nThe English translation of %s is:\n\n%s\n"
+               non-english english))
+      (t
+       (format "\nThe %s translation of %s is:\n\n%s\n"
+               (capitalize (format "%s" language))
+               english non-english)))
+     (funcall reschedule-fn))))
+
+
+;;; `spanish_verb' card type ==================================================
+;;; Not very interesting, but included to demonstrate how a presentation
+;;; function can manipulate which subheading are hidden versus shown.
+
+
+(defun org-drill-present-spanish-verb ()
+  (let ((prompt nil)
+        (reveal-headings nil))
+    (with-hidden-comments
+     (with-hidden-cloze-hints
+      (with-hidden-cloze-text
+       (case (random* 6)
+         (0
+          (org-drill-hide-all-subheadings-except '("Infinitive"))
+          (setq prompt
+                (concat "Translate this Spanish verb, and conjugate it "
+                        "for the *present* tense.")
+                reveal-headings '("English" "Present Tense" "Notes")))
+         (1
+          (org-drill-hide-all-subheadings-except '("English"))
+          (setq prompt (concat "For the *present* tense, conjugate the "
+                               "Spanish translation of this English verb.")
+                reveal-headings '("Infinitive" "Present Tense" "Notes")))
+         (2
+          (org-drill-hide-all-subheadings-except '("Infinitive"))
+          (setq prompt (concat "Translate this Spanish verb, and "
+                               "conjugate it for the *past* tense.")
+                reveal-headings '("English" "Past Tense" "Notes")))
+         (3
+          (org-drill-hide-all-subheadings-except '("English"))
+          (setq prompt (concat "For the *past* tense, conjugate the "
+                               "Spanish translation of this English verb.")
+                reveal-headings '("Infinitive" "Past Tense" "Notes")))
+         (4
+          (org-drill-hide-all-subheadings-except '("Infinitive"))
+          (setq prompt (concat "Translate this Spanish verb, and "
+                               "conjugate it for the *future perfect* tense.")
+                reveal-headings '("English" "Future Perfect Tense" "Notes")))
+         (5
+          (org-drill-hide-all-subheadings-except '("English"))
+          (setq prompt (concat "For the *future perfect* tense, conjugate the "
+                               "Spanish translation of this English verb.")
+                reveal-headings '("Infinitive" "Future Perfect Tense" "Notes"))))
+       (org-cycle-hide-drawers 'all)
+       (prog1 (org-drill-presentation-prompt)
+         (org-drill-hide-subheadings-if 'org-drill-entry-p)))))))
+
+
+(provide 'org-drill)
diff --git a/contrib/lisp/org-e-ascii.el b/contrib/lisp/org-e-ascii.el
new file mode 100644
index 0000000..ad0f1b3
--- /dev/null
+++ b/contrib/lisp/org-e-ascii.el
@@ -0,0 +1,1807 @@
+;;; org-e-ascii.el --- ASCII Back-End For Org Export Engine
+
+;; Copyright (C) 2012  Free Software Foundation, Inc.
+
+;; Author: Nicolas Goaziou 
+;; Keywords: outlines, hypermedia, calendar, wp
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program.  If not, see .
+
+;;; Commentary:
+;;
+;; This library implements an ASCII back-end for Org generic exporter.
+;;
+;; It provides two commands for export, depending on the desired
+;; output: `org-e-ascii-export-as-ascii' (temporary buffer) and
+;; `org-e-ascii-export-to-ascii' ("txt" file).
+;;
+;; Output encoding is specified through `org-e-ascii-charset'
+;; variable, among `ascii', `latin1' and `utf-8' symbols.
+;;
+;; By default, horizontal rules span over the full text with, but with
+;; a given width attribute (set though #+ATTR_ASCII: :width )
+;; they can be shortened and centered.
+
+;;; Code:
+
+(eval-when-compile (require 'cl))
+(require 'org-export)
+
+(declare-function aa2u "ext:ascii-art-to-unicode" ())
+
+;;; Define Back-End
+;;
+;; The following setting won't allow to modify preferred charset
+;; through a buffer keyword or an option item, but, since the property
+;; will appear in communication channel nonetheless, it allows to
+;; override `org-e-ascii-charset' variable on the fly by the ext-plist
+;; mechanism.
+;;
+;; We also install a filter for headlines and sections, in order to
+;; control blank lines separating them in output string.
+
+(org-export-define-backend e-ascii
+  ((bold . org-e-ascii-bold)
+   (center-block . org-e-ascii-center-block)
+   (clock . org-e-ascii-clock)
+   (code . org-e-ascii-code)
+   (drawer . org-e-ascii-drawer)
+   (dynamic-block . org-e-ascii-dynamic-block)
+   (entity . org-e-ascii-entity)
+   (example-block . org-e-ascii-example-block)
+   (export-block . org-e-ascii-export-block)
+   (export-snippet . org-e-ascii-export-snippet)
+   (fixed-width . org-e-ascii-fixed-width)
+   (footnote-definition . org-e-ascii-footnote-definition)
+   (footnote-reference . org-e-ascii-footnote-reference)
+   (headline . org-e-ascii-headline)
+   (horizontal-rule . org-e-ascii-horizontal-rule)
+   (inline-src-block . org-e-ascii-inline-src-block)
+   (inlinetask . org-e-ascii-inlinetask)
+   (italic . org-e-ascii-italic)
+   (item . org-e-ascii-item)
+   (keyword . org-e-ascii-keyword)
+   (latex-environment . org-e-ascii-latex-environment)
+   (latex-fragment . org-e-ascii-latex-fragment)
+   (line-break . org-e-ascii-line-break)
+   (link . org-e-ascii-link)
+   (macro . org-e-ascii-macro)
+   (paragraph . org-e-ascii-paragraph)
+   (plain-list . org-e-ascii-plain-list)
+   (plain-text . org-e-ascii-plain-text)
+   (planning . org-e-ascii-planning)
+   (quote-block . org-e-ascii-quote-block)
+   (quote-section . org-e-ascii-quote-section)
+   (radio-target . org-e-ascii-radio-target)
+   (section . org-e-ascii-section)
+   (special-block . org-e-ascii-special-block)
+   (src-block . org-e-ascii-src-block)
+   (statistics-cookie . org-e-ascii-statistics-cookie)
+   (strike-through . org-e-ascii-strike-through)
+   (subscript . org-e-ascii-subscript)
+   (superscript . org-e-ascii-superscript)
+   (table . org-e-ascii-table)
+   (table-cell . org-e-ascii-table-cell)
+   (table-row . org-e-ascii-table-row)
+   (target . org-e-ascii-target)
+   (template . org-e-ascii-template)
+   (timestamp . org-e-ascii-timestamp)
+   (underline . org-e-ascii-underline)
+   (verbatim . org-e-ascii-verbatim)
+   (verse-block . org-e-ascii-verse-block))
+  :export-block "ASCII"
+  :filters-alist ((:filter-headline . org-e-ascii-filter-headline-blank-lines)
+		  (:filter-section . org-e-ascii-filter-headline-blank-lines))
+  :options-alist ((:ascii-charset nil nil org-e-ascii-charset)))
+
+
+
+;;; User Configurable Variables
+
+(defgroup org-export-e-ascii nil
+  "Options for exporting Org mode files to ASCII."
+  :tag "Org Export ASCII"
+  :group 'org-export)
+
+(defcustom org-e-ascii-text-width 72
+  "Maximum width of exported text.
+This number includes margin size, as set in
+`org-e-ascii-global-margin'."
+  :group 'org-export-e-ascii
+  :type 'integer)
+
+(defcustom org-e-ascii-global-margin 0
+  "Width of the left margin, in number of characters."
+  :group 'org-export-e-ascii
+  :type 'integer)
+
+(defcustom org-e-ascii-inner-margin 2
+  "Width of the inner margin, in number of characters.
+Inner margin is applied between each headline."
+  :group 'org-export-e-ascii
+  :type 'integer)
+
+(defcustom org-e-ascii-quote-margin 6
+  "Width of margin used for quoting text, in characters.
+This margin is applied on both sides of the text."
+  :group 'org-export-e-ascii
+  :type 'integer)
+
+(defcustom org-e-ascii-inlinetask-width 30
+  "Width of inline tasks, in number of characters.
+This number ignores any margin."
+  :group 'org-export-e-ascii
+  :type 'integer)
+
+(defcustom org-e-ascii-headline-spacing '(1 . 2)
+  "Number of blank lines inserted around headlines.
+
+This variable can be set to a cons cell.  In that case, its car
+represents the number of blank lines present before headline
+contents whereas its cdr reflects the number of blank lines after
+contents.
+
+A nil value replicates the number of blank lines found in the
+original Org buffer at the same place."
+  :group 'org-export-e-ascii
+  :type '(choice
+	  (const :tag "Replicate original spacing" nil)
+	  (cons :tag "Set an uniform spacing"
+		(integer :tag "Number of blank lines before contents")
+		(integer :tag "Number of blank lines after contents"))))
+
+(defcustom org-e-ascii-charset 'ascii
+  "The charset allowed to represent various elements and objects.
+Possible values are:
+`ascii'    Only use plain ASCII characters
+`latin1'   Include Latin-1 characters
+`utf-8'    Use all UTF-8 characters"
+  :group 'org-export-e-ascii
+  :type '(choice
+	  (const :tag "ASCII" ascii)
+	  (const :tag "Latin-1" latin1)
+	  (const :tag "UTF-8" utf-8)))
+
+(defcustom org-e-ascii-underline '((ascii ?= ?~ ?-)
+				   (latin1 ?= ?~ ?-)
+				   (utf-8 ?═ ?─ ?╌ ?┄ ?┈))
+  "Characters for underlining headings in ASCII export.
+
+Alist whose key is a symbol among `ascii', `latin1' and `utf-8'
+and whose value is a list of characters.
+
+For each supported charset, this variable associates a sequence
+of underline characters.  In a sequence, the characters will be
+used in order for headlines level 1, 2, ...  If no character is
+available for a given level, the headline won't be underlined."
+  :group 'org-export-e-ascii
+  :type '(list
+	  (cons :tag "Underline characters sequence"
+		(const :tag "ASCII charset" ascii)
+		(repeat character))
+	  (cons :tag "Underline characters sequence"
+		(const :tag "Latin-1 charset" latin1)
+		(repeat character))
+	  (cons :tag "Underline characters sequence"
+		(const :tag "UTF-8 charset" utf-8)
+		(repeat character))))
+
+(defcustom org-e-ascii-bullets '((ascii ?* ?+ ?-)
+				 (latin1 ?§ ?¶)
+				 (utf-8 ?◊))
+  "Bullet characters for headlines converted to lists in ASCII export.
+
+Alist whose key is a symbol among `ascii', `latin1' and `utf-8'
+and whose value is a list of characters.
+
+The first character is used for the first level considered as low
+level, and so on.  If there are more levels than characters given
+here, the list will be repeated.
+
+Note that this variable doesn't affect plain lists
+representation."
+  :group 'org-export-e-ascii
+  :type '(list
+	  (cons :tag "Bullet characters for low level headlines"
+		(const :tag "ASCII charset" ascii)
+		(repeat character))
+	  (cons :tag "Bullet characters for low level headlines"
+		(const :tag "Latin-1 charset" latin1)
+		(repeat character))
+	  (cons :tag "Bullet characters for low level headlines"
+		(const :tag "UTF-8 charset" utf-8)
+		(repeat character))))
+
+(defcustom org-e-ascii-links-to-notes t
+  "Non-nil means convert links to notes before the next headline.
+When nil, the link will be exported in place.  If the line
+becomes long in this way, it will be wrapped."
+  :group 'org-export-e-ascii
+  :type 'boolean)
+
+(defcustom org-e-ascii-table-keep-all-vertical-lines nil
+  "Non-nil means keep all vertical lines in ASCII tables.
+When nil, vertical lines will be removed except for those needed
+for column grouping."
+  :group 'org-export-e-ascii
+  :type 'boolean)
+
+(defcustom org-e-ascii-table-widen-columns t
+  "Non-nil means widen narrowed columns for export.
+When nil, narrowed columns will look in ASCII export just like in
+Org mode, i.e. with \"=>\" as ellipsis."
+  :group 'org-export-e-ascii
+  :type 'boolean)
+
+(defcustom org-e-ascii-table-use-ascii-art nil
+  "Non-nil means table.el tables are turned into ascii-art.
+
+It only makes sense when export charset is `utf-8'.  It is nil by
+default since it requires ascii-art-to-unicode.el package.  You
+can download it here:
+
+  http://gnuvola.org/software/j/aa2u/ascii-art-to-unicode.el.")
+
+(defcustom org-e-ascii-caption-above nil
+  "When non-nil, place caption string before the element.
+Otherwise, place it right after it."
+  :group 'org-export-e-ascii
+  :type 'boolean)
+
+(defcustom org-e-ascii-verbatim-format "`%s'"
+  "Format string used for verbatim text and inline code."
+  :group 'org-export-e-ascii
+  :type 'string)
+
+(defcustom org-e-ascii-format-drawer-function nil
+  "Function called to format a drawer in ASCII.
+
+The function must accept two parameters:
+  NAME      the drawer name, like \"LOGBOOK\"
+  CONTENTS  the contents of the drawer.
+  WIDTH     the text width within the drawer.
+
+The function should return either the string to be exported or
+nil to ignore the drawer.
+
+For example, the variable could be set to the following function
+in order to mimic default behaviour:
+
+\(defun org-e-ascii-format-drawer-default \(name contents width\)
+  \"Format a drawer element for ASCII export.\"
+  contents\)"
+  :group 'org-export-e-ascii
+  :type 'function)
+
+(defcustom org-e-ascii-format-inlinetask-function nil
+  "Function called to format an inlinetask in ASCII.
+
+The function must accept six parameters:
+  TODO      the todo keyword, as a string
+  TODO-TYPE the todo type, a symbol among `todo', `done' and nil.
+  PRIORITY  the inlinetask priority, as a string
+  NAME      the inlinetask name, as a string.
+  TAGS      the inlinetask tags, as a list of strings.
+  CONTENTS  the contents of the inlinetask, as a string.
+
+The function should return either the string to be exported or
+nil to ignore the inline task.
+
+For example, the variable could be set to the following function
+in order to mimic default behaviour:
+
+\(defun org-e-ascii-format-inlinetask-default
+  \(todo type priority name tags contents\)
+  \"Format an inline task element for ASCII export.\"
+  \(let* \(\(utf8p \(eq \(plist-get info :ascii-charset\) 'utf-8\)\)
+           \(width org-e-ascii-inlinetask-width\)
+    \(org-e-ascii--indent-string
+     \(concat
+      ;; Top line, with an additional blank line if not in UTF-8.
+      \(make-string width \(if utf8p ?━ ?_\)\)  \"\\n\"
+      \(unless utf8p \(concat \(make-string width ? \) \"\\n\"\)\)
+      ;; Add title.  Fill it if wider than inlinetask.
+      \(let \(\(title \(org-e-ascii--build-title inlinetask info width\)\)\)
+	\(if \(<= \(length title\) width\) title
+	  \(org-e-ascii--fill-string title width info\)\)\)
+      \"\\n\"
+      ;; If CONTENTS is not empty, insert it along with
+      ;; a separator.
+      \(when \(org-string-nw-p contents\)
+        \(concat \(make-string width \(if utf8p ?─ ?-\)\) \"\\n\" contents\)\)
+      ;; Bottom line.
+      \(make-string width \(if utf8p ?━ ?_\)\)\)
+     ;; Flush the inlinetask to the right.
+     \(- \(plist-get info :ascii-width\)
+        \(plist-get info :ascii-margin\)
+        \(plist-get info :ascii-inner-margin\)
+        \(org-e-ascii--current-text-width inlinetask info\)\)"
+  :group 'org-export-e-ascii
+  :type 'function)
+
+
+
+;;; Internal Functions
+
+;; Internal functions fall into three categories.
+
+;; The first one is about text formatting.  The core function is
+;; `org-e-ascii--current-text-width', which determines the current
+;; text width allowed to a given element.  In other words, it helps
+;; keeping each line width within maximum text width defined in
+;; `org-e-ascii-text-width'.  Once this information is known,
+;; `org-e-ascii--fill-string', `org-e-ascii--justify-string',
+;; `org-e-ascii--box-string' and `org-e-ascii--indent-string' can
+;; operate on a given output string.
+
+;; The second category contains functions handling elements listings,
+;; triggered by "#+TOC:" keyword.  As such, `org-e-ascii--build-toc'
+;; returns a complete table of contents, `org-e-ascii--list-listings'
+;; returns a list of referenceable src-block elements, and
+;; `org-e-ascii--list-tables' does the same for table elements.
+
+;; The third category includes general helper functions.
+;; `org-e-ascii--build-title' creates the title for a given headline
+;; or inlinetask element.  `org-e-ascii--build-caption' returns the
+;; caption string associated to a table or a src-block.
+;; `org-e-ascii--describe-links' creates notes about links for
+;; insertion at the end of a section.  It uses
+;; `org-e-ascii--unique-links' to get the list of links to describe.
+;; Eventually, `org-e-ascii--translate' translates a string according
+;; to language and charset specification.
+
+
+(defun org-e-ascii--fill-string (s text-width info &optional justify)
+  "Fill a string with specified text-width and return it.
+
+S is the string being filled.  TEXT-WIDTH is an integer
+specifying maximum length of a line.  INFO is the plist used as
+a communication channel.
+
+Optional argument JUSTIFY can specify any type of justification
+among `left', `center', `right' or `full'.  A nil value is
+equivalent to `left'.  For a justification that doesn't also fill
+string, see `org-e-ascii--justify-string'.
+
+Return nil if S isn't a string."
+  ;; Don't fill paragraph when break should be preserved.
+  (cond ((not (stringp s)) nil)
+	((plist-get info :preserve-breaks) s)
+	(t (with-temp-buffer
+	     (let ((fill-column text-width)
+		   (use-hard-newlines t))
+	       (insert s)
+	       (fill-region (point-min) (point-max) justify))
+	     (buffer-string)))))
+
+(defun org-e-ascii--justify-string (s text-width how)
+  "Justify string S.
+TEXT-WIDTH is an integer specifying maximum length of a line.
+HOW determines the type of justification: it can be `left',
+`right', `full' or `center'."
+  (with-temp-buffer
+    (insert s)
+    (goto-char (point-min))
+    (let ((fill-column text-width))
+      (while (< (point) (point-max))
+	(justify-current-line how)
+	(forward-line)))
+    (buffer-string)))
+
+(defun org-e-ascii--indent-string (s width)
+  "Indent string S by WIDTH white spaces.
+Empty lines are not indented."
+  (when (stringp s)
+    (replace-regexp-in-string
+     "\\(^\\)\\(?:.*\\S-\\)" (make-string width ? ) s nil nil 1)))
+
+(defun org-e-ascii--box-string (s info)
+  "Return string S with a partial box to its left.
+INFO is a plist used as a communicaton channel."
+  (let ((utf8p (eq (plist-get info :ascii-charset) 'utf-8)))
+    (format (if utf8p "╭────\n%s\n╰────" ",----\n%s\n`----")
+	    (replace-regexp-in-string
+	     "^" (if utf8p "│ " "| ")
+	     ;; Remove last newline character.
+	     (replace-regexp-in-string "\n[ \t]*\\'" "" s)))))
+
+(defun org-e-ascii--current-text-width (element info)
+  "Return maximum text width for ELEMENT's contents.
+INFO is a plist used as a communication channel."
+  (case (org-element-type element)
+    ;; Elements with an absolute width: `headline' and `inlinetask'.
+    (inlinetask org-e-ascii-inlinetask-width)
+    ('headline
+     (- org-e-ascii-text-width
+	(let ((low-level-rank (org-export-low-level-p element info)))
+	  (if low-level-rank (* low-level-rank 2) org-e-ascii-global-margin))))
+    ;; Elements with a relative width: store maximum text width in
+    ;; TOTAL-WIDTH.
+    (otherwise
+     (let* ((genealogy (cons element (org-export-get-genealogy element)))
+	    ;; Total width is determined by the presence, or not, of an
+	    ;; inline task among ELEMENT parents.
+	    (total-width
+	     (if (loop for parent in genealogy
+		       thereis (eq (org-element-type parent) 'inlinetask))
+		 org-e-ascii-inlinetask-width
+	       ;; No inlinetask: Remove global margin from text width.
+	       (- org-e-ascii-text-width
+		  org-e-ascii-global-margin
+		  (let ((parent (org-export-get-parent-headline element)))
+		    ;; Inner margin doesn't apply to text before first
+		    ;; headline.
+		    (if (not parent) 0
+		      (let ((low-level-rank
+			     (org-export-low-level-p parent info)))
+			;; Inner margin doesn't apply to contents of
+			;; low level headlines, since they've got their
+			;; own indentation mechanism.
+			(if low-level-rank (* low-level-rank 2)
+			  org-e-ascii-inner-margin))))))))
+       (- total-width
+	  ;; Each `quote-block', `quote-section' and `verse-block' above
+	  ;; narrows text width by twice the standard margin size.
+	  (+ (* (loop for parent in genealogy
+		      when (memq (org-element-type parent)
+				 '(quote-block quote-section verse-block))
+		      count parent)
+		2 org-e-ascii-quote-margin)
+	     ;; Text width within a plain-list is restricted by
+	     ;; indentation of current item.  If that's the case,
+	     ;; compute it with the help of `:structure' property from
+	     ;; parent item, if any.
+	     (let ((parent-item
+		    (if (eq (org-element-type element) 'item) element
+		      (loop for parent in genealogy
+			    when (eq (org-element-type parent) 'item)
+			    return parent))))
+	       (if (not parent-item) 0
+		 ;; Compute indentation offset of the current item,
+		 ;; that is the sum of the difference between its
+		 ;; indentation and the indentation of the top item in
+		 ;; the list and current item bullet's length.  Also
+		 ;; remove checkbox length, and tag length (for
+		 ;; description lists) or bullet length.
+		 (let ((struct (org-element-property :structure parent-item))
+		       (beg-item (org-element-property :begin parent-item)))
+		   (+ (- (org-list-get-ind beg-item struct)
+			 (org-list-get-ind
+			  (org-list-get-top-point struct) struct))
+		      (length (org-e-ascii--checkbox parent-item info))
+		      (length
+		       (or (org-list-get-tag beg-item struct)
+			   (org-list-get-bullet beg-item struct)))))))))))))
+
+(defun org-e-ascii--build-title
+  (element info text-width &optional underline notags)
+  "Format ELEMENT title and return it.
+
+ELEMENT is either an `headline' or `inlinetask' element.  INFO is
+a plist used as a communication channel.  TEXT-WIDTH is an
+integer representing the maximum length of a line.
+
+When optional argument UNDERLINE is non-nil, underline title,
+without the tags, according to `org-e-ascii-underline'
+specifications.
+
+if optional argument NOTAGS is nil, no tags will be added to the
+title."
+  (let* ((headlinep (eq (org-element-type element) 'headline))
+	 (numbers
+	  ;; Numbering is specific to headlines.
+	  (and headlinep (org-export-numbered-headline-p element info)
+	       ;; All tests passed: build numbering string.
+	       (concat
+		(mapconcat
+		 'number-to-string
+		 (org-export-get-headline-number element info) ".")
+		" ")))
+	 (text (org-export-data (org-element-property :title element) info))
+	 (todo
+	  (and (plist-get info :with-todo-keywords)
+	       (let ((todo (org-element-property :todo-keyword element)))
+		 (and todo (concat (org-export-data todo info) " ")))))
+	 (tags (and (not notags)
+		    (plist-get info :with-tags)
+		    (let ((tag-list (org-export-get-tags element info)))
+		      (and tag-list
+			   (format ":%s:"
+				   (mapconcat 'identity tag-list ":"))))))
+	 (priority
+	  (and (plist-get info :with-priority)
+	       (let ((char (org-element-property :priority element)))
+		 (and char (format "(#%c) " char)))))
+	 (first-part (concat numbers todo priority text)))
+    (concat
+     first-part
+     ;; Align tags, if any.
+     (when tags
+       (format
+	(format " %%%ds"
+		(max (- text-width  (1+ (length first-part))) (length tags)))
+	tags))
+     ;; Maybe underline text, if ELEMENT type is `headline' and an
+     ;; underline character has been defined.
+     (when (and underline headlinep)
+       (let ((under-char
+	      (nth (1- (org-export-get-relative-level element info))
+		   (cdr (assq (plist-get info :ascii-charset)
+			      org-e-ascii-underline)))))
+	 (and under-char
+	      (concat "\n"
+		      (make-string (length first-part) under-char))))))))
+
+(defun org-e-ascii--has-caption-p (element info)
+  "Non-nil when ELEMENT has a caption affiliated keyword.
+INFO is a plist used as a communication channel.  This function
+is meant to be used as a predicate for `org-export-get-ordinal'."
+  (org-element-property :caption element))
+
+(defun org-e-ascii--build-caption (element info)
+  "Return caption string for ELEMENT, if applicable.
+
+INFO is a plist used as a communication channel.
+
+The caption string contains the sequence number of ELEMENT along
+with its real caption.  Return nil when ELEMENT has no affiliated
+caption keyword."
+  (let ((caption (org-element-property :caption element)))
+    (when caption
+      ;; Get sequence number of current src-block among every
+      ;; src-block with a caption.
+      (let ((reference
+	     (org-export-get-ordinal
+	      element info nil 'org-e-ascii--has-caption-p))
+	    (title-fmt (org-e-ascii--translate
+			(case (org-element-type element)
+			  (table "Table %d: %s")
+			  (src-block "Listing %d: %s"))
+			info)))
+	(org-e-ascii--fill-string
+	 (format title-fmt reference (org-export-data (car caption) info))
+	 (org-e-ascii--current-text-width element info) info)))))
+
+(defun org-e-ascii--build-toc (info &optional n keyword)
+  "Return a table of contents.
+
+INFO is a plist used as a communication channel.
+
+Optional argument N, when non-nil, is an integer specifying the
+depth of the table.
+
+Optional argument KEYWORD specifies the TOC keyword, if any, from
+which the table of contents generation has been initiated."
+  (let ((title (org-e-ascii--translate "Table of Contents" info)))
+    (concat
+     title "\n"
+     (make-string (length title)
+		  (if (eq (plist-get info :ascii-charset) 'utf-8) ?─ ?_))
+     "\n\n"
+     (let ((text-width
+	    (if keyword (org-e-ascii--current-text-width keyword info)
+	      (- org-e-ascii-text-width org-e-ascii-global-margin))))
+       (mapconcat
+	(lambda (headline)
+	  (let* ((level (org-export-get-relative-level headline info))
+		 (indent (* (1- level) 3)))
+	    (concat
+	     (unless (zerop indent) (concat (make-string (1- indent) ?.) " "))
+	     (org-e-ascii--build-title
+	      headline info (- text-width indent) nil
+	      (eq (plist-get info :with-tags) 'not-in-toc)))))
+	(org-export-collect-headlines info n) "\n")))))
+
+(defun org-e-ascii--list-listings (keyword info)
+  "Return a list of listings.
+
+KEYWORD is the keyword that initiated the list of listings
+generation.  INFO is a plist used as a communication channel."
+  (let ((title (org-e-ascii--translate "List of Listings" info)))
+    (concat
+     title "\n"
+     (make-string (length title)
+		  (if (eq (plist-get info :ascii-charset) 'utf-8) ?─ ?_))
+     "\n\n"
+     (let ((text-width
+	    (if keyword (org-e-ascii--current-text-width keyword info)
+	      (- org-e-ascii-text-width org-e-ascii-global-margin)))
+	   ;; Use a counter instead of retreiving ordinal of each
+	   ;; src-block.
+	   (count 0))
+       (mapconcat
+	(lambda (src-block)
+	  ;; Store initial text so its length can be computed.  This is
+	  ;; used to properly align caption right to it in case of
+	  ;; filling (like contents of a description list item).
+	  (let ((initial-text
+		 (format (org-e-ascii--translate "Listing %d:" info)
+			 (incf count))))
+	    (concat
+	     initial-text " "
+	     (org-trim
+	      (org-e-ascii--indent-string
+	       (org-e-ascii--fill-string
+		(let ((caption (org-element-property :caption src-block)))
+		  ;; Use short name in priority, if available.
+		  (org-export-data (or (cdr caption) (car caption)) info))
+		(- text-width (length initial-text)) info)
+	       (length initial-text))))))
+	(org-export-collect-listings info) "\n")))))
+
+(defun org-e-ascii--list-tables (keyword info)
+  "Return a list of listings.
+
+KEYWORD is the keyword that initiated the list of listings
+generation.  INFO is a plist used as a communication channel."
+  (let ((title (org-e-ascii--translate "List of Tables" info)))
+    (concat
+     title "\n"
+     (make-string (length title)
+		  (if (eq (plist-get info :ascii-charset) 'utf-8) ?─ ?_))
+     "\n\n"
+     (let ((text-width
+	    (if keyword (org-e-ascii--current-text-width keyword info)
+	      (- org-e-ascii-text-width org-e-ascii-global-margin)))
+	   ;; Use a counter instead of retreiving ordinal of each
+	   ;; src-block.
+	   (count 0))
+       (mapconcat
+	(lambda (table)
+	  ;; Store initial text so its length can be computed.  This is
+	  ;; used to properly align caption right to it in case of
+	  ;; filling (like contents of a description list item).
+	  (let ((initial-text
+		 (format (org-e-ascii--translate "Table %d:" info)
+			 (incf count))))
+	    (concat
+	     initial-text " "
+	     (org-trim
+	      (org-e-ascii--indent-string
+	       (org-e-ascii--fill-string
+		(let ((caption (org-element-property :caption table)))
+		  ;; Use short name in priority, if available.
+		  (org-export-data (or (cdr caption) (car caption)) info))
+		(- text-width (length initial-text)) info)
+	       (length initial-text))))))
+	(org-export-collect-tables info) "\n")))))
+
+(defun org-e-ascii--unique-links (element info)
+  "Return a list of unique link references in ELEMENT.
+
+ELEMENT is either an headline element or a section element.  INFO
+is a plist used as a communication channel."
+  (let* (seen
+	 (unique-link-p
+	  (function
+	   ;; Return LINK if it wasn't referenced so far, or nil.
+	   ;; Update SEEN links along the way.
+	   (lambda (link)
+	     (let ((footprint
+		    (cons (org-element-property :raw-link link)
+			  (org-element-contents link))))
+	       (unless (member footprint seen)
+		 (push footprint seen) link)))))
+	 ;; If at a section, find parent headline, if any, in order to
+	 ;; count links that might be in the title.
+	 (headline
+	  (if (eq (org-element-type element) 'headline) element
+	    (or (org-export-get-parent-headline element) element))))
+    ;; Get all links in HEADLINE.
+    (org-element-map
+     headline 'link (lambda (link) (funcall unique-link-p link)) info)))
+
+(defun org-e-ascii--describe-links (links width info)
+  "Return a string describing a list of links.
+
+LINKS is a list of link type objects, as returned by
+`org-e-ascii--unique-links'.  WIDTH is the text width allowed for
+the output string.  INFO is a plist used as a communication
+channel."
+  (mapconcat
+   (lambda (link)
+     (let ((type (org-element-property :type link))
+	   (anchor (let ((desc (org-element-contents link)))
+		     (if (not desc) (org-element-property :raw-link link)
+		       (org-export-data desc info)))))
+       (cond
+	;; Coderefs, radio links and fuzzy links are ignored.
+	((member type '("coderef" "radio" "fuzzy")) nil)
+	;; Id and custom-id links: Headlines refer to their numbering.
+	((member type '("custom-id" "id"))
+	 (let ((dest (org-export-resolve-id-link link info)))
+	   (concat
+	    (org-e-ascii--fill-string
+	     (format
+	      "[%s] %s"
+	      anchor
+	      (if (not dest) (org-e-ascii--translate "Unknown reference" info)
+		(format
+		 (org-e-ascii--translate "See section %s" info)
+		 (mapconcat 'number-to-string
+			    (org-export-get-headline-number dest info) "."))))
+	     width info) "\n\n")))
+	;; Do not add a link that cannot be resolved and doesn't have
+	;; any description: destination is already visible in the
+	;; paragraph.
+	((not (org-element-contents link)) nil)
+	(t
+	 (concat
+	  (org-e-ascii--fill-string
+	   (format "[%s] %s" anchor (org-element-property :raw-link link))
+	   width info)
+	  "\n\n")))))
+   links ""))
+
+(defun org-e-ascii--checkbox (item info)
+  "Return checkbox string for ITEM or nil.
+INFO is a plist used as a communication channel."
+  (let ((utf8p (eq (plist-get info :ascii-charset) 'utf-8)))
+    (case (org-element-property :checkbox item)
+      (on (if utf8p "☑ " "[X] "))
+      (off (if utf8p "☐ " "[ ] "))
+      (trans (if utf8p "☒ " "[-] ")))))
+
+
+
+;;; Template
+
+(defun org-e-ascii-template--document-title (info)
+  "Return document title, as a string.
+INFO is a plist used as a communication channel."
+  (let ((text-width org-e-ascii-text-width)
+	(title (org-export-data (plist-get info :title) info))
+	(author (and (plist-get info :with-author)
+		     (let ((auth (plist-get info :author)))
+		       (and auth (org-export-data auth info)))))
+	(email (and (plist-get info :with-email)
+		    (org-export-data (plist-get info :email) info)))
+	(date (org-export-data (plist-get info :date) info)))
+    ;; There are two types of title blocks depending on the presence
+    ;; of a title to display.
+    (if (string= title "")
+	;; Title block without a title.  DATE is positioned at the top
+	;; right of the document, AUTHOR to the top left and EMAIL
+	;; just below.
+	(cond
+	 ((and (org-string-nw-p date) (org-string-nw-p author))
+	  (concat
+	   author
+	   (make-string (- text-width (length date) (length author)) ? )
+	   date
+	   (when (org-string-nw-p email) (concat "\n" email))
+	   "\n\n\n"))
+	 ((and (org-string-nw-p date) (org-string-nw-p email))
+	  (concat
+	   email
+	   (make-string (- text-width (length date) (length email)) ? )
+	   date "\n\n\n"))
+	 ((org-string-nw-p date)
+	  (concat
+	   (org-e-ascii--justify-string date text-width 'right)
+	   "\n\n\n"))
+	 ((and (org-string-nw-p author) (org-string-nw-p email))
+	  (concat author "\n" email "\n\n\n"))
+	 ((org-string-nw-p author) (concat author "\n\n\n"))
+	 ((org-string-nw-p email) (concat email "\n\n\n")))
+      ;; Title block with a title.  Document's TITLE, along with the
+      ;; AUTHOR and its EMAIL are both overlined and an underlined,
+      ;; centered.  Date is just below, also centered.
+      (let* ((utf8p (eq (plist-get info :ascii-charset) 'utf-8))
+	     ;; Format TITLE.  It may be filled if it is too wide,
+	     ;; that is wider than the two thirds of the total width.
+	     (title-len (min (length title) (/ (* 2 text-width) 3)))
+	     (formatted-title (org-e-ascii--fill-string title title-len info))
+	     (line
+	      (make-string
+	       (min (+ (max title-len (length author) (length email)) 2)
+		    text-width) (if utf8p ?━ ?_))))
+	(org-e-ascii--justify-string
+	 (concat line "\n"
+		 (unless utf8p "\n")
+		 (upcase formatted-title)
+		 (cond
+		  ((and (org-string-nw-p author) (org-string-nw-p email))
+		   (concat (if utf8p "\n\n\n" "\n\n") author "\n" email))
+		  ((org-string-nw-p author)
+		   (concat (if utf8p "\n\n\n" "\n\n") author))
+		  ((org-string-nw-p email)
+		   (concat (if utf8p "\n\n\n" "\n\n") email)))
+		 "\n" line
+		 (when (org-string-nw-p date) (concat "\n\n\n" date))
+		 "\n\n\n") text-width 'center)))))
+
+(defun org-e-ascii-template (contents info)
+  "Return complete document string after ASCII conversion.
+CONTENTS is the transcoded contents string.  INFO is a plist
+holding export options."
+  (org-element-normalize-string
+   (org-e-ascii--indent-string
+    (let ((text-width (- org-e-ascii-text-width org-e-ascii-global-margin)))
+      ;; 1. Build title block.
+      (concat
+       (org-e-ascii-template--document-title info)
+       ;; 2. Table of contents.
+       (let ((depth (plist-get info :with-toc)))
+	 (when depth
+	   (concat
+	    (org-e-ascii--build-toc info (and (wholenump depth) depth))
+	    "\n\n\n")))
+       ;; 3. Document's body.
+       contents
+       ;; 4. Footnote definitions.
+       (let ((definitions (org-export-collect-footnote-definitions
+			   (plist-get info :parse-tree) info))
+	     ;; Insert full links right inside the footnote definition
+	     ;; as they have no chance to be inserted later.
+	     (org-e-ascii-links-to-notes nil))
+	 (when definitions
+	   (concat
+	    "\n\n\n"
+	    (let ((title (org-e-ascii--translate "Footnotes" info)))
+	      (concat
+	       title "\n"
+	       (make-string
+		(length title)
+		(if (eq (plist-get info :ascii-charset) 'utf-8) ?─ ?_))))
+	    "\n\n"
+	    (mapconcat
+	     (lambda (ref)
+	       (let ((id (format "[%s] " (car ref))))
+		 ;; Distinguish between inline definitions and
+		 ;; full-fledged definitions.
+		 (org-trim
+		  (let ((def (nth 2 ref)))
+		    (if (eq (org-element-type def) 'org-data)
+			;; Full-fledged definition: footnote ID is
+			;; inserted inside the first parsed paragraph
+			;; (FIRST), if any, to be sure filling will
+			;; take it into consideration.
+			(let ((first (car (org-element-contents def))))
+			  (if (not (eq (org-element-type first) 'paragraph))
+			      (concat id "\n" (org-export-data def info))
+			    (push id (nthcdr 2 first))
+			    (org-export-data def info)))
+		      ;; Fill paragraph once footnote ID is inserted in
+		      ;; order to have a correct length for first line.
+		      (org-e-ascii--fill-string
+		       (concat id (org-export-data def info))
+		       text-width info))))))
+	     definitions "\n\n"))))
+       ;; 5. Creator.  Ignore `comment' value as there are no comments in
+       ;;    ASCII.  Justify it to the bottom right.
+       (let ((creator-info (plist-get info :with-creator)))
+	 (unless (or (not creator-info) (eq creator-info 'comment))
+	   (concat
+	    "\n\n\n"
+	    (org-e-ascii--fill-string
+	     (plist-get info :creator) text-width info 'right))))))
+    org-e-ascii-global-margin)))
+
+(defun org-e-ascii--translate (s info)
+  "Translate string S according to specified language and charset.
+INFO is a plist used as a communication channel."
+  (let ((charset (intern (format ":%s" (plist-get info :ascii-charset)))))
+    (org-export-translate s charset info)))
+
+
+
+;;; Transcode Functions
+
+;;;; Babel Call
+
+;; Babel Calls are ignored.
+
+
+;;;; Bold
+
+(defun org-e-ascii-bold (bold contents info)
+  "Transcode BOLD from Org to ASCII.
+CONTENTS is the text with bold markup.  INFO is a plist holding
+contextual information."
+  (format "*%s*" contents))
+
+
+;;;; Center Block
+
+(defun org-e-ascii-center-block (center-block contents info)
+  "Transcode a CENTER-BLOCK element from Org to ASCII.
+CONTENTS holds the contents of the block.  INFO is a plist
+holding contextual information."
+  (org-e-ascii--justify-string
+   contents (org-e-ascii--current-text-width center-block info) 'center))
+
+
+;;;; Clock
+
+(defun org-e-ascii-clock (clock contents info)
+  "Transcode a CLOCK object from Org to ASCII.
+CONTENTS is nil.  INFO is a plist holding contextual
+information."
+  (concat org-clock-string " "
+	  (org-translate-time (org-element-property :value clock))
+	  (let ((time (org-element-property :time clock)))
+	    (and time
+		 (concat " => "
+			 (apply 'format
+				"%2s:%02s"
+				(org-split-string time ":")))))))
+
+
+;;;; Code
+
+(defun org-e-ascii-code (code contents info)
+  "Return a CODE object from Org to ASCII.
+CONTENTS is nil.  INFO is a plist holding contextual
+information."
+  (format org-e-ascii-verbatim-format (org-element-property :value code)))
+
+
+;;;; Comment
+
+;; Comments are ignored.
+
+
+;;;; Comment Block
+
+;; Comment Blocks are ignored.
+
+
+;;;; Drawer
+
+(defun org-e-ascii-drawer (drawer contents info)
+  "Transcode a DRAWER element from Org to ASCII.
+CONTENTS holds the contents of the block.  INFO is a plist
+holding contextual information."
+  (let ((name (org-element-property :drawer-name drawer))
+	(width (org-e-ascii--current-text-width drawer info)))
+    (if (functionp org-e-ascii-format-drawer-function)
+	(funcall org-e-ascii-format-drawer-function name contents width)
+      ;; If there's no user defined function: simply
+      ;; display contents of the drawer.
+      contents)))
+
+
+;;;; Dynamic Block
+
+(defun org-e-ascii-dynamic-block (dynamic-block contents info)
+  "Transcode a DYNAMIC-BLOCK element from Org to ASCII.
+CONTENTS holds the contents of the block.  INFO is a plist
+holding contextual information."
+  contents)
+
+
+;;;; Entity
+
+(defun org-e-ascii-entity (entity contents info)
+  "Transcode an ENTITY object from Org to ASCII.
+CONTENTS are the definition itself.  INFO is a plist holding
+contextual information."
+  (org-element-property
+   (intern (concat ":" (symbol-name (plist-get info :ascii-charset))))
+   entity))
+
+
+;;;; Example Block
+
+(defun org-e-ascii-example-block (example-block contents info)
+  "Transcode a EXAMPLE-BLOCK element from Org to ASCII.
+CONTENTS is nil.  INFO is a plist holding contextual information."
+  (org-e-ascii--box-string
+   (org-export-format-code-default example-block info) info))
+
+
+;;;; Export Snippet
+
+(defun org-e-ascii-export-snippet (export-snippet contents info)
+  "Transcode a EXPORT-SNIPPET object from Org to ASCII.
+CONTENTS is nil.  INFO is a plist holding contextual information."
+  (when (eq (org-export-snippet-backend export-snippet) 'e-ascii)
+    (org-element-property :value export-snippet)))
+
+
+;;;; Export Block
+
+(defun org-e-ascii-export-block (export-block contents info)
+  "Transcode a EXPORT-BLOCK element from Org to ASCII.
+CONTENTS is nil.  INFO is a plist holding contextual information."
+  (when (string= (org-element-property :type export-block) "ASCII")
+    (org-remove-indentation (org-element-property :value export-block))))
+
+
+;;;; Fixed Width
+
+(defun org-e-ascii-fixed-width (fixed-width contents info)
+  "Transcode a FIXED-WIDTH element from Org to ASCII.
+CONTENTS is nil.  INFO is a plist holding contextual information."
+  (org-e-ascii--box-string
+   (org-remove-indentation
+    (org-element-property :value fixed-width)) info))
+
+
+;;;; Footnote Definition
+
+;; Footnote Definitions are ignored.  They are compiled at the end of
+;; the document, by `org-e-ascii-template'.
+
+
+;;;; Footnote Reference
+
+(defun org-e-ascii-footnote-reference (footnote-reference contents info)
+  "Transcode a FOOTNOTE-REFERENCE element from Org to ASCII.
+CONTENTS is nil.  INFO is a plist holding contextual information."
+  (format "[%s]" (org-export-get-footnote-number footnote-reference info)))
+
+
+;;;; Headline
+
+(defun org-e-ascii-headline (headline contents info)
+  "Transcode an HEADLINE element from Org to ASCII.
+CONTENTS holds the contents of the headline.  INFO is a plist
+holding contextual information."
+  ;; Don't export footnote section, which will be handled at the end
+  ;; of the template.
+  (unless (org-element-property :footnote-section-p headline)
+    (let* ((low-level-rank (org-export-low-level-p headline info))
+	   (width (org-e-ascii--current-text-width headline info))
+	   ;; Blank lines between headline and its contents.
+	   ;; `org-e-ascii-headline-spacing', when set, overwrites
+	   ;; original buffer's spacing.
+	   (pre-blanks
+	    (make-string
+	     (if org-e-ascii-headline-spacing (car org-e-ascii-headline-spacing)
+	       (org-element-property :pre-blank headline)) ?\n))
+	   ;; Even if HEADLINE has no section, there might be some
+	   ;; links in its title that we shouldn't forget to describe.
+	   (links
+	    (unless (or (eq (caar (org-element-contents headline)) 'section))
+	      (let ((title (org-element-property :title headline)))
+		(when (consp title)
+		  (org-e-ascii--describe-links
+		   (org-e-ascii--unique-links title info) width info))))))
+      ;; Deep subtree: export it as a list item.
+      (if low-level-rank
+	  (concat
+	   ;; Bullet.
+	   (let ((bullets (cdr (assq (plist-get info :ascii-charset)
+				     org-e-ascii-bullets))))
+	     (char-to-string
+	      (nth (mod (1- low-level-rank) (length bullets)) bullets)))
+	   " "
+	   ;; Title.
+	   (org-e-ascii--build-title headline info width) "\n"
+	   ;; Contents, indented by length of bullet.
+	   pre-blanks
+	   (org-e-ascii--indent-string
+	    (concat contents
+		    (when (org-string-nw-p links) (concat "\n\n" links)))
+	    2))
+	;; Else: Standard headline.
+	(concat
+	 (org-e-ascii--build-title headline info width 'underline)
+	 "\n" pre-blanks
+	 (concat (when (org-string-nw-p links) links) contents))))))
+
+
+;;;; Horizontal Rule
+
+(defun org-e-ascii-horizontal-rule (horizontal-rule contents info)
+  "Transcode an HORIZONTAL-RULE object from Org to ASCII.
+CONTENTS is nil.  INFO is a plist holding contextual
+information."
+  (let ((text-width (org-e-ascii--current-text-width horizontal-rule info))
+	(spec-width
+	 (org-export-read-attribute :attr_ascii horizontal-rule :width)))
+    (org-e-ascii--justify-string
+     (make-string (if (wholenump spec-width) spec-width text-width)
+		  (if (eq (plist-get info :ascii-charset) 'utf-8) ?― ?-))
+     text-width 'center)))
+
+
+;;;; Inline Babel Call
+
+;; Inline Babel Calls are ignored.
+
+
+;;;; Inline Src Block
+
+(defun org-e-ascii-inline-src-block (inline-src-block contents info)
+  "Transcode an INLINE-SRC-BLOCK element from Org to ASCII.
+CONTENTS holds the contents of the item.  INFO is a plist holding
+contextual information."
+  (format org-e-ascii-verbatim-format
+	  (org-element-property :value inline-src-block)))
+
+
+;;;; Inlinetask
+
+(defun org-e-ascii-inlinetask (inlinetask contents info)
+  "Transcode an INLINETASK element from Org to ASCII.
+CONTENTS holds the contents of the block.  INFO is a plist
+holding contextual information."
+  (let ((width (org-e-ascii--current-text-width inlinetask info)))
+    ;; If `org-e-ascii-format-inlinetask-function' is provided, call it
+    ;; with appropriate arguments.
+    (if (functionp org-e-ascii-format-inlinetask-function)
+	(funcall org-e-ascii-format-inlinetask-function
+		 ;; todo.
+		 (and (plist-get info :with-todo-keywords)
+		      (let ((todo (org-element-property
+				   :todo-keyword inlinetask)))
+			(and todo (org-export-data todo info))))
+		 ;; todo-type
+		 (org-element-property :todo-type inlinetask)
+		 ;; priority
+		 (and (plist-get info :with-priority)
+		      (org-element-property :priority inlinetask))
+		 ;; title
+		 (org-export-data (org-element-property :title inlinetask) info)
+		 ;; tags
+		 (and (plist-get info :with-tags)
+		      (org-element-property :tags inlinetask))
+		 ;; contents and width
+		 contents width)
+      ;; Otherwise, use a default template.
+      (let* ((utf8p (eq (plist-get info :ascii-charset) 'utf-8)))
+	(org-e-ascii--indent-string
+	 (concat
+	  ;; Top line, with an additional blank line if not in UTF-8.
+	  (make-string width (if utf8p ?━ ?_))  "\n"
+	  (unless utf8p (concat (make-string width ? ) "\n"))
+	  ;; Add title.  Fill it if wider than inlinetask.
+	  (let ((title (org-e-ascii--build-title inlinetask info width)))
+	    (if (<= (length title) width) title
+	      (org-e-ascii--fill-string title width info)))
+	  "\n"
+	  ;; If CONTENTS is not empty, insert it along with
+	  ;; a separator.
+	  (when (org-string-nw-p contents)
+	    (concat (make-string width (if utf8p ?─ ?-)) "\n" contents))
+	  ;; Bottom line.
+	  (make-string width (if utf8p ?━ ?_)))
+	 ;; Flush the inlinetask to the right.
+	 (- org-e-ascii-text-width org-e-ascii-global-margin
+	    (if (not (org-export-get-parent-headline inlinetask)) 0
+	      org-e-ascii-inner-margin)
+	    (org-e-ascii--current-text-width inlinetask info)))))))
+
+;;;; Italic
+
+(defun org-e-ascii-italic (italic contents info)
+  "Transcode italic from Org to ASCII.
+CONTENTS is the text with italic markup.  INFO is a plist holding
+contextual information."
+  (format "/%s/" contents))
+
+
+;;;; Item
+
+(defun org-e-ascii-item (item contents info)
+  "Transcode an ITEM element from Org to ASCII.
+CONTENTS holds the contents of the item.  INFO is a plist holding
+contextual information."
+  (let* ((utf8p (eq (plist-get info :ascii-charset) 'utf-8))
+	 (checkbox (org-e-ascii--checkbox item info))
+	 (list-type (org-element-property :type (org-export-get-parent item)))
+	 (bullet
+	  ;; First parent of ITEM is always the plain-list.  Get
+	  ;; `:type' property from it.
+	  (org-list-bullet-string
+	   (case list-type
+	     (descriptive
+	      (concat checkbox
+		      (org-export-data (org-element-property :tag item) info)
+		      ": "))
+	     (ordered
+	      ;; Return correct number for ITEM, paying attention to
+	      ;; counters.
+	      (let* ((struct (org-element-property :structure item))
+		     (bul (org-element-property :bullet item))
+		     (num (number-to-string
+			   (car (last (org-list-get-item-number
+				       (org-element-property :begin item)
+				       struct
+				       (org-list-prevs-alist struct)
+				       (org-list-parents-alist struct)))))))
+		(replace-regexp-in-string "[0-9]+" num bul)))
+	     (t (let ((bul (org-element-property :bullet item)))
+		  ;; Change bullets into more visible form if UTF-8 is active.
+		  (if (not utf8p) bul
+		    (replace-regexp-in-string
+		     "-" "•"
+		     (replace-regexp-in-string
+		      "+" "⁃"
+		      (replace-regexp-in-string "*" "‣" bul))))))))))
+    (concat
+     bullet
+     (unless (eq list-type 'descriptive) checkbox)
+     ;; Contents: Pay attention to indentation.  Note: check-boxes are
+     ;; already taken care of at the paragraph level so they don't
+     ;; interfere with indentation.
+     (let ((contents (org-e-ascii--indent-string contents (length bullet))))
+       (if (eq (org-element-type (car (org-element-contents item))) 'paragraph)
+	   (org-trim contents)
+	 (concat "\n" contents))))))
+
+
+;;;; Keyword
+
+(defun org-e-ascii-keyword (keyword contents info)
+  "Transcode a KEYWORD element from Org to ASCII.
+CONTENTS is nil.  INFO is a plist holding contextual
+information."
+  (let ((key (org-element-property :key keyword))
+	(value (org-element-property :value keyword)))
+    (cond
+     ((string= key "ASCII") value)
+     ((string= key "TOC")
+      (let ((value (downcase value)))
+	(cond
+	 ((string-match "\\" value)
+	  (let ((depth (or (and (string-match "[0-9]+" value)
+				(string-to-number (match-string 0 value)))
+			   (plist-get info :with-toc))))
+	    (org-e-ascii--build-toc
+	     info (and (wholenump depth) depth) keyword)))
+	 ((string= "tables" value)
+	  (org-e-ascii--list-tables keyword info))
+	 ((string= "listings" value)
+	  (org-e-ascii--list-listings keyword info))))))))
+
+
+;;;; Latex Environment
+
+(defun org-e-ascii-latex-environment (latex-environment contents info)
+  "Transcode a LATEX-ENVIRONMENT element from Org to ASCII.
+CONTENTS is nil.  INFO is a plist holding contextual
+information."
+  (org-remove-indentation (org-element-property :value latex-environment)))
+
+
+;;;; Latex Fragment
+
+(defun org-e-ascii-latex-fragment (latex-fragment contents info)
+  "Transcode a LATEX-FRAGMENT object from Org to ASCII.
+CONTENTS is nil.  INFO is a plist holding contextual
+information."
+  (org-element-property :value latex-fragment))
+
+
+;;;; Line Break
+
+(defun org-e-ascii-line-break (line-break contents info)
+  "Transcode a LINE-BREAK object from Org to ASCII.
+CONTENTS is nil.  INFO is a plist holding contextual
+  information."  hard-newline)
+
+
+;;;; Link
+
+(defun org-e-ascii-link (link desc info)
+  "Transcode a LINK object from Org to ASCII.
+
+DESC is the description part of the link, or the empty string.
+INFO is a plist holding contextual information."
+  (let ((raw-link (org-element-property :raw-link link))
+	(type (org-element-property :type link)))
+    (cond
+     ((string= type "coderef")
+      (let ((ref (org-element-property :path link)))
+	(format (org-export-get-coderef-format ref desc)
+		(org-export-resolve-coderef ref info))))
+     ;; Do not apply a special syntax on radio links.  Though, use
+     ;; transcoded target's contents as output.
+     ((string= type "radio")
+      (let ((destination (org-export-resolve-radio-link link info)))
+	(when destination
+	  (org-export-data (org-element-contents destination) info))))
+     ;; Do not apply a special syntax on fuzzy links pointing to
+     ;; targets.
+     ((string= type "fuzzy")
+      (let ((destination (org-export-resolve-fuzzy-link link info)))
+	;; Ignore invisible "#+TARGET: path".
+	(unless (eq (org-element-type destination) 'keyword)
+	  (if (org-string-nw-p desc) desc
+	    (when destination
+	      (let ((number
+		     (org-export-get-ordinal
+		      destination info nil 'org-e-ascii--has-caption-p)))
+		(when number
+		  (if (atom number) (number-to-string number)
+		    (mapconcat 'number-to-string number ".")))))))))
+     (t
+      (if (not (org-string-nw-p desc)) (format "[%s]" raw-link)
+	(concat
+	 (format "[%s]" desc)
+	 (unless org-e-ascii-links-to-notes (format " (%s)" raw-link))))))))
+
+
+;;;; Macro
+
+(defun org-e-ascii-macro (macro contents info)
+  "Transcode a MACRO element from Org to ASCII.
+CONTENTS is nil.  INFO is a plist holding contextual
+information."
+  (org-export-expand-macro macro info))
+
+
+;;;; Paragraph
+
+(defun org-e-ascii-paragraph (paragraph contents info)
+  "Transcode a PARAGRAPH element from Org to ASCII.
+CONTENTS is the contents of the paragraph, as a string.  INFO is
+the plist used as a communication channel."
+  (org-e-ascii--fill-string
+   contents
+   (org-e-ascii--current-text-width paragraph info) info))
+
+
+;;;; Plain List
+
+(defun org-e-ascii-plain-list (plain-list contents info)
+  "Transcode a PLAIN-LIST element from Org to ASCII.
+CONTENTS is the contents of the list.  INFO is a plist holding
+contextual information."
+  contents)
+
+
+;;;; Plain Text
+
+(defun org-e-ascii-plain-text (text info)
+  "Transcode a TEXT string from Org to ASCII.
+INFO is a plist used as a communication channel."
+  (if (not (and (eq (plist-get info :ascii-charset) 'utf-8)
+		(plist-get info :with-special-strings)))
+      text
+    ;; Usual replacements in utf-8 with proper option set.
+    (replace-regexp-in-string
+     "\\.\\.\\." "…"
+     (replace-regexp-in-string
+      "--" "–"
+      (replace-regexp-in-string "---" "—" text)))))
+
+
+;;;; Planning
+
+(defun org-e-ascii-planning (planning contents info)
+  "Transcode a PLANNING element from Org to ASCII.
+CONTENTS is nil.  INFO is a plist used as a communication
+channel."
+  (mapconcat
+   'identity
+   (delq nil
+	 (list (let ((closed (org-element-property :closed planning)))
+		 (when closed (concat org-closed-string " "
+				      (org-translate-time closed))))
+	       (let ((deadline (org-element-property :deadline planning)))
+		 (when deadline (concat org-deadline-string " "
+					(org-translate-time deadline))))
+	       (let ((scheduled (org-element-property :scheduled planning)))
+		 (when scheduled (concat org-scheduled-string " "
+					 (org-translate-time scheduled))))))
+   " "))
+
+
+;;;; Property Drawer
+;;
+;; Property drawers are ignored.
+
+
+;;;; Quote Block
+
+(defun org-e-ascii-quote-block (quote-block contents info)
+  "Transcode a QUOTE-BLOCK element from Org to ASCII.
+CONTENTS holds the contents of the block.  INFO is a plist
+holding contextual information."
+  (let ((width (org-e-ascii--current-text-width quote-block info)))
+    (org-e-ascii--indent-string
+     (org-remove-indentation
+      (org-e-ascii--fill-string contents width info))
+     org-e-ascii-quote-margin)))
+
+
+;;;; Quote Section
+
+(defun org-e-ascii-quote-section (quote-section contents info)
+  "Transcode a QUOTE-SECTION element from Org to ASCII.
+CONTENTS is nil.  INFO is a plist holding contextual information."
+  (let ((width (org-e-ascii--current-text-width quote-section info))
+	(value
+	 (org-export-data
+	  (org-remove-indentation (org-element-property :value quote-section))
+	  info)))
+    (org-e-ascii--indent-string
+     value
+     (+ org-e-ascii-quote-margin
+	;; Don't apply inner margin if parent headline is low level.
+	(let ((headline (org-export-get-parent-headline quote-section)))
+	  (if (org-export-low-level-p headline info) 0
+	    org-e-ascii-inner-margin))))))
+
+
+;;;; Radio Target
+
+(defun org-e-ascii-radio-target (radio-target contents info)
+  "Transcode a RADIO-TARGET object from Org to ASCII.
+CONTENTS is the contents of the target.  INFO is a plist holding
+contextual information."
+  contents)
+
+;;;; Section
+
+(defun org-e-ascii-section (section contents info)
+  "Transcode a SECTION element from Org to ASCII.
+CONTENTS is the contents of the section.  INFO is a plist holding
+contextual information."
+  (org-e-ascii--indent-string
+   (concat
+    contents
+    (when org-e-ascii-links-to-notes
+      ;; Add list of links at the end of SECTION.
+      (let ((links (org-e-ascii--describe-links
+		    (org-e-ascii--unique-links section info)
+		    (org-e-ascii--current-text-width section info) info)))
+	;; Separate list of links and section contents.
+	(when (org-string-nw-p links) (concat "\n\n" links)))))
+   ;; Do not apply inner margin if parent headline is low level.
+   (let ((headline (org-export-get-parent-headline section)))
+     (if (or (not headline) (org-export-low-level-p headline info)) 0
+       org-e-ascii-inner-margin))))
+
+
+;;;; Special Block
+
+(defun org-e-ascii-special-block (special-block contents info)
+  "Transcode a SPECIAL-BLOCK element from Org to ASCII.
+CONTENTS holds the contents of the block.  INFO is a plist
+holding contextual information."
+  contents)
+
+
+;;;; Src Block
+
+(defun org-e-ascii-src-block (src-block contents info)
+  "Transcode a SRC-BLOCK element from Org to ASCII.
+CONTENTS holds the contents of the item.  INFO is a plist holding
+contextual information."
+  (let ((caption (org-e-ascii--build-caption src-block info)))
+    (concat
+     (when (and caption org-e-ascii-caption-above) (concat caption "\n"))
+     (org-e-ascii--box-string
+      (org-export-format-code-default src-block info) info)
+     (when (and caption (not org-e-ascii-caption-above))
+       (concat "\n" caption)))))
+
+;;;; Statistics Cookie
+
+(defun org-e-ascii-statistics-cookie (statistics-cookie contents info)
+  "Transcode a STATISTICS-COOKIE object from Org to ASCII.
+CONTENTS is nil.  INFO is a plist holding contextual information."
+  (org-element-property :value statistics-cookie))
+
+
+;;;; Subscript
+
+(defun org-e-ascii-subscript (subscript contents info)
+  "Transcode a SUBSCRIPT object from Org to ASCII.
+CONTENTS is the contents of the object.  INFO is a plist holding
+contextual information."
+  (if (org-element-property :use-brackets-p subscript)
+      (format "_{%s}" contents)
+    (format "_%s" contents)))
+
+
+;;;; Superscript
+
+(defun org-e-ascii-superscript (superscript contents info)
+  "Transcode a SUPERSCRIPT object from Org to ASCII.
+CONTENTS is the contents of the object.  INFO is a plist holding
+contextual information."
+  (if (org-element-property :use-brackets-p superscript)
+      (format "_{%s}" contents)
+    (format "_%s" contents)))
+
+
+;;;; Strike-through
+
+(defun org-e-ascii-strike-through (strike-through contents info)
+  "Transcode STRIKE-THROUGH from Org to ASCII.
+CONTENTS is text with strike-through markup.  INFO is a plist
+holding contextual information."
+  (format "+%s+" contents))
+
+
+;;;; Table
+
+(defun org-e-ascii-table (table contents info)
+  "Transcode a TABLE element from Org to ASCII.
+CONTENTS is the contents of the table.  INFO is a plist holding
+contextual information."
+  (let ((caption (org-e-ascii--build-caption table info)))
+    (concat
+     ;; Possibly add a caption string above.
+     (when (and caption org-e-ascii-caption-above) (concat caption "\n"))
+     ;; Insert table.  Note: "table.el" tables are left unmodified.
+     (cond ((eq (org-element-property :type table) 'org) contents)
+	   ((and org-e-ascii-table-use-ascii-art
+		 (eq (plist-get info :ascii-charset) 'utf-8)
+		 (require 'ascii-art-to-unicode nil t))
+	    (with-temp-buffer
+	      (insert (org-remove-indentation
+		       (org-element-property :value table)))
+	      (goto-char (point-min))
+	      (aa2u)
+	      (goto-char (point-max))
+	      (skip-chars-backward " \r\t\n")
+	      (buffer-substring (point-min) (point))))
+	   (t (org-remove-indentation (org-element-property :value table))))
+     ;; Possible add a caption string below.
+     (when (and caption (not org-e-ascii-caption-above))
+       (concat "\n" caption)))))
+
+
+;;;; Table Cell
+
+(defun org-e-ascii--table-cell-width (table-cell info)
+  "Return width of TABLE-CELL.
+
+INFO is a plist used as a communication channel.
+
+Width of a cell is determined either by a width cookie in the
+same column as the cell, or by the maximum cell's length in that
+column.
+
+When `org-e-ascii-table-widen-columns' is non-nil, width cookies
+are ignored."
+  (or (and (not org-e-ascii-table-widen-columns)
+	   (org-export-table-cell-width table-cell info))
+      (let* ((max-width 0)
+	     (table (org-export-get-parent-table table-cell))
+	     (specialp (org-export-table-has-special-column-p table))
+	     (col (cdr (org-export-table-cell-address table-cell info))))
+	(org-element-map
+	 table 'table-row
+	 (lambda (row)
+	   (setq max-width
+		 (max (length
+		       (org-export-data
+			(org-element-contents
+			 (elt (if specialp (cdr (org-element-contents row))
+				(org-element-contents row))
+			      col))
+			info))
+		      max-width)))
+	 info)
+	max-width)))
+
+(defun org-e-ascii-table-cell (table-cell contents info)
+  "Transcode a TABLE-CELL object from Org to ASCII.
+CONTENTS is the cell contents.  INFO is a plist used as
+a communication channel."
+  ;; Determine column width.  When `org-e-ascii-table-widen-columns'
+  ;; is nil and some width cookie has set it, use that value.
+  ;; Otherwise, compute the maximum width among transcoded data of
+  ;; each cell in the column.
+  (let ((width (org-e-ascii--table-cell-width table-cell info)))
+    ;; When contents are too large, truncate them.
+    (unless (or org-e-ascii-table-widen-columns (<= (length contents) width))
+      (setq contents (concat (substring contents 0 (- width 2)) "=>")))
+    ;; Align contents correctly within the cell.
+    (let* ((indent-tabs-mode nil)
+	   (data
+	    (when contents
+	      (org-e-ascii--justify-string
+	       contents width
+	       (org-export-table-cell-alignment table-cell info)))))
+      (setq contents (concat data (make-string (- width (length data)) ? ))))
+    ;; Return cell.
+    (concat (format " %s " contents)
+	    (when (memq 'right (org-export-table-cell-borders table-cell info))
+	      (if (eq (plist-get info :ascii-charset) 'utf-8) "│" "|")))))
+
+
+;;;; Table Row
+
+(defun org-e-ascii-table-row (table-row contents info)
+  "Transcode a TABLE-ROW element from Org to ASCII.
+CONTENTS is the row contents.  INFO is a plist used as
+a communication channel."
+  (when (eq (org-element-property :type table-row) 'standard)
+    (let ((build-hline
+	   (function
+	    (lambda (lcorner horiz vert rcorner)
+	      (concat
+	       (apply
+		'concat
+		(org-element-map
+		 table-row 'table-cell
+		 (lambda (cell)
+		   (let ((width (org-e-ascii--table-cell-width cell info))
+			 (borders (org-export-table-cell-borders cell info)))
+		     (concat
+		      ;; In order to know if CELL starts the row, do
+		      ;; not compare it with the first cell in the row
+		      ;; as there might be a special column.  Instead,
+		      ;; compare it with the first exportable cell,
+		      ;; obtained with `org-element-map'.
+		      (when (and (memq 'left borders)
+				 (eq (org-element-map
+				      table-row 'table-cell 'identity info t)
+				     cell))
+			lcorner)
+		      (make-string (+ 2 width) (string-to-char horiz))
+		      (cond
+		       ((not (memq 'right borders)) nil)
+		       ((eq (car (last (org-element-contents table-row))) cell)
+			rcorner)
+		       (t vert)))))
+		 info)) "\n"))))
+	  (utf8p (eq (plist-get info :ascii-charset) 'utf-8))
+	  (borders (org-export-table-cell-borders
+		    (org-element-map table-row 'table-cell 'identity info t)
+		    info)))
+      (concat (cond
+	       ((and (memq 'top borders) (or utf8p (memq 'above borders)))
+		(if utf8p (funcall build-hline "┍" "━" "┯" "┑")
+		  (funcall build-hline "+" "-" "+" "+")))
+	       ((memq 'above borders)
+		(if utf8p (funcall build-hline "├" "─" "┼" "┤")
+		  (funcall build-hline "+" "-" "+" "+"))))
+	      (when (memq 'left borders) (if utf8p "│" "|"))
+	      contents "\n"
+	      (when (and (memq 'bottom borders) (or utf8p (memq 'below borders)))
+		(if utf8p (funcall build-hline "┕" "━" "┷" "┙")
+		  (funcall build-hline "+" "-" "+" "+")))))))
+
+
+;;;; Target
+
+;; Targets are invisible.
+
+
+;;;; Timestamp
+
+(defun org-e-ascii-timestamp (timestamp contents info)
+  "Transcode a TIMESTAMP object from Org to ASCII.
+CONTENTS is nil.  INFO is a plist holding contextual information."
+  (let ((value (org-translate-time (org-element-property :value timestamp)))
+	(range-end
+	 (org-translate-time (org-element-property :range-end timestamp)))
+	(utf8p (eq (plist-get info :ascii-charset) 'utf-8)))
+    (concat value
+	    (when range-end (concat (if utf8p "–" "--") range-end)))))
+
+
+;;;; Underline
+
+(defun org-e-ascii-underline (underline contents info)
+  "Transcode UNDERLINE from Org to ASCII.
+CONTENTS is the text with underline markup.  INFO is a plist
+holding contextual information."
+  (format "_%s_" contents))
+
+
+;;;; Verbatim
+
+(defun org-e-ascii-verbatim (verbatim contents info)
+  "Return a VERBATIM object from Org to ASCII.
+CONTENTS is nil.  INFO is a plist holding contextual information."
+  (format org-e-ascii-verbatim-format
+	  (org-element-property :value verbatim)))
+
+
+;;;; Verse Block
+
+(defun org-e-ascii-verse-block (verse-block contents info)
+  "Transcode a VERSE-BLOCK element from Org to ASCII.
+CONTENTS is verse block contents.  INFO is a plist holding
+contextual information."
+  (let ((verse-width (org-e-ascii--current-text-width verse-block info)))
+    (org-e-ascii--indent-string
+     (org-e-ascii--justify-string contents verse-width 'left)
+     org-e-ascii-quote-margin)))
+
+
+;;; Filter
+
+(defun org-e-ascii-filter-headline-blank-lines (headline back-end info)
+  "Filter controlling number of blank lines after an headline.
+
+HEADLINE is a string representing a transcoded headline.
+BACK-END is symbol specifying back-end used for export.  INFO is
+plist containing the communication channel.
+
+This function only applies to `e-ascii' back-end.  See
+`org-e-ascii-headline-spacing' for information.
+
+For any other back-end, HEADLINE is returned as-is."
+  (if (not org-e-ascii-headline-spacing) headline
+    (let ((blanks (make-string (1+ (cdr org-e-ascii-headline-spacing)) ?\n)))
+      (replace-regexp-in-string "\n\\(?:\n[ \t]*\\)*\\'" blanks headline))))
+
+
+
+;;; Interactive function
+
+;;;###autoload
+(defun org-e-ascii-export-as-ascii
+  (&optional subtreep visible-only body-only ext-plist)
+  "Export current buffer to a text buffer.
+
+If narrowing is active in the current buffer, only export its
+narrowed part.
+
+If a region is active, export that region.
+
+When optional argument SUBTREEP is non-nil, export the sub-tree
+at point, extracting information from the headline properties
+first.
+
+When optional argument VISIBLE-ONLY is non-nil, don't export
+contents of hidden elements.
+
+When optional argument BODY-ONLY is non-nil, strip title, table
+of contents and footnote definitions from output.
+
+EXT-PLIST, when provided, is a property list with external
+parameters overriding Org default settings, but still inferior to
+file-local settings.
+
+Export is done in a buffer named \"*Org E-ASCII Export*\", which
+will be displayed when `org-export-show-temporary-export-buffer'
+is non-nil."
+  (interactive)
+  (let ((outbuf (org-export-to-buffer
+		 'e-ascii "*Org E-ASCII Export*"
+		 subtreep visible-only body-only ext-plist)))
+    (with-current-buffer outbuf (text-mode))
+    (when org-export-show-temporary-export-buffer
+      (switch-to-buffer-other-window outbuf))))
+
+;;;###autoload
+(defun org-e-ascii-export-to-ascii
+  (&optional subtreep visible-only body-only ext-plist pub-dir)
+  "Export current buffer to a text file.
+
+If narrowing is active in the current buffer, only export its
+narrowed part.
+
+If a region is active, export that region.
+
+When optional argument SUBTREEP is non-nil, export the sub-tree
+at point, extracting information from the headline properties
+first.
+
+When optional argument VISIBLE-ONLY is non-nil, don't export
+contents of hidden elements.
+
+When optional argument BODY-ONLY is non-nil, strip title, table
+of contents and footnote definitions from output.
+
+EXT-PLIST, when provided, is a property list with external
+parameters overriding Org default settings, but still inferior to
+file-local settings.
+
+When optional argument PUB-DIR is set, use it as the publishing
+directory.
+
+Return output file's name."
+  (interactive)
+  (let ((outfile (org-export-output-file-name ".txt" subtreep pub-dir)))
+    (org-export-to-file
+     'e-ascii outfile subtreep visible-only body-only ext-plist)))
+
+
+(provide 'org-e-ascii)
+;;; org-e-ascii.el ends here
diff --git a/contrib/lisp/org-e-beamer.el b/contrib/lisp/org-e-beamer.el
new file mode 100644
index 0000000..0c3c430
--- /dev/null
+++ b/contrib/lisp/org-e-beamer.el
@@ -0,0 +1,1069 @@
+;;; org-e-beamer.el --- Beamer Back-End for Org Export Engine
+
+;; Copyright (C) 2007-2012  Free Software Foundation, Inc.
+
+;; Author: Carsten Dominik 
+;;         Nicolas Goaziou 
+;; Keywords: org, wp, tex
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs.  If not, see .
+
+;;; Commentary:
+;;
+;; This library implements both a Beamer back-end, derived from the
+;; LaTeX one and a minor mode easing structure edition of the
+;; document.
+;;
+;; Depending on the desired output format, three commands are provided
+;; for export: `org-e-beamer-export-as-latex' (temporary buffer),
+;; `org-e-beamer-export-to-latex' ("tex" file) and
+;; `org-e-beamer-export-to-pdf' ("pdf" file).
+;;
+;; On top of buffer keywords supported by `e-latex' back-end (see
+;; `org-e-latex-options-alist'), this back-end introduces the
+;; following keywords: "BEAMER_THEME", "BEAMER_COLOR_THEME",
+;; "BEAMER_FONT_THEME", "BEAMER_INNER_THEME" and "BEAMER_OUTER_THEME".
+;; All accept options in square brackets.
+;;
+;; Moreover, headlines now fall into three categories: sectioning
+;; elements, frames and blocks.
+;;
+;; - Like `e-latex' back-end sectioning elements are still set through
+;;   `org-e-latex-classes' variable.
+;;
+;; - Headlines become frames when their level is equal to
+;;   `org-e-beamer-frame-level' (or "H" value in the OPTIONS line).
+;;   Though, if an headline in the current tree has a "BEAMER_env"
+;;   (see below) property set to "frame", its level overrides the
+;;   variable.
+;;
+;; - All frames' children become block environments.  Special block
+;;   types can be enforced by setting headline's "BEAMER_env" property
+;;   to an appropriate value (see `org-e-beamer-environments-default'
+;;   for supported value and `org-e-beamer-environments-extra' for
+;;   adding more).
+;;
+;; - As a special case, if the "BEAMER_env" property is set to either
+;;   "appendix", "note" or "noteNH", the headline will become,
+;;   respectively, an appendix, a note (within frame or between frame,
+;;   depending on its level) and a note with its title ignored.
+;;
+;;   Also, an headline with an "ignoreheading" value will have its
+;;   contents only inserted in the output.  This special value is
+;;   useful to have data between frames, or to properly close
+;;   a "column" environment.
+;;
+;; Along with "BEAMER_env", headlines also support "BEAMER_act" and
+;; "BEAMER_opt" properties.  The former is translated as an
+;; overlay/action specification (or a default overlay specification
+;; when enclosed within square brackets) whereas the latter specifies
+;; options for the current frame ("fragile" option is added
+;; automatically, though).
+;;
+;; Every plain list has support for `:overlay' attribute (through
+;; ATTR_BEAMER affiliated keyword).  Also, ordered (resp. description)
+;; lists make use of `:template' (resp. `:long-text') attribute.
+;;
+;; Eventually, an export snippet with a value enclosed within angular
+;; brackets put at the beginning of an element or object whose type is
+;; among `bold', `item', `link', `radio-target' and `target' will
+;; control its overlay specifications.
+;;
+;; On the minor mode side, `org-e-beamer-select-environment' (bound by
+;; default to "C-c C-b") and `org-e-beamer-insert-options-template'
+;; are the two entry points.
+
+;;; Code:
+
+(require 'org-e-latex)
+
+
+
+;;; User-Configurable Variables
+
+(defgroup org-export-e-beamer nil
+  "Options specific for using the beamer class in LaTeX export."
+  :tag "Org Beamer"
+  :group 'org-export
+  :version "24.2")
+
+(defcustom org-e-beamer-frame-level 1
+  "The level at which headlines become frames.
+
+Headlines at a lower level will be translated into a sectioning
+structure.  At a higher level, they will be translated into
+blocks.
+
+If an headline with a \"BEAMER_env\" property set to \"frame\" is
+found within a tree, its level locally overrides this number.
+
+This variable has no effect on headlines with the \"BEAMER_env\"
+property set to either \"ignoreheading\", \"appendix\", or
+\"note\", which will respectively, be invisible, become an
+appendix or a note.
+
+This integer is relative to the minimal level of an headline
+within the parse tree, defined as 1."
+  :group 'org-export-e-beamer
+  :type 'integer)
+
+(defcustom org-e-beamer-frame-default-options ""
+  "Default options string to use for frames.
+For example, it could be set to \"allowframebreaks\"."
+  :group 'org-export-e-beamer
+  :type '(string :tag "[options]"))
+
+(defcustom org-e-beamer-column-view-format
+  "%45ITEM %10BEAMER_env(Env) %10BEAMER_act(Act) %4BEAMER_col(Col) %8BEAMER_opt(Opt)"
+  "Column view format that should be used to fill the template."
+  :group 'org-export-e-beamer
+  :type '(choice
+	  (const  :tag "Do not insert Beamer column view format" nil)
+	  (string :tag "Beamer column view format")))
+
+(defcustom org-e-beamer-theme "default"
+  "Default theme used in Beamer presentations."
+  :group 'org-export-e-beamer
+  :type '(choice
+	  (const :tag "Do not insert a Beamer theme" nil)
+	  (string :tag "Beamer theme")))
+
+(defcustom org-e-beamer-environments-extra nil
+  "Environments triggered by tags in Beamer export.
+Each entry has 4 elements:
+
+name    Name of the environment
+key     Selection key for `org-e-beamer-select-environment'
+open    The opening template for the environment, with the following escapes
+        %a   the action/overlay specification
+        %A   the default action/overlay specification
+        %o   the options argument of the template
+        %h   the headline text
+        %H   if there is headline text, that text in {} braces
+        %U   if there is headline text, that text in [] brackets
+close   The closing string of the environment."
+  :group 'org-export-e-beamer
+  :type '(repeat
+	  (list
+	   (string :tag "Environment")
+	   (string :tag "Selection key")
+	   (string :tag "Begin")
+	   (string :tag "End"))))
+
+(defcustom org-e-beamer-outline-frame-title "Outline"
+  "Default title of a frame containing an outline."
+  :group 'org-export-e-beamer
+  :type '(string :tag "Outline frame title"))
+
+(defcustom org-e-beamer-outline-frame-options ""
+  "Outline frame options appended after \\begin{frame}.
+You might want to put e.g. \"allowframebreaks=0.9\" here."
+  :group 'org-export-e-beamer
+  :type '(string :tag "Outline frame options"))
+
+
+
+;;; Internal Variables
+
+(defconst org-e-beamer-column-widths
+  "0.1 0.2 0.3 0.4 0.5 0.6 0.7 0.8 0.9 0.0 :ETC"
+"The column widths that should be installed as allowed property values.")
+
+(defconst org-e-beamer-environments-special
+  '(("appendix"       "x")
+    ("column"         "c")
+    ("frame"          "f")
+    ("ignoreheading"  "i")
+    ("note"           "n")
+    ("noteNH"         "N"))
+  "Alist of environments treated in a special way by the back-end.
+Keys are environment names, as strings, values are bindings used
+in `org-e-beamer-select-environment'.  Environments listed here,
+along with their binding, are hard coded and cannot be modified
+through `org-e-beamer-environments-extra' variable.")
+
+(defconst org-e-beamer-environments-default
+  '(("block"          "b" "\\begin{block}%a{%h}"          "\\end{block}")
+    ("alertblock"     "a" "\\begin{alertblock}%a{%h}"     "\\end{alertblock}")
+    ("verse"          "v" "\\begin{verse}%a %% %h"        "\\end{verse}")
+    ("quotation"      "q" "\\begin{quotation}%a %% %h"    "\\end{quotation}")
+    ("quote"          "Q" "\\begin{quote}%a %% %h"        "\\end{quote}")
+    ("structureenv"   "s" "\\begin{structureenv}%a %% %h" "\\end{structureenv}")
+    ("theorem"        "t" "\\begin{theorem}%a%U"          "\\end{theorem}")
+    ("definition"     "d" "\\begin{definition}%a%U"       "\\end{definition}")
+    ("example"        "e" "\\begin{example}%a%U"          "\\end{example}")
+    ("exampleblock"   "E" "\\begin{exampleblock}%a{%h}"   "\\end{exampleblock}")
+    ("proof"          "p" "\\begin{proof}%a%U"            "\\end{proof}")
+    ("beamercolorbox" "o" "\\begin{beamercolorbox}%o{%h}" "\\end{beamercolorbox}"))
+  "Environments triggered by properties in Beamer export.
+These are the defaults - for user definitions, see
+`org-e-beamer-environments-extra'.")
+
+(defconst org-e-beamer-verbatim-elements
+  '(code example-block fixed-width inline-src-block src-block verbatim)
+  "List of element or object types producing verbatim text.
+This is used internally to determine when a frame should have the
+\"fragile\" option.")
+
+
+
+;;; Internal functions
+
+(defun org-e-beamer--normalize-argument (argument type)
+  "Return ARGUMENT string with proper boundaries.
+
+TYPE is a symbol among the following:
+`action'    Return ARGUMENT within angular brackets.
+`defaction' Return ARGUMENT within both square and angular brackets.
+`option'    Return ARGUMENT within square brackets."
+  (if (not (string-match "\\S-" argument)) ""
+    (case type
+      (action (if (string-match "\\`<.*>\\'" argument) argument
+		(format "<%s>" argument)))
+      (defaction (cond
+		  ((string-match "\\`\\[<.*>\\]\\'" argument) argument)
+		  ((string-match "\\`<.*>\\'" argument)
+		   (format "[%s]" argument))
+		  ((string-match "\\`\\[\\(.*\\)\\]\\'" argument)
+		   (format "[<%s>]" (match-string 1 argument)))
+		  (t (format "[<%s>]" argument))))
+      (option (if (string-match "\\`\\[.*\\]\\'" argument) argument
+		(format "[%s]" argument)))
+      (otherwise argument))))
+
+(defun org-e-beamer--element-has-overlay-p (element)
+  "Non-nil when ELEMENT has an overlay specified.
+An element has an overlay specification when it starts with an
+`e-beamer' export-snippet whose value is between angular
+brackets.  Return overlay specification, as a string, or nil."
+  (let ((first-object (car (org-element-contents element))))
+    (when (eq (org-element-type first-object) 'export-snippet)
+      (let ((value (org-element-property :value first-object)))
+	(and (string-match "\\`<.*>\\'" value) value)))))
+
+
+
+;;; Define Back-End
+
+(org-export-define-derived-backend e-beamer e-latex
+  :export-block "BEAMER"
+  :options-alist
+  ((:beamer-theme "BEAMER_THEME" nil org-e-beamer-theme)
+   (:beamer-color-theme "BEAMER_COLOR_THEME" nil nil t)
+   (:beamer-font-theme "BEAMER_FONT_THEME" nil nil t)
+   (:beamer-inner-theme "BEAMER_INNER_THEME" nil nil t)
+   (:beamer-outer-theme "BEAMER_OUTER_THEME" nil nil t)
+   (:headline-levels nil "H" org-e-beamer-frame-level))
+  :translate-alist ((bold . org-e-beamer-bold)
+		    (export-block . org-e-beamer-export-block)
+		    (export-snippet . org-e-beamer-export-snippet)
+		    (headline . org-e-beamer-headline)
+		    (item . org-e-beamer-item)
+		    (keyword . org-e-beamer-keyword)
+		    (link . org-e-beamer-link)
+		    (plain-list . org-e-beamer-plain-list)
+		    (radio-target . org-e-beamer-radio-target)
+		    (target . org-e-beamer-target)
+		    (template . org-e-beamer-template)))
+
+
+
+;;; Transcode Functions
+
+;;;; Bold
+
+(defun org-e-beamer-bold (bold contents info)
+  "Transcode BLOCK object into Beamer code.
+CONTENTS is the text being bold.  INFO is a plist used as
+a communication channel."
+  (format "\\alert%s{%s}"
+	  (or (org-e-beamer--element-has-overlay-p bold) "")
+	  contents))
+
+
+;;;; Export Block
+
+(defun org-e-beamer-export-block (export-block contents info)
+  "Transcode an EXPORT-BLOCK element into Beamer code.
+CONTENTS is nil.  INFO is a plist used as a communication
+channel."
+  (when (member (org-element-property :type export-block) '("BEAMER" "LATEX"))
+    (org-remove-indentation (org-element-property :value export-block))))
+
+
+;;;; Export Snippet
+
+(defun org-e-beamer-export-snippet (export-snippet contents info)
+  "Transcode an EXPORT-SNIPPET object into Beamer code.
+CONTENTS is nil.  INFO is a plist used as a communication
+channel."
+  (let ((backend (org-export-snippet-backend export-snippet))
+	(value (org-element-property :value export-snippet)))
+    ;; Only "e-latex" and "e-beamer" snippets are retained.
+    (cond ((eq backend 'e-latex) value)
+	  ;; Ignore "e-beamer" snippets specifying overlays.
+	  ((and (eq backend 'e-beamer)
+		(or (org-export-get-previous-element export-snippet info)
+		    (not (string-match "\\`<.*>\\'" value))))
+	   value))))
+
+
+;;;; Headline
+;;
+;; The main function to translate an headline is
+;; `org-e-beamer-headline'.
+;;
+;; Depending on the level at which an headline is considered as
+;; a frame (given by `org-e-beamer--frame-level'), the headline is
+;; either a section (`org-e-beamer--format-section'), a frame
+;; (`org-e-beamer--format-frame') or a block
+;; (`org-e-beamer--format-block').
+;;
+;; `org-e-beamer-headline' also takes care of special environments
+;; like "ignoreheading", "note", "noteNH" and "appendix".
+
+(defun org-e-beamer--frame-level (headline info)
+  "Return frame level in subtree containing HEADLINE.
+INFO is a plist used as a communication channel."
+  (or
+   ;; 1. Look for "frame" environment in parents, starting from the
+   ;;    farthest.
+   (catch 'exit
+     (mapc (lambda (parent)
+	     (when (equal (org-element-property :beamer-env parent) "frame")
+	       (throw 'exit (org-export-get-relative-level parent info))))
+	   (reverse (org-export-get-genealogy headline)))
+     nil)
+   ;; 2. Look for "frame" environment in HEADLINE.
+   (and (equal (org-element-property :beamer-env headline) "frame")
+	(org-export-get-relative-level headline info))
+   ;; 3. Look for "frame" environment in sub-tree.
+   (org-element-map
+    headline 'headline
+    (lambda (hl)
+      (when (equal (org-element-property :beamer-env hl) "frame")
+	(org-export-get-relative-level hl info)))
+    info 'first-match)
+   ;; 4. No "frame" environment in tree: use default value.
+   (plist-get info :headline-levels)))
+
+(defun org-e-beamer--format-section (headline contents info)
+  "Format HEADLINE as a sectioning part.
+CONTENTS holds the contents of the headline.  INFO is a plist
+used as a communication channel."
+  ;; Use `e-latex' back-end output, inserting overlay specifications
+  ;; if possible.
+  (let ((latex-headline
+	 (funcall (cdr (assq 'headline org-e-latex-translate-alist))
+		  headline contents info))
+	(mode-specs (org-element-property :beamer-act headline)))
+    (if (and mode-specs
+	     (string-match "\\`\\\\\\(.*?\\)\\(?:\\*\\|\\[.*\\]\\)?{"
+			   latex-headline))
+	(replace-match (concat (match-string 1 latex-headline)
+			       (format "<%s>" mode-specs))
+		       nil nil latex-headline 1)
+      latex-headline)))
+
+(defun org-e-beamer--format-frame (headline contents info)
+  "Format HEADLINE as a frame.
+CONTENTS holds the contents of the headline.  INFO is a plist
+used as a communication channel."
+  (let ((fragilep
+	 ;; FRAGILEP is non-nil when HEADLINE contains an element
+	 ;; among `org-e-beamer-verbatim-elements'.
+	 (org-element-map headline org-e-beamer-verbatim-elements 'identity
+			  info 'first-match)))
+    (concat "\\begin{frame}"
+	    ;; Overlay specification, if any. If is surrounded by square
+	    ;; brackets, consider it as a default specification.
+	    (let ((action (org-element-property :beamer-act headline)))
+	      (cond
+	       ((not action) "")
+	       ((string-match "\\`\\[.*\\]\\'" action )
+		(org-e-beamer--normalize-argument action 'defaction))
+	       (t (org-e-beamer--normalize-argument action 'action))))
+	    ;; Options, if any.
+	    (let ((options
+		   ;; Collect options from default value and headline's
+		   ;; properties.  Also add a label for links.
+		   (append
+		    (org-split-string org-e-beamer-frame-default-options
+				      ",")
+		    (let ((opt (org-element-property :beamer-opt headline)))
+		      (and opt (org-split-string
+				;; Remove square brackets if user
+				;; provided them.
+				(and (string-match "^\\[?\\(.*\\)\\]?$" opt)
+				     (match-string 1 opt))
+				",")))
+		    (list
+		     (format "label=sec-%s"
+			     (mapconcat
+			      'number-to-string
+			      (org-export-get-headline-number headline info)
+			      "-"))))))
+	      ;; Change options list into a string.
+	      (org-e-beamer--normalize-argument
+	       (mapconcat
+		'identity
+		(if (or (not fragilep) (member "fragile" options)) options
+		  (cons "fragile" options))
+		",")
+	       'option))
+	    ;; Title.
+	    (format "{%s}"
+		    (org-export-data (org-element-property :title headline)
+				     info))
+	    "\n"
+	    ;; The following workaround is required in fragile frames
+	    ;; as Beamer will append "\par" to the beginning of the
+	    ;; contents.  So we need to make sure the command is
+	    ;; separated from the contents by at least one space.  If
+	    ;; it isn't, it will create "\parfirst-word" command and
+	    ;; remove the first word from the contents in the PDF
+	    ;; output.
+	    (if (not fragilep) contents
+	      (replace-regexp-in-string "\\`\n*" "\\& " contents))
+	    "\\end{frame}")))
+
+(defun org-e-beamer--format-block (headline contents info)
+  "Format HEADLINE as a block.
+CONTENTS holds the contents of the headline.  INFO is a plist
+used as a communication channel."
+  (let* ((column-width (org-element-property :beamer-col headline))
+	 ;; Environment defaults to "block" if none is specified and
+	 ;; there is no column specification.  If there is a column
+	 ;; specified but still no explicit environment, ENVIRONMENT
+	 ;; is nil.
+	 (environment (let ((env (org-element-property :beamer-env headline)))
+			(cond
+			 ;; "block" is the fallback environment.
+			 ((and (not env) (not column-width)) "block")
+			 ;; "column" only.
+			 ((not env) nil)
+			 ;; Use specified environment.
+			 (t (downcase env)))))
+	 (env-format (when environment
+		       (assoc environment
+			      (append org-e-beamer-environments-special
+				      org-e-beamer-environments-extra
+				      org-e-beamer-environments-default))))
+	 (title (org-export-data (org-element-property :title headline) info))
+	 ;; Start a columns environment when there is no previous
+	 ;; headline or the previous headline do not have
+	 ;; a BEAMER_column property.
+	 (start-columns-p
+	  (and column-width
+	       (or (org-export-first-sibling-p headline info)
+		   (not (org-element-property
+			 :beamer-col
+			 (org-export-get-previous-element headline info))))))
+	 ;; Ends a columns environment when there is no next headline
+	 ;; or the next headline do not have a BEAMER_column property.
+	 (end-columns-p
+	  (and column-width
+	       (or (org-export-last-sibling-p headline info)
+		   (not (org-element-property
+			 :beamer-col
+			 (org-export-get-next-element headline info)))))))
+    (concat
+     (when start-columns-p "\\begin{columns}\n")
+     (when column-width
+       (format "\\begin{column}%s{%s}\n"
+	       ;; One can specify placement for column only when
+	       ;; HEADLINE stands for a column on its own.
+	       (if (not environment) ""
+		 (let ((options (org-element-property :beamer-opt headline)))
+		   (if (not options) ""
+		     (org-e-beamer--normalize-argument options 'option))))
+	       (format "%s\\textwidth" column-width)))
+     ;; Block's opening string.
+     (when env-format
+       (concat
+	(org-fill-template
+	 (nth 2 env-format)
+	 (nconc
+	  ;; If BEAMER_act property has its value enclosed in square
+	  ;; brackets, it is a default overlay specification and
+	  ;; overlay specification is empty.  Otherwise, it is an
+	  ;; overlay specification and the default one is nil.
+	  (let ((action (org-element-property :beamer-act headline)))
+	    (cond
+	     ((not action) (list (cons "a" "") (cons "A" "")))
+	     ((string-match "\\`\\[.*\\]\\'" action)
+	      (list
+	       (cons "A"
+		     (org-e-beamer--normalize-argument action 'defaction))
+	       (cons "a" "")))
+	     (t
+	      (list
+	       (cons "a"
+		     (org-e-beamer--normalize-argument action 'action))
+	       (cons "A" "")))))
+	  (list (cons "o"
+		      (let ((options
+			     (org-element-property :beamer-opt headline)))
+			(if (not options) ""
+			  (org-e-beamer--normalize-argument options 'option))))
+		(cons "h" title)
+		(cons "H" (if (equal title "") "" (format "{%s}" title)))
+		(cons "U" (if (equal title "") "" (format "[%s]" title))))))
+	"\n"))
+     contents
+     ;; Block's closing string.
+     (when environment (concat (nth 3 env-format) "\n"))
+     (when column-width "\\end{column}\n")
+     (when end-columns-p "\\end{columns}"))))
+
+(defun org-e-beamer-headline (headline contents info)
+  "Transcode HEADLINE element into Beamer code.
+CONTENTS is the contents of the headline.  INFO is a plist used
+as a communication channel."
+  (unless (org-element-property :footnote-section-p headline)
+    (let ((level (org-export-get-relative-level headline info))
+	  (frame-level (org-e-beamer--frame-level headline info))
+	  (environment (let ((env (org-element-property :beamer-env headline)))
+			 (if (stringp env) (downcase env) "block"))))
+      (cond
+       ;; Creation of an appendix is requested.
+       ((equal environment "appendix")
+	(concat "\\appendix"
+		(org-element-property :beamer-act headline)
+		"\n"
+		(make-string (org-element-property :pre-blank headline) ?\n)
+		contents))
+       ((equal environment "ignoreheading")
+	(concat (make-string (org-element-property :pre-blank headline) ?\n)
+		contents))
+       ;; HEADLINE is a note.
+       ((member environment '("note" "noteNH"))
+	(format "\\note{%s}"
+		(concat (and (equal environment "note")
+			     (concat
+			      (org-export-data
+			       (org-element-property :title headline) info)
+			      "\n"))
+			(org-trim contents))))
+       ;; HEADLINE is a frame.
+       ((or (equal environment "frame") (= level frame-level))
+	(org-e-beamer--format-frame headline contents info))
+       ;; Regular section, extracted from `org-e-latex-classes'.
+       ((< level frame-level)
+	(org-e-beamer--format-section headline contents info))
+       ;; Otherwise, HEADLINE is a block.
+       (t (org-e-beamer--format-block headline contents info))))))
+
+
+;;;; Item
+
+(defun org-e-beamer-item (item contents info)
+  "Transcode an ITEM element into Beamer code.
+CONTENTS holds the contents of the item.  INFO is a plist holding
+contextual information."
+  (let ((action (let ((first-element (car (org-element-contents item))))
+		  (and (eq (org-element-type first-element) 'paragraph)
+		       (org-e-beamer--element-has-overlay-p first-element))))
+	(output (funcall (cdr (assq 'item org-e-latex-translate-alist))
+			 item contents info)))
+    (if (not action) output
+      ;; If the item starts with a paragraph and that paragraph starts
+      ;; with an export snippet specifying an overlay, insert it after
+      ;; \item command.
+      (replace-regexp-in-string "\\\\item" (concat "\\\\item" action) output))))
+
+
+;;;; Keyword
+
+(defun org-e-beamer-keyword (keyword contents info)
+  "Transcode a KEYWORD element into Beamer code.
+CONTENTS is nil.  INFO is a plist used as a communication
+channel."
+  (let ((key (org-element-property :key keyword))
+	(value (org-element-property :value keyword)))
+    ;; Handle specifically BEAMER and TOC (headlines only) keywords.
+    ;; Otherwise, fallback to `e-latex' back-end.
+    (cond
+     ((equal key "BEAMER") value)
+     ((and (equal key "TOC") (string-match "\\" value))
+      (let ((depth (or (and (string-match "[0-9]+" value)
+			    (string-to-number (match-string 0 value)))
+		       (plist-get info :with-toc)))
+	    (options (and (string-match "\\[.*?\\]" value)
+			  (match-string 0 value))))
+	(concat
+	 "\\begin{frame}"
+	 (when (wholenump depth) (format "\\setcounter{tocdepth}{%s}\n" depth))
+	 "\\tableofcontents" options "\n"
+	 "\\end{frame}")))
+     (t (funcall (cdr (assq 'keyword org-e-latex-translate-alist))
+		 keyword contents info)))))
+
+
+;;;; Link
+
+(defun org-e-beamer-link (link contents info)
+  "Transcode a LINK object into Beamer code.
+CONTENTS is the description part of the link.  INFO is a plist
+used as a communication channel."
+  (let ((type (org-element-property :type link))
+	(path (org-element-property :path link)))
+    ;; Use \hyperlink command for all internal links.
+    (cond
+     ((equal type "radio")
+      (let ((destination (org-export-resolve-radio-link link info)))
+	(when destination
+	  (format "\\hyperlink%s{%s}{%s}"
+		  (or (org-e-beamer--element-has-overlay-p link) "")
+		  (org-export-solidify-link-text path)
+		  (org-export-data (org-element-contents destination) info)))))
+     ((and (member type '("custom-id" "fuzzy" "id"))
+	   (let ((destination (if (string= type "fuzzy")
+				  (org-export-resolve-fuzzy-link link info)
+				(org-export-resolve-id-link link info))))
+	     (case (org-element-type destination)
+	       (headline
+		(let ((label
+		       (format "sec-%s"
+			       (mapconcat
+				'number-to-string
+				(org-export-get-headline-number
+				 destination info)
+				"-"))))
+		  (if (and (plist-get info :section-numbers) (not contents))
+		      (format "\\ref{%s}" label)
+		    (format "\\hyperlink%s{%s}{%s}"
+			    (or (org-e-beamer--element-has-overlay-p link) "")
+			    label
+			    contents))))
+	       (target
+		(let ((path (org-export-solidify-link-text path)))
+		  (if (not contents) (format "\\ref{%s}" path)
+		    (format "\\hyperlink%s{%s}{%s}"
+			    (or (org-e-beamer--element-has-overlay-p link) "")
+			    path
+			    contents))))))))
+     ;; Otherwise, use `e-latex' back-end.
+     (t (funcall (cdr (assq 'link org-e-latex-translate-alist))
+		 link contents info)))))
+
+
+;;;; Plain List
+;;
+;; Plain lists support `:overlay' (for any type), `:template' (for
+;; ordered lists only) and `:long-text' (for description lists only)
+;; attributes.
+
+(defun org-e-beamer-plain-list (plain-list contents info)
+  "Transcode a PLAIN-LIST element into Beamer code.
+CONTENTS is the contents of the list.  INFO is a plist holding
+contextual information."
+  (let* ((type (org-element-property :type plain-list))
+	 (attributes (org-export-read-attribute :attr_beamer plain-list))
+	 (latex-type (cond ((eq type 'ordered) "enumerate")
+			   ((eq type 'descriptive) "description")
+			   (t "itemize"))))
+    (org-e-latex--wrap-label
+     plain-list
+     (format "\\begin{%s}%s%s\n%s\\end{%s}"
+	     latex-type
+	     ;; Default overlay specification, if any.
+	     (let ((overlay (plist-get attributes :overlay)))
+	       (if (not overlay) ""
+		 (org-e-beamer--normalize-argument overlay 'defaction)))
+	     ;; Second optional argument depends on the list type.
+	     (case type
+	       (ordered
+		(let ((template (plist-get attributes :template)))
+		  (if (not template) ""
+		    (org-e-beamer--normalize-argument template 'option))))
+	       (descriptive
+		(let ((long-text (plist-get attributes :long-text)))
+		  (if (not long-text) ""
+		    (org-e-beamer--normalize-argument long-text 'option))))
+	       ;; There's no second argument for un-ordered lists.
+	       (otherwise ""))
+	     ;; Eventually insert contents and close environment.
+	     contents
+	     latex-type))))
+
+
+;;;; Radio Target
+
+(defun org-e-beamer-radio-target (radio-target text info)
+  "Transcode a RADIO-TARGET object into Beamer code.
+TEXT is the text of the target.  INFO is a plist holding
+contextual information."
+  (format "\\hypertarget%s{%s}{%s}"
+	  (or (org-e-beamer--element-has-overlay-p radio-target) "")
+	  (org-export-solidify-link-text
+	   (org-element-property :value radio-target))
+	  text))
+
+
+;;;; Target
+
+(defun org-e-beamer-target (target contents info)
+  "Transcode a TARGET object into Beamer code.
+CONTENTS is nil.  INFO is a plist holding contextual
+information."
+  (format "\\hypertarget{%s}{}"
+	  (org-export-solidify-link-text (org-element-property :value target))))
+
+
+;;;; Template
+;;
+;; Template used is similar to the one used in `e-latex' back-end,
+;; excepted for the table of contents and Beamer themes.
+
+(defun org-e-beamer-template (contents info)
+  "Return complete document string after Beamer conversion.
+CONTENTS is the transcoded contents string.  INFO is a plist
+holding export options."
+  (let ((title (org-export-data (plist-get info :title) info)))
+    (concat
+     ;; 1. Time-stamp.
+     (and (plist-get info :time-stamp-file)
+	  (format-time-string "%% Created %Y-%m-%d %a %H:%M\n"))
+     ;; 2. Document class and packages.
+     (let ((class (plist-get info :latex-class))
+	   (class-options (plist-get info :latex-class-options)))
+       (org-element-normalize-string
+	(let* ((header (nth 1 (assoc class org-e-latex-classes)))
+	       (document-class-string
+		(and (stringp header)
+		     (if class-options
+			 (replace-regexp-in-string
+			  "^[ \t]*\\\\documentclass\\(\\[.*?\\]\\)"
+			  class-options header t nil 1)
+		       header))))
+	  (when document-class-string
+	    (org-e-latex--guess-babel-language
+	     (org-e-latex--guess-inputenc
+	      (org-splice-latex-header
+	       document-class-string
+	       org-export-latex-default-packages-alist ; defined in org.el
+	       org-export-latex-packages-alist nil ; defined in org.el
+	       (plist-get info :latex-header-extra)))
+	     info)))))
+     ;; 3. Insert themes.
+     (let ((format-theme
+	    (function
+	     (lambda (prop command)
+	       (let ((theme (plist-get info prop)))
+		 (when theme
+		   (concat command
+			   (if (not (string-match "\\[.*\\]" theme))
+			       (format "{%s}\n" theme)
+			     (format "%s{%s}\n"
+				     (match-string 0 theme)
+				     (org-trim
+				      (replace-match "" nil nil theme)))))))))))
+       (mapconcat (lambda (args) (apply format-theme args))
+		  '((:beamer-theme "\\usetheme")
+		    (:beamer-color-theme "\\usecolortheme")
+		    (:beamer-font-theme "\\usefonttheme")
+		    (:beamer-inner-theme "\\useinnertheme")
+		    (:beamer-outer-theme "\\useoutertheme"))
+		  ""))
+     ;; 4. Possibly limit depth for headline numbering.
+     (let ((sec-num (plist-get info :section-numbers)))
+       (when (integerp sec-num)
+	 (format "\\setcounter{secnumdepth}{%d}\n" sec-num)))
+     ;; 5. Author.
+     (let ((author (and (plist-get info :with-author)
+			(let ((auth (plist-get info :author)))
+			  (and auth (org-export-data auth info)))))
+	   (email (and (plist-get info :with-email)
+		       (org-export-data (plist-get info :email) info))))
+       (cond ((and author email (not (string= "" email)))
+	      (format "\\author{%s\\thanks{%s}}\n" author email))
+	     (author (format "\\author{%s}\n" author))
+	     (t "\\author{}\n")))
+     ;; 6. Date.
+     (format "\\date{%s}\n" (org-export-data (plist-get info :date) info))
+     ;; 7. Title
+     (format "\\title{%s}\n" title)
+     ;; 8. Hyperref options.
+     (format "\\hypersetup{\n  pdfkeywords={%s},\n  pdfsubject={%s},\n  pdfcreator={%s}}\n"
+	     (or (plist-get info :keywords) "")
+	     (or (plist-get info :description) "")
+	     (if (not (plist-get info :with-creator)) ""
+	       (plist-get info :creator)))
+     ;; 9. Document start.
+     "\\begin{document}\n\n"
+     ;; 10. Title command.
+     (org-element-normalize-string
+      (cond ((string= "" title) nil)
+	    ((not (stringp org-e-latex-title-command)) nil)
+	    ((string-match "\\(?:[^%]\\|^\\)%s"
+			   org-e-latex-title-command)
+	     (format org-e-latex-title-command title))
+	    (t org-e-latex-title-command)))
+     ;; 11. Table of contents.
+     (let ((depth (plist-get info :with-toc)))
+       (when depth
+	 (concat
+	  (format "\\begin{frame}%s{%s}\n"
+		  (org-e-beamer--normalize-argument
+		   org-e-beamer-outline-frame-options 'option)
+		  org-e-beamer-outline-frame-title)
+	  (when (wholenump depth)
+	    (format "\\setcounter{tocdepth}{%d}\n" depth))
+	  "\\tableofcontents\n"
+	  "\\end{frame}\n\n")))
+     ;; 12. Document's body.
+     contents
+     ;; 13. Creator.
+     (let ((creator-info (plist-get info :with-creator)))
+       (cond
+	((not creator-info) "")
+	((eq creator-info 'comment)
+	 (format "%% %s\n" (plist-get info :creator)))
+	(t (concat (plist-get info :creator) "\n"))))
+     ;; 14. Document end.
+     "\\end{document}")))
+
+
+
+;;; Minor Mode
+
+
+(defvar org-e-beamer-mode-map (make-sparse-keymap)
+  "The keymap for `org-e-beamer-mode'.")
+(define-key org-e-beamer-mode-map "\C-c\C-b" 'org-e-beamer-select-environment)
+
+;;;###autoload
+(define-minor-mode org-e-beamer-mode
+  "Support for editing Beamer oriented Org mode files."
+  nil " Bm" 'org-e-beamer-mode-map)
+
+(when (fboundp 'font-lock-add-keywords)
+  (font-lock-add-keywords
+   'org-mode
+   '((":\\(B_[a-z]+\\|BMCOL\\):" 1 'org-e-beamer-tag prepend))
+   'prepend))
+
+(defface org-e-beamer-tag '((t (:box (:line-width 1 :color grey40))))
+  "The special face for beamer tags."
+  :group 'org-export-e-beamer)
+
+(defun org-e-beamer-property-changed (property value)
+  "Track the BEAMER_env property with tags.
+PROPERTY is the name of the modified property.  VALUE is its new
+value."
+  (cond
+   ((equal property "BEAMER_env")
+    (save-excursion
+      (org-back-to-heading t)
+      (let ((tags (org-get-tags)))
+	(setq tags (delq nil (mapcar (lambda (x)
+				       (if (string-match "^B_" x) nil x))
+				     tags)))
+	(org-set-tags-to tags))
+      (when (org-string-nw-p value) (org-toggle-tag (concat "B_" value) 'on))))
+   ((equal property "BEAMER_col")
+    (org-toggle-tag "BMCOL" (if (org-string-nw-p value) 'on 'off)))))
+
+(add-hook 'org-property-changed-functions 'org-e-beamer-property-changed)
+
+(defun org-e-beamer-allowed-property-values (property)
+  "Supply allowed values for PROPERTY."
+  (cond
+   ((and (equal property "BEAMER_env")
+	 (not (org-entry-get nil (concat property "_ALL") 'inherit)))
+    ;; If no allowed values for BEAMER_env have been defined,
+    ;; supply all defined environments
+    (mapcar 'car (append org-e-beamer-environments-special
+			 org-e-beamer-environments-extra
+			 org-e-beamer-environments-default)))
+   ((and (equal property "BEAMER_col")
+	 (not (org-entry-get nil (concat property "_ALL") 'inherit)))
+    ;; If no allowed values for BEAMER_col have been defined,
+    ;; supply some
+    (org-split-string org-e-beamer-column-widths " "))))
+
+(add-hook 'org-property-allowed-value-functions
+	  'org-e-beamer-allowed-property-values)
+
+
+
+;;; Commands
+
+;;;###autoload
+(defun org-e-beamer-export-as-latex
+  (&optional subtreep visible-only body-only ext-plist)
+  "Export current buffer as a Beamer buffer.
+
+If narrowing is active in the current buffer, only export its
+narrowed part.
+
+If a region is active, export that region.
+
+When optional argument SUBTREEP is non-nil, export the sub-tree
+at point, extracting information from the headline properties
+first.
+
+When optional argument VISIBLE-ONLY is non-nil, don't export
+contents of hidden elements.
+
+When optional argument BODY-ONLY is non-nil, only write code
+between \"\\begin{document}\" and \"\\end{document}\".
+
+EXT-PLIST, when provided, is a property list with external
+parameters overriding Org default settings, but still inferior to
+file-local settings.
+
+Export is done in a buffer named \"*Org E-BEAMER Export*\", which
+will be displayed when `org-export-show-temporary-export-buffer'
+is non-nil."
+  (interactive)
+  (let ((outbuf (org-export-to-buffer
+		 'e-beamer "*Org E-BEAMER Export*"
+		 subtreep visible-only body-only ext-plist)))
+    (with-current-buffer outbuf (LaTeX-mode))
+    (when org-export-show-temporary-export-buffer
+      (switch-to-buffer-other-window outbuf))))
+
+;;;###autoload
+(defun org-e-beamer-export-to-latex
+  (&optional subtreep visible-only body-only ext-plist pub-dir)
+  "Export current buffer as a Beamer presentation (tex).
+
+If narrowing is active in the current buffer, only export its
+narrowed part.
+
+If a region is active, export that region.
+
+When optional argument SUBTREEP is non-nil, export the sub-tree
+at point, extracting information from the headline properties
+first.
+
+When optional argument VISIBLE-ONLY is non-nil, don't export
+contents of hidden elements.
+
+When optional argument BODY-ONLY is non-nil, only write code
+between \"\\begin{document}\" and \"\\end{document}\".
+
+EXT-PLIST, when provided, is a property list with external
+parameters overriding Org default settings, but still inferior to
+file-local settings.
+
+When optional argument PUB-DIR is set, use it as the publishing
+directory.
+
+Return output file's name."
+  (interactive)
+  (let ((outfile (org-export-output-file-name ".tex" subtreep pub-dir)))
+    (org-export-to-file
+     'e-beamer outfile subtreep visible-only body-only ext-plist)))
+
+;;;###autoload
+(defun org-e-beamer-export-to-pdf
+  (&optional subtreep visible-only body-only ext-plist pub-dir)
+  "Export current buffer as a Beamer presentation (PDF).
+
+If narrowing is active in the current buffer, only export its
+narrowed part.
+
+If a region is active, export that region.
+
+When optional argument SUBTREEP is non-nil, export the sub-tree
+at point, extracting information from the headline properties
+first.
+
+When optional argument VISIBLE-ONLY is non-nil, don't export
+contents of hidden elements.
+
+When optional argument BODY-ONLY is non-nil, only write code
+between \"\\begin{document}\" and \"\\end{document}\".
+
+EXT-PLIST, when provided, is a property list with external
+parameters overriding Org default settings, but still inferior to
+file-local settings.
+
+When optional argument PUB-DIR is set, use it as the publishing
+directory.
+
+Return PDF file's name."
+  (interactive)
+  (org-e-latex-compile
+   (org-e-beamer-export-to-latex
+    subtreep visible-only body-only ext-plist pub-dir)))
+
+;;;###autoload
+(defun org-e-beamer-select-environment ()
+  "Select the environment to be used by beamer for this entry.
+While this uses (for convenience) a tag selection interface, the
+result of this command will be that the BEAMER_env *property* of
+the entry is set.
+
+In addition to this, the command will also set a tag as a visual
+aid, but the tag does not have any semantic meaning."
+  (interactive)
+  ;; Make sure `org-e-beamer-environments-special' has a higher
+  ;; priority than `org-e-beamer-environments-extra'.
+  (let* ((envs (append org-e-beamer-environments-special
+		       org-e-beamer-environments-extra
+		       org-e-beamer-environments-default))
+	 (org-tag-alist
+	  (append '((:startgroup))
+		  (mapcar (lambda (e) (cons (concat "B_" (car e))
+				       (string-to-char (nth 1 e))))
+			  envs)
+		  '((:endgroup))
+		  '(("BMCOL" . ?|))))
+	 (org-fast-tag-selection-single-key t))
+    (org-set-tags)
+    (let ((tags (or (ignore-errors (org-get-tags-string)) "")))
+      (cond
+       ((eq org-last-tag-selection-key ?|)
+	(if (string-match ":BMCOL:" tags)
+	    (org-set-property "BEAMER_col" (read-string "Column width: "))
+	  (org-delete-property "BEAMER_col")))
+       ((string-match (concat ":B_\\("
+			      (mapconcat 'car envs "\\|")
+			      "\\):")
+		      tags)
+	(org-entry-put nil "BEAMER_env" (match-string 1 tags)))
+       (t (org-entry-delete nil "BEAMER_env"))))))
+
+;;;###autoload
+(defun org-e-beamer-insert-options-template (&optional kind)
+  "Insert a settings template, to make sure users do this right."
+  (interactive (progn
+		 (message "Current [s]ubtree or [g]lobal?")
+		 (if (eq (read-char-exclusive) ?g) (list 'global)
+		   (list 'subtree))))
+  (if (eq kind 'subtree)
+      (progn
+	(org-back-to-heading t)
+	(org-reveal)
+	(org-entry-put nil "EXPORT_LaTeX_CLASS" "beamer")
+	(org-entry-put nil "EXPORT_LaTeX_CLASS_OPTIONS" "[presentation]")
+	(org-entry-put nil "EXPORT_FILE_NAME" "presentation.pdf")
+	(when org-e-beamer-column-view-format
+	  (org-entry-put nil "COLUMNS" org-e-beamer-column-view-format))
+	(org-entry-put nil "BEAMER_col_ALL" org-e-beamer-column-widths))
+    (insert "#+LaTeX_CLASS: beamer\n")
+    (insert "#+LaTeX_CLASS_OPTIONS: [presentation]\n")
+    (when org-e-beamer-theme
+      (insert "#+BEAMER_THEME: " org-e-beamer-theme "\n"))
+    (when org-e-beamer-column-view-format
+      (insert "#+COLUMNS: " org-e-beamer-column-view-format "\n"))
+    (insert "#+PROPERTY: BEAMER_col_ALL " org-e-beamer-column-widths "\n")))
+
+
+(provide 'org-e-beamer)
+;;; org-e-beamer.el ends here
diff --git a/contrib/lisp/org-e-groff.el b/contrib/lisp/org-e-groff.el
new file mode 100644
index 0000000..756a818
--- /dev/null
+++ b/contrib/lisp/org-e-groff.el
@@ -0,0 +1,2090 @@
+;; org-e-groff.el --- Groff Back-End For Org Export Engine
+
+;; Copyright (C) 2011-2012  Free Software Foundation, Inc.
+
+;; Author: Nicolas Goaziou 
+;; Author: Luis R Anaya 
+;; Keywords: outlines, hypermedia, calendar, wp
+;;
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program.  If not, see .
+;;; Commentary:
+;;
+;; This library implements a Groff Memorandum Macro  back-end for
+;; Org generic exporter.
+;;
+;; To test it, run
+;;
+;;   M-: (org-export-to-buffer 'e-groff "*Test e-Groff*") RET
+;;
+;; in an org-mode buffer then switch to the buffer to see the Groff
+;; export.  See contrib/lisp/org-export.el for more details on how
+;; this exporter works.
+;;
+;; It introduces two new buffer keywords: "GROFF_CLASS" and
+;; "GROFF_CLASS_OPTIONS".
+
+;;; Code:
+
+(eval-when-compile (require 'cl))
+
+(defvar org-export-groff-default-packages-alist)
+(defvar org-export-groff-packages-alist)
+
+(require 'org-export)
+
+
+;;; Define Back-End
+
+(defvar org-e-groff-translate-alist
+  '((babel-call . org-e-groff-babel-call)
+    (bold . org-e-groff-bold)
+    (center-block . org-e-groff-center-block)
+    (clock . org-e-groff-clock)
+    (code . org-e-groff-code)
+    (comment . org-e-groff-comment)
+    (comment-block . org-e-groff-comment-block)
+    (drawer . org-e-groff-drawer)
+    (dynamic-block . org-e-groff-dynamic-block)
+    (entity . org-e-groff-entity)
+    (example-block . org-e-groff-example-block)
+    (export-block . org-e-groff-export-block)
+    (export-snippet . org-e-groff-export-snippet)
+    (fixed-width . org-e-groff-fixed-width)
+    (footnote-definition . org-e-groff-footnote-definition)
+    (footnote-reference . org-e-groff-footnote-reference)
+    (headline . org-e-groff-headline)
+    (horizontal-rule . org-e-groff-horizontal-rule)
+    (inline-babel-call . org-e-groff-inline-babel-call)
+    (inline-src-block . org-e-groff-inline-src-block)
+    (inlinetask . org-e-groff-inlinetask)
+    (italic . org-e-groff-italic)
+    (item . org-e-groff-item)
+    (keyword . org-e-groff-keyword)
+    (groff-environment . org-e-groff-groff-environment)
+    (groff-fragment . org-e-groff-groff-fragment)
+    (line-break . org-e-groff-line-break)
+    (link . org-e-groff-link)
+    (macro . org-e-groff-macro)
+    (paragraph . org-e-groff-paragraph)
+    (plain-list . org-e-groff-plain-list)
+    (plain-text . org-e-groff-plain-text)
+    (planning . org-e-groff-planning)
+    (property-drawer . org-e-groff-property-drawer)
+    (quote-block . org-e-groff-quote-block)
+    (quote-section . org-e-groff-quote-section)
+    (radio-target . org-e-groff-radio-target)
+    (section . org-e-groff-section)
+    (special-block . org-e-groff-special-block)
+    (src-block . org-e-groff-src-block)
+    (statistics-cookie . org-e-groff-statistics-cookie)
+    (strike-through . org-e-groff-strike-through)
+    (subscript . org-e-groff-subscript)
+    (superscript . org-e-groff-superscript)
+    (table . org-e-groff-table)
+    (table-cell . org-e-groff-table-cell)
+    (table-row . org-e-groff-table-row)
+    (target . org-e-groff-target)
+    (template . org-e-groff-template)
+    (timestamp . org-e-groff-timestamp)
+    (underline . org-e-groff-underline)
+    (verbatim . org-e-groff-verbatim)
+    (verse-block . org-e-groff-verse-block))
+  "Alist between element or object types and translators.")
+
+(defconst org-e-groff-options-alist
+  '((:date "DATE" nil org-e-groff-date-format t)
+    (:groff-class "GROFF_CLASS" nil org-e-groff-default-class t)
+    (:groff-class-options "GROFF_CLASS_OPTIONS" nil nil t)
+    (:groff-header-extra "GROFF_HEADER" nil nil newline))
+"Alist between Groff export properties and ways to set them.
+See `org-export-options-alist' for more information on the
+structure of the values.")
+
+
+;;; User Configurable Variables
+
+(defgroup org-export-e-groff nil
+  "Options for exporting Org mode files to Groff."
+  :tag "Org Export Groff"
+  :group 'org-export)
+
+;;; Preamble
+
+(defcustom org-e-groff-default-class "internal"
+  "The default Groff class."
+  :group 'org-export-e-groff
+  :type '(string :tag "Groff class"))
+
+(defcustom org-e-groff-classes
+  '(("file" ".MT 1"
+     (:heading 'default :type "memo" :last-section "toc"))
+    ("internal" ".MT 0"
+     (:heading 'default :type "memo" :last-section "toc"))
+    ("programmer" ".MT 2"
+     (:heading 'default :type "memo" :last-section "toc"))
+    ("engineer" ".MT 3"
+     (:heading 'default :type "memo" :last-section "toc"))
+    ("external" ".MT 4"
+     (:heading 'default :type "memo" :last-section "toc"))
+    ("letter" ".MT 5"
+     (:heading 'default :type "memo" :last-section "sign"))
+    ("custom" ".so file"
+     (:heading custom-function :type "custom" :last-section "toc"))
+    ("dummy" ""
+     (:heading 'default :type "memo"))
+    ("ms" "ms"
+     (:heading 'default :type "cover" :last-section "toc"))
+    ("se_ms" "se_ms"
+     (:heading 'default :type "cover" :last-section "toc"))
+    ("block" "BL"
+     (:heading 'default :type "letter" :last-section "sign"))
+    ("semiblock" "SB"
+     (:heading 'default :type "letter" :last-section "sign"))
+    ("fullblock" "FB"
+     (:heading 'default :type "letter" :last-section "sign"))
+    ("simplified" "SP"
+     (:heading 'default :type "letter" :last-section "sign"))
+    ("none" "" (:heading 'default :type "custom")))
+
+  ;; none means, no Cover or Memorandum Type and no calls to AU, AT, ND and TL
+  ;; This is to facilitate the creation of custom pages.
+
+  ;; dummy means, no Cover or Memorandum Type but calls to AU, AT, ND and TL
+  ;; are made. This is to facilitate Abstract Insertion.
+
+  "This list describes the attributes for the documents being created.
+   It allows for the creation of new "
+  :group 'org-export-e-groff
+  :type '(repeat
+          (list (string :tag "Document Type")
+                (string :tag "Header")
+                (repeat :tag "Options" :inline t
+                        (choice
+                         (list :tag "Heading")
+                         (function :tag "Hook computing sectioning"))))))
+
+
+(defcustom org-e-groff-date-format
+  (format-time-string "%Y-%m-%d")
+  "Format string for .ND "
+  :group 'org-export-e-groff
+  :type 'boolean)
+
+;;; Headline
+
+(defconst org-e-groff-special-tags
+  '("FROM" "TO" "ABSTRACT" "APPENDIX" "BODY" "NS"))
+
+(defcustom org-e-groff-format-headline-function nil
+  "Function to format headline text.
+
+This function will be called with 5 arguments:
+TODO      the todo keyword (string or nil).
+TODO-TYPE the type of todo (symbol: `todo', `done', nil)
+PRIORITY  the priority of the headline (integer or nil)
+TEXT      the main headline text (string).
+TAGS      the tags as a list of strings (list of strings or nil).
+
+The function result will be used in the section format string.
+
+As an example, one could set the variable to the following, in
+order to reproduce the default set-up:
+
+\(defun org-e-groff-format-headline (todo todo-type priority text tags)
+  \"Default format function for an headline.\"
+  \(concat (when todo
+            \(format \"\\fB%s\\fP \" todo))
+	  \(when priority
+            \(format \"[\\#%c] \" priority))
+	  text
+	  \(when tags
+            \(format \" %s \"
+              \(mapconcat 'identity tags \":\"))))"
+  :group 'org-export-e-groff
+  :type 'function)
+
+;;; Timestamps
+
+(defcustom org-e-groff-active-timestamp-format "\\fI%s\\fP"
+  "A printf format string to be applied to active timestamps."
+  :group 'org-export-e-groff
+  :type 'string)
+
+(defcustom org-e-groff-inactive-timestamp-format "\\fI%s\\fP"
+  "A printf format string to be applied to inactive timestamps."
+  :group 'org-export-e-groff
+  :type 'string)
+
+(defcustom org-e-groff-diary-timestamp-format "\\fI%s\\fP"
+  "A printf format string to be applied to diary timestamps."
+  :group 'org-export-e-groff
+  :type 'string)
+
+;;; Links
+
+(defcustom org-e-groff-inline-image-rules
+  '(("file" . "\\.\\(pdf\\|ps\\|eps\\|pic\\)\\'")
+    ("fuzzy" . "\\.\\(pdf\\|ps\\|eps\\|pic\\)\\'"))
+  "Rules characterizing image files that can be inlined into Groff.
+
+A rule consists in an association whose key is the type of link
+to consider, and value is a regexp that will be matched against
+link's path.
+
+Note that, by default, the image extensions actually allowed
+depend on the way the Groff file is processed.  When used with
+pdfgroff, pdf, jpg and png images are OK.  When processing
+through dvi to Postscript, only ps and eps are allowed.  The
+default we use here encompasses both."
+  :group 'org-export-e-groff
+  :type '(alist :key-type (string :tag "Type")
+                :value-type (regexp :tag "Path")))
+
+(defcustom org-e-groff-link-with-unknown-path-format "\\fI%s\\fP"
+  "Format string for links with unknown path type."
+  :group 'org-export-groff
+  :type 'string)
+
+;;; Tables
+
+(defcustom org-e-groff-tables-centered t
+  "When non-nil, tables are exported in a center environment."
+  :group 'org-export-e-groff
+  :type 'boolean)
+
+(defcustom org-e-groff-tables-verbatim nil
+  "When non-nil, tables are exported verbatim."
+  :group 'org-export-e-groff
+  :type 'boolean)
+
+(defcustom org-e-groff-table-scientific-notation "%sE%s"
+  "Format string to display numbers in scientific notation.
+The format should have \"%s\" twice, for mantissa and exponent
+\(i.e. \"%s\\\\times10^{%s}\").
+
+When nil, no transformation is made."
+  :group 'org-export-e-groff
+  :type '(choice
+          (string :tag "Format string")
+          (const :tag "No formatting")))
+
+;;; Text markup
+
+(defcustom org-e-groff-text-markup-alist 
+   '((bold . "\\fB%s\\fP")
+    (code . "\\fC%s\\fP")
+    (italic . "\\fI%s\\fP")
+    (strike-through . "\\fC%s\\fP")  ; Strike through and underline
+    (underline . "\\fI%s\\fP")       ; need to be revised.
+    (verbatim .   "protectedtexttt"))
+  "Alist of Groff expressions to convert text markup.
+
+The key must be a symbol among `bold', `code', `italic',
+`strike-through', `underline' and `verbatim'.  The value is
+a formatting string to wrap fontified text with it.
+
+If no association can be found for a given markup, text will be
+returned as-is."
+  :group 'org-export-e-groff
+  :type 'alist
+  :options '(bold code italic strike-through underline verbatim))
+
+;;; Drawers
+
+(defcustom org-e-groff-format-drawer-function nil
+  "Function called to format a drawer in Groff code.
+
+The function must accept two parameters:
+  NAME      the drawer name, like \"LOGBOOK\"
+  CONTENTS  the contents of the drawer.
+
+The function should return the string to be exported.
+
+For example, the variable could be set to the following function
+in order to mimic default behaviour:
+
+\(defun org-e-groff-format-drawer-default \(name contents\)
+  \"Format a drawer element for Groff export.\"
+  contents\)"
+  :group 'org-export-e-groff
+  :type 'function)
+
+;;; Inlinetasks
+
+(defcustom org-e-groff-format-inlinetask-function nil
+  "Function called to format an inlinetask in Groff code.
+
+The function must accept six parameters:
+  TODO      the todo keyword, as a string
+  TODO-TYPE the todo type, a symbol among `todo', `done' and nil.
+  PRIORITY  the inlinetask priority, as a string
+  NAME      the inlinetask name, as a string.
+  TAGS      the inlinetask tags, as a list of strings.
+  CONTENTS  the contents of the inlinetask, as a string.
+
+The function should return the string to be exported.
+
+For example, the variable could be set to the following function
+in order to mimic default behaviour:
+
+\(defun org-e-groff-format-inlinetask \(todo type priority name tags contents\)
+\"Format an inline task element for Groff export.\"
+  \(let ((full-title
+	 \(concat
+	  \(when todo
+            \(format \"\\fB%s\\fP \" todo))
+	  \(when priority (format \"[\\#%c] \" priority))
+	  title
+	  \(when tags
+            \(format \":%s:\"
+                    \(mapconcat 'identity tags \":\")))))
+    \(format (concat \".DS L\\n\"
+		    \"%s\\n\\n\"
+		    \"%s\"
+		    \".DE\")
+	    full-title contents))"
+  :group 'org-export-e-groff
+  :type 'function)
+
+;; Src blocks
+
+(defcustom org-e-groff-source-highlight nil
+  "Use GNU source highlight to embellish source blocks "
+  :group 'org-export-e-groff
+  :type 'boolean)
+
+(defcustom org-e-groff-source-highlight-langs
+  '((emacs-lisp "lisp") (lisp "lisp") (clojure "lisp")
+    (scheme "scheme")
+    (c "c") (cc "cpp") (csharp "csharp") (d "d")
+    (fortran "fortran") (cobol "cobol") (pascal "pascal")
+    (ada "ada") (asm "asm")
+    (perl "perl") (cperl "perl")
+    (python "python") (ruby "ruby") (tcl "tcl") (lua "lua")
+    (java "java") (javascript "javascript")
+    (tex "latex")
+    (shell-script "sh") (awk "awk") (diff "diff") (m4 "m4")
+    (ocaml "caml") (caml "caml")
+    (sql "sql") (sqlite "sql")
+    (html "html") (css "css") (xml "xml")
+    (bat "bat") (bison "bison") (clipper "clipper")
+    (ldap "ldap") (opa "opa")
+    (php "php") (postscript "postscript") (prolog "prolog")
+    (properties "properties") (makefile "makefile")
+    (tml "tml") (vala "vala") (vbscript "vbscript") (xorg "xorg"))
+  "Alist mapping languages to their listing language counterpart.
+The key is a symbol, the major mode symbol without the \"-mode\".
+The value is the string that should be inserted as the language
+parameter for the listings package.  If the mode name and the
+listings name are the same, the language does not need an entry
+in this list - but it does not hurt if it is present."
+  :group 'org-export-e-groff
+  :type '(repeat
+          (list
+           (symbol :tag "Major mode       ")
+           (string :tag "Listings language"))))
+
+(defcustom org-e-groff-source-highlight-options nil
+  "Association list of options for the groff listings package.
+
+These options are supplied as a comma-separated list to the
+\\lstset command.  Each element of the association list should be
+a list containing two strings: the name of the option, and the
+value.  For example,
+
+  (setq org-e-groff-source-highlight-options
+    '((\"basicstyle\" \"\\small\")
+      (\"keywordstyle\" \"\\color{black}\\bfseries\\underbar\")))
+
+will typeset the code in a small size font with underlined, bold
+black keywords.
+
+Note that the same options will be applied to blocks of all
+languages."
+  :group 'org-export-e-groff
+  :type '(repeat
+          (list
+           (string :tag "Listings option name ")
+           (string :tag "Listings option value"))))
+
+(defvar org-e-groff-custom-lang-environments nil
+  "Alist mapping languages to language-specific Groff environments.
+
+It is used during export of src blocks by the listings and
+groff packages.  For example,
+
+  \(setq org-e-groff-custom-lang-environments
+     '\(\(python \"pythoncode\"\)\)\)
+
+would have the effect that if org encounters begin_src python
+during groff export it will use pythoncode as the source-highlight
+language.")
+
+;;; Plain text
+
+(defcustom org-e-groff-quotes
+  '(("fr"
+     ("\\(\\s-\\|[[(]\\|^\\)\"" . "«~")
+     ("\\(\\S-\\)\"" . "~»")
+     ("\\(\\s-\\|(\\|^\\)'" . "'"))
+    ("en"
+     ("\\(\\s-\\|[[(]\\|^\\)\"" . "``")
+     ("\\(\\S-\\)\"" . "''")
+     ("\\(\\s-\\|(\\|^\\)'" . "`")))
+  "Alist for quotes to use when converting english double-quotes.
+
+The CAR of each item in this alist is the language code.
+The CDR of each item in this alist is a list of three CONS:
+- the first CONS defines the opening quote;
+- the second CONS defines the closing quote;
+- the last CONS defines single quotes.
+
+For each item in a CONS, the first string is a regexp
+for allowed characters before/after the quote, the second
+string defines the replacement string for this quote."
+  :group 'org-export-e-groff
+  :type '(list
+          (cons :tag "Opening quote"
+                (string :tag "Regexp for char before")
+                (string :tag "Replacement quote     "))
+          (cons :tag "Closing quote"
+                (string :tag "Regexp for char after ")
+                (string :tag "Replacement quote     "))
+          (cons :tag "Single quote"
+                (string :tag "Regexp for char before")
+                (string :tag "Replacement quote     "))))
+
+(defcustom org-e-groff-special-char
+  '(("(c)" . "\\\\(co")
+    ("(tm)" . "\\\\(tm")
+    ("(rg)" . "\\\\(rg"))
+  "CONS list in which the value of the car
+  is replace on the value of the CDR. "
+  :group 'org-export-e-groff
+  :type '(list
+          (cons :tag "Character Subtitute"
+                (string :tag "Original Character Group")
+                (string :tag "Replacement Character"))))
+
+;;; Compilation
+
+(defcustom org-e-groff-pdf-process
+  '("pic %f | tbl | eqn | groff -mm | ps2pdf - > %b.pdf"
+    "pic %f | tbl | eqn | groff -mm | ps2pdf - > %b.pdf"
+    "pic %f | tbl | eqn | groff -mm | ps2pdf - > %b.pdf")
+
+  "Commands to process a Groff file to a PDF file.
+This is a list of strings, each of them will be given to the
+shell as a command.  %f in the command will be replaced by the
+full file name, %b by the file base name \(i.e. without
+extension) and %o by the base directory of the file."
+  :group 'org-export-pdf
+  :type '(choice
+          (repeat :tag "Shell command sequence"
+                  (string :tag "Shell command"))
+          (const :tag "2 runs of pdfgroff"
+                 ("pic %f | tbl | eqn | groff -mm | ps2pdf - > %b.pdf"
+                  "pic %f | tbl | eqn | groff -mm | ps2pdf - > %b.pdf"))
+          (const :tag "3 runs of pdfgroff"
+                 ("pic %f | tbl | eqn | groff -mm | ps2pdf - > %b.pdf"
+                  "pic %f | tbl | eqn | groff -mm | ps2pdf - > %b.pdf"
+                  "pic %f | tbl | eqn | groff -mm | ps2pdf - > %b.pdf"))
+          (function)))
+
+(defcustom org-e-groff-logfiles-extensions
+  '("aux" "idx" "log" "out" "toc" "nav" "snm" "vrb")
+  "The list of file extensions to consider as Groff logfiles."
+  :group 'org-export-e-groff
+  :type '(repeat (string :tag "Extension")))
+
+(defcustom org-e-groff-remove-logfiles t
+  "Non-nil means remove the logfiles produced by PDF production.
+These are the .aux, .log, .out, and .toc files."
+  :group 'org-export-e-groff
+  :type 'boolean)
+
+(defcustom org-e-groff-organization "Org User"
+  "Name of the organization used to populate the .AF command."
+  :group 'org-export-e-groff
+  :type 'string)
+
+
+;; Adding GROFF as a block parser to make sure that its contents
+;; does not execute
+
+(add-to-list 'org-element-block-name-alist
+             '("GROFF" . org-element-export-block-parser))
+
+(defvar org-e-groff-registered-references nil)
+(defvar org-e-groff-special-content nil)
+
+
+
+;;; Internal Functions
+
+(defun org-e-groff--caption/label-string (caption label info)
+  "Return caption and label Groff string for floats.
+
+CAPTION is a cons cell of secondary strings, the car being the
+standard caption and the cdr its short form.  LABEL is a string
+representing the label.  INFO is a plist holding contextual
+information.
+
+If there's no caption nor label, return the empty string.
+
+For non-floats, see `org-e-groff--wrap-label'."
+  (let ((label-str ""))
+    (cond
+     ((and (not caption) (not label)) "")
+     ((not caption) (format "\\fI%s\\fP" label))
+     ;; Option caption format with short name.
+     ((cdr caption)
+      (format "%s\n.br\n%s - %s\n"
+              (org-export-data (cdr caption) info)
+              label-str
+              (org-export-data (car caption) info)))
+     ;; Standard caption format.
+     (t (format "\\fR%s\\fP"
+                (org-export-data (car caption) info))))))
+
+(defun org-e-groff--quotation-marks (text info)
+  "Export quotation marks depending on language conventions.
+TEXT is a string containing quotation marks to be replaced.  INFO
+is a plist used as a communication channel."
+  (mapc (lambda(l)
+          (let ((start 0))
+            (while (setq start (string-match (car l) text start))
+              (let ((new-quote (concat (match-string 1 text) (cdr l))))
+                (setq text (replace-match new-quote  t t text))))))
+        (cdr (or (assoc (plist-get info :language) org-e-groff-quotes)
+                 ;; Falls back on English.
+                 (assoc "en" org-e-groff-quotes))))
+  text)
+
+(defun org-e-groff--wrap-label (element output)
+  "Wrap label associated to ELEMENT around OUTPUT, if appropriate.
+This function shouldn't be used for floats.  See
+`org-e-groff--caption/label-string'."
+  (let ((label (org-element-property :name element)))
+    (if (or (not output) (not label) (string= output "") (string= label ""))
+        output
+      (concat (format "%s\n.br\n" label) output))))
+
+(defun org-e-groff--text-markup (text markup)
+  "Format TEXT depending on MARKUP text markup.
+See `org-e-groff-text-markup-alist' for details."
+  (let ((fmt (cdr (assq markup org-e-groff-text-markup-alist))))
+    (cond
+     ;; No format string: Return raw text.
+     ((not fmt) text)
+     ((string= "protectedtexttt" fmt)
+      (let ((start 0)
+            (trans '(("\\" . "\\")))
+            (rtn "")
+            char)
+        (while (string-match "[\\{}$%&_#~^]" text)
+          (setq char (match-string 0 text))
+          (if (> (match-beginning 0) 0)
+              (setq rtn (concat rtn (substring text 0 (match-beginning 0)))))
+          (setq text (substring text (1+ (match-beginning 0))))
+          (setq char (or (cdr (assoc char trans)) (concat "\\" char))
+                rtn (concat rtn char)))
+        (setq text (concat rtn text))
+        (format "\\fC%s\\fP" text)))
+     ;; Else use format string.
+     (t (format fmt text)))))
+
+
+(defun org-e-groff--get-tagged-content  (tag info)
+  (cdr  (assoc tag org-e-groff-special-content)))
+
+(defun org-e-groff--mt-head (title contents attr info)
+  (concat
+
+   ;; 1. Insert Organization
+   (let ((firm-option (plist-get attr :firm)))
+     (cond
+      ((stringp firm-option)
+       (format ".AF \"%s\" \n" firm-option))
+      (t (format ".AF \"%s\" \n" (or org-e-groff-organization "")))))
+
+   ;; 2. Title
+   (let ((subtitle1 (plist-get attr :subtitle1))
+         (subtitle2 (plist-get attr :subtitle2)))
+
+     (cond
+      ((string= "" title)
+       (format ".TL \"%s\" \"%s\" \n%s\n"
+               (or subtitle1 "")
+               (or subtitle2 "") " "))
+
+      ((not (or subtitle1 subtitle2))
+       (format ".TL\n%s\n"
+               (or title "")))
+      (t
+       (format ".TL \"%s\" \"%s \" \n%s\n"
+               (or subtitle1 "")
+               (or subtitle2 "") title))))
+
+   ;; 3. Author.
+   ;; In Groff, .AU *MUST* be placed after .TL
+   ;; If From, populate with data from From else
+   ;;
+   (let ((author (and (plist-get info :with-author)
+                      (let ((auth (plist-get info :author)))
+                        (and auth (org-export-data auth info)))))
+         (email (and (plist-get info :with-email)
+                     (org-export-data (plist-get info :email) info)))
+         (from-data  (org-e-groff--get-tagged-content "FROM" info))
+
+         (to-data  (org-e-groff--get-tagged-content "TO" info)))
+
+     (cond
+      ((and author from-data)
+       (let ((au-line
+              (mapconcat
+               (lambda (from-line)
+                 (format " \"%s\" " from-line))
+               (split-string
+                (setq from-data
+                      (replace-regexp-in-string "\\.P\n" "" from-data)) "\n") "")))
+
+         (concat
+          (format ".AU \"%s\" " author) au-line "\n")))
+
+      ((and author email (not (string= "" email)))
+       (format ".AU \"%s\" \"%s\"\n" author email))
+
+      (author (format ".AU \"%s\"\n" author))
+
+      (t ".AU \"\" \n")))
+
+
+   ;; 4. Author Title, if present
+   (let ((at-item (plist-get attr :author-title)))
+     (if (and at-item (stringp at-item))
+         (format ".AT \"%s\" \n" at-item)
+       ""))
+
+   ;; 5. Date.
+   (let ((date (org-export-data (plist-get info :date) info)))
+     (and date (format ".ND \"%s\"\n" date)))
+
+   ;;
+   ;; If Abstract, then Populate Abstract
+   ;;
+
+   (let ((abstract-data (org-e-groff--get-tagged-content "ABSTRACT" info))
+         (to-data (org-e-groff--get-tagged-content "TO" info)))
+     (cond
+      (abstract-data
+       (format ".AS\n%s\n.AE\n" abstract-data))
+      (to-data
+       (format ".AS\n%s\n.AE\n" to-data))))))
+
+(defun org-e-groff--letter-head (title contents attr info)
+  (let ((author (and (plist-get info :with-author)
+                     (let ((auth (plist-get info :author)))
+                       (and auth (org-export-data auth info)))))
+        (email (and (plist-get info :with-email)
+                    (org-export-data (plist-get info :email) info)))
+        (from-data  (org-e-groff--get-tagged-content "FROM" info))
+        (at-item (plist-get attr :author-title))
+        (to-data  (org-e-groff--get-tagged-content "TO" info)))
+
+
+    ;; If FROM then get data from FROM
+    (setq from-data
+          (replace-regexp-in-string "\\.P\n" "" from-data))
+
+    (setq to-data
+          (replace-regexp-in-string "\\.P\n" "" to-data))
+
+    (concat
+     (cond
+      (from-data
+       (format ".WA \"%s\" \"%s\" \n%s\n.WE\n" author (or at-item "") from-data))
+      ((and author email (not (string= "" email)))
+       (format ".WA \"%s\"\n \"%s\"\n.WE\n" author email))
+      (author (format ".WA \"%s\"\n.WE\n" author))
+      (t ".WA \"\" \n.WE\n"))
+
+     ;; If TO then get data from TO
+
+     (when to-data
+       (format ".IA \n%s\n.IE\n" to-data)))))
+
+
+;;; Template
+
+(defun org-e-groff-template (contents info)
+  "Return complete document string after Groff conversion.
+CONTENTS is the transcoded contents string.  INFO is a plist
+holding export options."
+  (let* ((title (org-export-data (plist-get info :title) info))
+         (attr (read
+                (format "(%s)"
+                        (mapconcat
+                         #'identity
+                         (list (plist-get info :groff-class-options))
+                         " "))))
+         (class (plist-get info :groff-class))
+         (class-options (plist-get info :groff-class-options))
+         (classes (assoc class org-e-groff-classes))
+         (classes-options (car (last classes)))
+         (heading-option (plist-get classes-options :heading))
+         (type-option (plist-get classes-options :type))
+         (last-option (plist-get classes-options :last-section))
+         (hyphenate (plist-get attr :hyphenate))
+         (justify-right (plist-get attr :justify-right))
+
+         (document-class-string
+          (progn
+            (org-element-normalize-string
+             (let* ((header (nth 1 (assoc class org-e-groff-classes)))
+                    (document-class-item (if (stringp header) header "")))
+               document-class-item)))))
+
+
+    (concat
+     (if justify-right
+         (case justify-right
+           ('yes ".SA 1 \n")
+           ('no ".SA 0 \n")
+           (t ""))
+       "")
+
+     (if hyphenate
+         (case hyphenate
+           ('yes ".nr Hy 1 \n")
+           ('no ".nr Hy 0 \n")
+           (t ""))
+       "")
+
+     (cond
+      ((string= type-option "custom") "")
+
+      ((and (stringp document-class-string)
+            (string= type-option "cover"))
+
+       (concat
+        (format ".COVER %s\n" document-class-string)
+        (org-e-groff--mt-head title contents attr info)
+        ".COVEND\n"))
+
+      ((string= type-option "memo")
+       (concat
+        (org-e-groff--mt-head title contents attr info)
+        document-class-string))
+      ((string= type-option "letter")
+       (concat
+        (org-e-groff--letter-head title contents attr info)
+        (let ((sa-item (plist-get attr :salutation))
+              (cn-item (plist-get attr :confidential))
+              (sj-item (plist-get attr :subject))
+              (rn-item (plist-get attr :reference))
+              (at-item (plist-get attr :attention)))
+
+          (concat
+
+           (if (stringp sa-item)
+               (format ".LO SA \"%s\" \n"  sa-item)
+             ".LO SA\n")
+
+           (when cn-item
+             (if (stringp cn-item)
+                 (format ".LO CN \"%s\"\n" cn-item)
+               ".LO CN\n"))
+
+           (when (and at-item (stringp at-item))
+             (format ".LO AT \"%s\" \n"  at-item))
+           (when (and title rn-item)
+             (format ".LO RN \"%s\"\n" title))
+
+           (when (and sj-item (stringp sj-item))
+             (format ".LO SJ \"%s\" \n"  sj-item))
+
+
+           ".LT " document-class-string  "\n"))))
+
+      (t ""))
+
+     contents
+
+     (cond
+      ((string= last-option "toc")
+       ".TC")
+      ((string= last-option "sign")
+       (let ((fc-item (plist-get attr :closing)))
+         (concat (if (stringp fc-item)
+                     (format ".FC \"%s\" \n" fc-item)
+                   ".FC\n")
+                 ".SG\n")))
+      (t ""))
+
+     (progn
+       (mapconcat
+        (lambda (item)
+          (when (string= (car item) "NS")
+            (replace-regexp-in-string
+                    "\\.P\n" "" (cdr item))))
+        (reverse org-e-groff-special-content) "\n")))))
+
+
+
+;;; Transcode Functions
+
+;;; Babel Call
+;;
+;; Babel Calls are ignored.
+
+
+;;; Bold
+
+(defun org-e-groff-bold (bold contents info)
+  "Transcode BOLD from Org to Groff.
+CONTENTS is the text with bold markup.  INFO is a plist holding
+contextual information."
+  (org-e-groff--text-markup contents 'bold))
+
+;;; Center Block
+
+(defun org-e-groff-center-block (center-block contents info)
+  "Transcode a CENTER-BLOCK element from Org to Groff.
+CONTENTS holds the contents of the center block.  INFO is a plist
+holding contextual information."
+  (org-e-groff--wrap-label
+   center-block
+   (format ".DS C \n%s\n.DE" contents)))
+
+;;; Clock
+
+(defun org-e-groff-clock (clock contents info)
+  "Transcode a CLOCK element from Org to Groff.
+CONTENTS is nil.  INFO is a plist holding contextual
+information."
+  (concat
+   (format "\\fB%s\\fP " org-clock-string)
+   (format org-e-groff-inactive-timestamp-format
+           (concat (org-translate-time (org-element-property :value clock))
+                   (let ((time (org-element-property :time clock)))
+                     (and time (format " (%s)" time)))))))
+
+;;; Code
+
+(defun org-e-groff-code (code contents info)
+  "Transcode a CODE object from Org to Groff.
+CONTENTS is nil.  INFO is a plist used as a communication
+channel."
+  (org-e-groff--text-markup (org-element-property :value code) 'code))
+
+;;; Comments and Comment Blocks are ignored.
+
+;;; Drawer
+
+(defun org-e-groff-drawer (drawer contents info)
+  "Transcode a DRAWER element from Org to Groff.
+CONTENTS holds the contents of the block.  INFO is a plist
+holding contextual information."
+  (let* ((name (org-element-property :drawer-name drawer))
+         (output (if (functionp org-e-groff-format-drawer-function)
+                     (funcall org-e-groff-format-drawer-function
+                              name contents)
+                   ;; If there's no user defined function: simply
+                   ;; display contents of the drawer.
+                   contents)))
+    (org-e-groff--wrap-label drawer output)))
+
+;;; Dynamic Block
+
+(defun org-e-groff-dynamic-block (dynamic-block contents info)
+  "Transcode a DYNAMIC-BLOCK element from Org to Groff.
+CONTENTS holds the contents of the block.  INFO is a plist
+holding contextual information.  See `org-export-data'."
+  (org-e-groff--wrap-label dynamic-block contents))
+
+;;; Entity
+
+(defun org-e-groff-entity (entity contents info)
+  "Transcode an ENTITY object from Org to Groff.
+CONTENTS are the definition itself.  INFO is a plist holding
+contextual information."
+  (let ((ent (org-element-property :utf8 entity))) ent))
+
+;;; Example Block
+
+(defun org-e-groff-example-block (example-block contents info)
+  "Transcode an EXAMPLE-BLOCK element from Org to Groff.
+CONTENTS is nil.  INFO is a plist holding contextual
+information."
+  (org-e-groff--wrap-label
+   example-block
+   (format ".DS L\n%s\n.DE"
+           (org-export-format-code-default example-block info))))
+
+;;; Export Block
+
+(defun org-e-groff-export-block (export-block contents info)
+  "Transcode a EXPORT-BLOCK element from Org to Groff.
+CONTENTS is nil.  INFO is a plist holding contextual information."
+  (when (string= (org-element-property :type export-block) "GROFF")
+    (org-remove-indentation (org-element-property :value export-block))))
+
+;;; Export Snippet
+
+(defun org-e-groff-export-snippet (export-snippet contents info)
+  "Transcode a EXPORT-SNIPPET object from Org to Groff.
+CONTENTS is nil.  INFO is a plist holding contextual information."
+  (when (eq (org-export-snippet-backend export-snippet) 'e-groff)
+    (org-element-property :value export-snippet)))
+
+;;; Fixed Width
+
+(defun org-e-groff-fixed-width (fixed-width contents info)
+  "Transcode a FIXED-WIDTH element from Org to Groff.
+CONTENTS is nil.  INFO is a plist holding contextual information."
+  (org-e-groff--wrap-label
+   fixed-width
+   (format "\\fC\n%s\\fP"
+           (org-remove-indentation
+            (org-element-property :value fixed-width)))))
+
+;;; Footnote Definition
+;;
+;; Footnote Definitions are ignored.
+;;
+;; Footnotes are handled automatically in GROFF.  Although manual
+;; references can be added, not really required.
+
+(defun org-e-groff-footnote-reference (footnote-reference contents info)
+  ;; Changing from info to footnote-reference
+  (let* ((raw (org-export-get-footnote-definition footnote-reference info))
+		 (n (org-export-get-footnote-number footnote-reference info))
+		 (data (org-trim (org-export-data raw info)))
+         (ref-id (plist-get (nth 1 footnote-reference) :label)))
+    ;; It is a reference
+    (if (string-match "fn:rl" ref-id)
+        (if (member ref-id org-e-groff-registered-references)
+            (format "\\*[%s]" ref-id)
+          (progn
+            (push ref-id org-e-groff-registered-references)
+            (format "\\*(Rf\n.RS \"%s\" \n%s\n.RF\n" ref-id  data)))
+      ;; else it is a footnote
+      (format "\\u\\s-2%s\\d\\s+2\n.FS %s\n%s\n.FE\n" n n data))))
+
+;;; Headline
+
+(defun org-e-groff-headline (headline contents info)
+  "Transcode an HEADLINE element from Org to Groff.
+CONTENTS holds the contents of the headline.  INFO is a plist
+holding contextual information."
+  (let* ((class (plist-get info :groff-class))
+         (level (org-export-get-relative-level headline info))
+         (numberedp (org-export-numbered-headline-p headline info))
+         ;; Section formatting will set two placeholders: one for the
+         ;; title and the other for the contents.
+         (classes (assoc class org-e-groff-classes))
+         (classes-options (car (last classes)))
+         (heading-option (plist-get classes-options :heading))
+         (section-fmt
+          (progn
+            (cond
+             ((and (symbolp heading-option)
+                   (fboundp heading-option))
+              (funcall heading-option level numberedp))
+             ((> level 7) nil)
+             (t (if numberedp
+                    (concat ".H " (number-to-string level) " \"%s\"\n%s")
+                  ".HU \"%s\"\n%s")))))
+         ;; End of section-fmt
+         (text (org-export-data (org-element-property :title headline) info))
+         (todo
+          (and (plist-get info :with-todo-keywords)
+               (let ((todo (org-element-property :todo-keyword headline)))
+                 (and todo (org-export-data todo info)))))
+         (todo-type (and todo (org-element-property :todo-type headline)))
+         (tags (and (plist-get info :with-tags)
+                    (org-export-get-tags headline info)))
+         (priority (and (plist-get info :with-priority)
+                        (org-element-property :priority headline)))
+         ;; Create the headline text along with a no-tag version.  The
+         ;; latter is required to remove tags from table of contents.
+         (full-text (if (functionp org-e-groff-format-headline-function)
+                        ;; User-defined formatting function.
+                        (funcall org-e-groff-format-headline-function
+                                 todo todo-type priority text tags)
+                      ;; Default formatting.
+                      (concat
+                       (when todo
+                         (format "\\fB%s\\fP " todo))
+                       (when priority (format " [\\#%c] " priority))
+                       text
+                       (when tags
+                         (format " \\fC:%s:\\fP "
+                                 (mapconcat 'identity tags ":"))))))
+         (full-text-no-tag
+          (if (functionp org-e-groff-format-headline-function)
+              ;; User-defined formatting function.
+              (funcall org-e-groff-format-headline-function
+                       todo todo-type priority text nil)
+            ;; Default formatting.
+            (concat
+             (when todo (format "\\fB%s\\fP " todo))
+             (when priority (format " [\\#%c] " priority))
+             text)))
+         ;; Associate some \label to the headline for internal links.
+         ;; 	 (headline-label
+         ;; 	  (format "\\label{sec-%s}\n"
+         ;; 		  (mapconcat 'number-to-string
+         ;; 			     (org-export-get-headline-number headline info)
+         ;; 			     "-")))
+         (headline-label "")
+         (pre-blanks
+          (make-string (org-element-property :pre-blank headline) 10)))
+
+    (cond
+     ;; Case 1: Special Tag
+     ((member (car  tags)  org-e-groff-special-tags)
+      (cond
+       ((string= (car tags) "BODY") contents)
+
+       ((string= (car tags) "NS")
+        (progn
+          (push (cons (car tags)
+                      (format ".NS \"%s\" 1 \n%s"
+                              (car (org-element-property :title headline))
+                              (or contents " ")))
+                org-e-groff-special-content) nil))
+
+       (t
+        (progn
+          (push (cons  (car tags) contents) org-e-groff-special-content)
+          nil))))
+
+     ;; Case 2: This is a footnote section: ignore it.
+     ((org-element-property :footnote-section-p headline) nil)
+
+     ;; Case 3: This is a deep sub-tree: export it as a list item.
+     ;;         Also export as items headlines for which no section
+     ;;         format has been found.
+     ((or (not section-fmt) (org-export-low-level-p headline info))
+      ;; Build the real contents of the sub-tree.
+      (let ((low-level-body
+             (concat
+              ;; If the headline is the first sibling, start a list.
+              (when (org-export-first-sibling-p headline info)
+                (format "%s\n" (if numberedp ".AL 1\n" ".DL \n")))
+              ;; Itemize headline
+              ".LI\n" full-text "\n" headline-label pre-blanks contents)))
+        ;; If headline is not the last sibling simply return
+        ;; LOW-LEVEL-BODY.  Otherwise, also close the list, before any
+        ;; blank line.
+        (if (not (org-export-last-sibling-p headline info)) low-level-body
+          (replace-regexp-in-string
+           "[ \t\n]*\\'"
+           (concat "\n.LE")
+           low-level-body))))
+
+     ;; Case 4. Standard headline.  Export it as a section.
+     (t
+      (format section-fmt full-text
+              (concat headline-label pre-blanks contents))))))
+
+;;; Horizontal Rule
+;; Not supported
+
+;;; Inline Babel Call
+;;
+;; Inline Babel Calls are ignored.
+
+;;; Inline Src Block
+
+(defun org-e-groff-inline-src-block (inline-src-block contents info)
+  "Transcode an INLINE-SRC-BLOCK element from Org to Groff.
+CONTENTS holds the contents of the item.  INFO is a plist holding
+contextual information."
+  (let* ((code (org-element-property :value inline-src-block)))
+    (cond
+     (org-e-groff-source-highlight
+      (let* ((tmpdir (if (featurep 'xemacs)
+                         temp-directory
+                       temporary-file-directory))
+             (in-file  (make-temp-name
+                        (expand-file-name "srchilite" tmpdir)))
+             (out-file (make-temp-name
+                        (expand-file-name "reshilite" tmpdir)))
+             (org-lang (org-element-property :language inline-src-block))
+             (lst-lang (cadr (assq (intern org-lang)
+                                   org-e-groff-source-highlight-langs)))
+
+             (cmd (concat (expand-file-name "source-highlight")
+                          " -s " lst-lang
+                          " -f groff_mm_color "
+                          " -i " in-file
+                          " -o " out-file)))
+        (if lst-lang
+            (let ((code-block ""))
+              (with-temp-file in-file (insert code))
+              (shell-command cmd)
+              (setq code-block  (org-file-contents out-file))
+              (delete-file in-file)
+              (delete-file out-file)
+              code-block)
+          (format ".DS I\n\\fC\\m[black]%s\\m[]\\fP\n.DE\n"
+                  code))))
+
+     ;; Do not use a special package: transcode it verbatim.
+     (t
+      (concat ".DS I\n" "\\fC" code "\\fP\n.DE\n")))))
+
+;;; Inlinetask
+
+(defun org-e-groff-inlinetask (inlinetask contents info)
+  "Transcode an INLINETASK element from Org to Groff.
+CONTENTS holds the contents of the block.  INFO is a plist
+holding contextual information."
+  (let ((title (org-export-data (org-element-property :title inlinetask) info))
+        (todo (and (plist-get info :with-todo-keywords)
+                   (let ((todo (org-element-property :todo-keyword inlinetask)))
+                     (and todo (org-export-data todo info)))))
+        (todo-type (org-element-property :todo-type inlinetask))
+        (tags (and (plist-get info :with-tags)
+                   (org-export-get-tags inlinetask info)))
+        (priority (and (plist-get info :with-priority)
+                       (org-element-property :priority inlinetask))))
+    ;; If `org-e-groff-format-inlinetask-function' is provided, call it
+    ;; with appropriate arguments.
+    (if (functionp org-e-groff-format-inlinetask-function)
+        (funcall org-e-groff-format-inlinetask-function
+                 todo todo-type priority title tags contents)
+      ;; Otherwise, use a default template.
+      (org-e-groff--wrap-label
+       inlinetask
+       (let ((full-title
+              (concat
+               (when todo (format "\\fB%s\\fP " todo))
+               (when priority (format " [\\#%c] " priority))
+               title
+               (when tags (format " \\fC:%s:\\fP "
+                                  (mapconcat 'identity tags ":"))))))
+         (format (concat "\n.DS I\n"
+                         "%s\n"
+                         ".sp"
+                         "%s\n"
+                         ".DE")
+                 full-title contents))))))
+
+;;; Italic
+
+(defun org-e-groff-italic (italic contents info)
+  "Transcode ITALIC from Org to Groff.
+CONTENTS is the text with italic markup.  INFO is a plist holding
+contextual information."
+  (org-e-groff--text-markup contents 'italic))
+
+;;; Item
+
+(defun org-e-groff-item (item contents info)
+  "Transcode an ITEM element from Org to Groff.
+CONTENTS holds the contents of the item.  INFO is a plist holding
+contextual information."
+  (let* ((bullet (org-element-property :bullet item))
+	 (type (org-element-property
+		:type (org-element-property :parent item)))
+         (checkbox (case (org-element-property :checkbox item)
+                     (on "\\o'\\(sq\\(mu'")
+                     (off "\\(sq")
+                     (trans "\\o'\\(sq\\(mi'")))
+         (tag (let ((tag (org-element-property :tag item)))
+                ;; Check-boxes must belong to the tag.
+                (and tag (format "%s"
+                                 (concat checkbox
+                                         (org-export-data tag info)))))))
+
+	(cond
+	 ((or checkbox tag)
+	  (concat ".LI ""\"" (or tag (concat "\\ " checkbox)) "\""
+              "\n"
+              (org-trim (or contents " "))))
+     ((eq type 'ordered)
+      (concat ".LI"
+              "\n"
+              (org-trim (or contents " "))))
+     (t
+      (let* ((bullet (org-trim bullet))
+             (marker (cond  ((string= "-" bullet) "\\(em")
+                            ((string= "*" bullet) "\\(bu")
+                            (t "\\(dg"))))
+        (concat ".LI " marker "\n"
+                (org-trim (or contents " "))))))))
+
+;;; Keyword
+
+(defun org-e-groff-keyword (keyword contents info)
+  "Transcode a KEYWORD element from Org to Groff.
+CONTENTS is nil.  INFO is a plist holding contextual information."
+  (let ((key (org-element-property :key keyword))
+        (value (org-element-property :value keyword)))
+    (cond
+     ((string= key "GROFF") value)
+     (t nil))))
+
+;;; Groff Environment
+
+(defun org-e-groff-groff-environment (groff-environment contents info)
+  "Transcode a GROFF-ENVIRONMENT element from Org to Groff.
+CONTENTS is nil.  INFO is a plist holding contextual information."
+  (let ((label (org-element-property :name groff-environment))
+        (value (org-remove-indentation
+                (org-element-property :value groff-environment))))
+    (if (not (org-string-nw-p label)) value
+      ;; Environment is labelled: label must be within the environment
+      ;; (otherwise, a reference pointing to that element will count
+      ;; the section instead).
+      (with-temp-buffer
+        (insert value)
+        (goto-char (point-min))
+        (forward-line)
+        (insert (format "%s\n" label))
+        (buffer-string)))))
+
+;;; Groff Fragment
+
+(defun org-e-groff-groff-fragment (groff-fragment contents info)
+  "Transcode a GROFF-FRAGMENT object from Org to Groff.
+CONTENTS is nil.  INFO is a plist holding contextual information."
+  (org-element-property :value groff-fragment))
+
+;;; Line Break
+
+(defun org-e-groff-line-break (line-break contents info)
+  "Transcode a LINE-BREAK object from Org to Groff.
+CONTENTS is nil.  INFO is a plist holding contextual information."
+  ".br\n")
+
+;;; Link
+;; Inline images just place a call to .PSPIC or .PS/.PE
+;;  and load the graph.
+
+(defun org-e-groff-link--inline-image (link info)
+  "Return Groff code for an inline image.
+LINK is the link pointing to the inline image.  INFO is a plist
+used as a communication channel."
+  (let* ((parent (org-export-get-parent-element link))
+         (path (let ((raw-path (org-element-property :path link)))
+                 (if (not (file-name-absolute-p raw-path)) raw-path
+                   (expand-file-name raw-path))))
+         (attr (read (format "(%s)"
+            (mapconcat
+             #'identity
+             (org-element-property :attr_groff parent)
+             " "))))
+         (placement
+          (case (plist-get attr :position)
+            ('center "")
+            ('left "-L")
+            ('right "-R")
+            (t "")))
+    (width  (or (plist-get attr :width) ""))
+    (height (or (plist-get attr :height) ""))
+
+    (disable-caption (plist-get attr :disable-caption))
+
+    (caption
+          (org-e-groff--caption/label-string
+           (org-element-property :caption parent)
+           (org-element-property :name parent)
+           info)))
+
+    ;; Now clear ATTR from any special keyword and set a default value
+    ;; if nothing is left.  Return proper string.
+
+    (concat
+     (cond
+      ((string-match ".\.pic$" path)
+       (format "\n.PS\ncopy \"%s\"\n.PE" path))
+      (t (format "\n.DS L F\n.PSPIC %s \"%s\" %s %s\n.DE "
+                 placement path width height)))
+     (unless disable-caption (format "\n.FG \"%s\"" caption)))))
+
+(defun org-e-groff-link (link desc info)
+  "Transcode a LINK object from Org to Groff.
+
+DESC is the description part of the link, or the empty string.
+INFO is a plist holding contextual information.  See
+`org-export-data'."
+
+  (let* ((type (org-element-property :type link))
+         (raw-path (org-element-property :path link))
+         ;; Ensure DESC really exists, or set it to nil.
+         (desc (and (not (string= desc "")) desc))
+         (imagep (org-export-inline-image-p
+                  link org-e-groff-inline-image-rules))
+         (path (cond
+                ((member type '("http" "https" "ftp" "mailto"))
+                 (concat type ":" raw-path))
+                ((string= type "file")
+                 (when (string-match "\\(.+\\)::.+" raw-path)
+                   (setq raw-path (match-string 1 raw-path)))
+                 (if (file-name-absolute-p raw-path)
+                     (concat "file://" (expand-file-name raw-path))
+                   (concat "file://" raw-path)))
+                (t raw-path)))
+         protocol)
+    (cond
+     ;; Image file.
+     (imagep (org-e-groff-link--inline-image link info))
+     ;; import groff files
+     ((and (string= type "file")
+           (string-match ".\.groff$" raw-path))
+      (concat ".so " raw-path "\n"))
+     ;; Radio link: transcode target's contents and use them as link's
+     ;; description.
+     ((string= type "radio")
+      (let ((destination (org-export-resolve-radio-link link info)))
+        (when destination
+          (format "\\fI [%s] \\fP"
+                  (org-export-solidify-link-text path)))))
+
+     ;; Links pointing to an headline: find destination and build
+     ;; appropriate referencing command.
+     ((member type '("custom-id" "fuzzy" "id"))
+      (let ((destination (if (string= type "fuzzy")
+                             (org-export-resolve-fuzzy-link link info)
+                           (org-export-resolve-id-link link info))))
+        (case (org-element-type destination)
+          ;; Id link points to an external file.
+          (plain-text
+           (if desc (format "%s \\fBat\\fP \\fIfile://%s\\fP" desc destination)
+             (format "\\fI file://%s \\fP" destination)))
+          ;; Fuzzy link points nowhere.
+          ('nil
+           (format org-e-groff-link-with-unknown-path-format
+                   (or desc
+                       (org-export-data
+                        (org-element-property :raw-link link) info))))
+          ;; Fuzzy link points to an invisible target.
+          (keyword nil)
+          ;; LINK points to an headline.  If headlines are numbered
+          ;; and the link has no description, display headline's
+          ;; number.  Otherwise, display description or headline's
+          ;; title.
+          (headline
+           (let ((label ""))
+             (if (and (plist-get info :section-numbers) (not desc))
+                 (format "\\fI%s\\fP" label)
+               (format "\\fI%s\\fP"
+                       (or desc
+                           (org-export-data
+                            (org-element-property :title destination) info))))))
+          ;; Fuzzy link points to a target.  Do as above.
+          (otherwise
+           (let ((path (org-export-solidify-link-text path)))
+             (if (not desc) (format "\\fI%s\\fP" path)
+               (format "%s \\fBat\\fP \\fI%s\\fP" desc path)))))))
+     ;; External link with a description part.
+     ((and path desc) (format "%s \\fBat\\fP \\fI%s\\fP" path desc))
+     ;; External link without a description part.
+     (path (format "\\fI%s\\fP" path))
+     ;; No path, only description.  Try to do something useful.
+     (t (format org-e-groff-link-with-unknown-path-format desc)))))
+
+;;; Macro
+
+(defun org-e-groff-macro (macro contents info)
+  "Transcode a MACRO element from Org to Groff.
+CONTENTS is nil.  INFO is a plist holding contextual information."
+  ;; Use available tools.
+  (org-export-expand-macro macro info))
+
+;;; Paragraph
+
+(defun org-e-groff-paragraph (paragraph contents info)
+  "Transcode a PARAGRAPH element from Org to Groff.
+CONTENTS is the contents of the paragraph, as a string.  INFO is
+the plist used as a communication channel."
+  (let ((parent (plist-get (nth 1 paragraph) :parent)))
+    (when parent
+      (let* ((parent-type (car parent))
+             (fixed-paragraph "")
+             (class (plist-get info :groff-class))
+             (class-options (plist-get info :groff-class-options))
+             (classes (assoc class org-e-groff-classes))
+             (classes-options (car (last classes)))
+             (paragraph-option (plist-get classes-options :paragraph)))
+        (cond
+         ((and (symbolp paragraph-option)
+               (fboundp paragraph-option))
+          (funcall paragraph-option parent-type parent contents))
+         ((and (eq parent-type 'item)
+               (plist-get (nth 1 parent) :bullet))
+          (setq fixed-paragraph (concat "" contents)))
+         ((eq parent-type 'section)
+          (setq fixed-paragraph (concat ".P\n" contents)))
+         ((eq parent-type 'footnote-definition)
+          (setq fixed-paragraph (concat "" contents)))
+         (t (setq fixed-paragraph (concat "" contents))))
+        fixed-paragraph))))
+
+;;; Plain List
+
+(defun org-e-groff-plain-list (plain-list contents info)
+  "Transcode a PLAIN-LIST element from Org to Groff.
+CONTENTS is the contents of the list.  INFO is a plist holding
+contextual information."
+  (let* ((type (org-element-property :type plain-list))
+         (attr (mapconcat #'identity
+                          (org-element-property :attr_groff plain-list)
+                          " "))
+         (groff-type (cond
+                      ((eq type 'ordered) ".AL")
+                      ((eq type 'unordered) ".BL")
+                      ((eq type 'descriptive) ".VL 2.0i"))))
+    (org-e-groff--wrap-label
+     plain-list
+     (format "%s\n%s\n.LE" groff-type contents))))
+
+;;; Plain Text
+
+(defun org-e-groff-plain-text (text info)
+  "Transcode a TEXT string from Org to Groff.
+TEXT is the string to transcode.  INFO is a plist holding
+contextual information."
+  ;; Protect
+  (setq text (replace-regexp-in-string
+              "\\(?:[^\\]\\|^\\)\\(\\\\\\)\\(?:[^%$#&{}~^_\\]\\|$\\)"
+              "$\\" text nil t 1))
+  ;; Handle quotation marks
+  (setq text (org-e-groff--quotation-marks text info))
+  ;; Handle Special Characters
+  (if org-e-groff-special-char
+      (dolist (special-char-list org-e-groff-special-char)
+        (setq text
+              (replace-regexp-in-string (car special-char-list)
+                                        (cdr special-char-list) text))))
+  ;; Handle break preservation if required.
+  (when (plist-get info :preserve-breaks)
+    (setq text (replace-regexp-in-string
+		"\\(\\\\\\\\\\)?[ \t]*\n" " \\\\\\\\\n" text)))
+  ;; Return value.
+  text)
+
+;;; Planning
+
+(defun org-e-groff-planning (planning contents info)
+  "Transcode a PLANNING element from Org to Groff.
+CONTENTS is nil.  INFO is a plist holding contextual
+information."
+  (concat
+   (mapconcat
+    'identity
+    (delq nil
+          (list
+           (let ((closed (org-element-property :closed planning)))
+             (when closed
+               (concat
+                (format "\\fR %s \\fP" org-closed-string)
+                (format org-e-groff-inactive-timestamp-format
+                        (org-translate-time closed)))))
+           (let ((deadline (org-element-property :deadline planning)))
+             (when deadline
+               (concat
+                (format "\\fB %s \\fP" org-deadline-string)
+                (format org-e-groff-active-timestamp-format
+                        (org-translate-time deadline)))))
+           (let ((scheduled (org-element-property :scheduled planning)))
+             (when scheduled
+               (concat
+                (format "\\fR %s \\fP" org-scheduled-string)
+                (format org-e-groff-active-timestamp-format
+                        (org-translate-time scheduled)))))))
+    "")
+   ""))
+
+;;; Property Drawer
+
+(defun org-e-groff-property-drawer (property-drawer contents info)
+  "Transcode a PROPERTY-DRAWER element from Org to Groff.
+CONTENTS is nil.  INFO is a plist holding contextual
+information."
+  ;; The property drawer isn't exported but we want separating blank
+  ;; lines nonetheless.
+  "")
+
+;;; Quote Block
+
+(defun org-e-groff-quote-block (quote-block contents info)
+  "Transcode a QUOTE-BLOCK element from Org to Groff.
+CONTENTS holds the contents of the block.  INFO is a plist
+holding contextual information."
+  (org-e-groff--wrap-label
+   quote-block
+   (format ".DS I\n.I\n%s\n.R\n.DE" contents)))
+
+;;; Quote Section
+
+(defun org-e-groff-quote-section (quote-section contents info)
+  "Transcode a QUOTE-SECTION element from Org to Groff.
+CONTENTS is nil.  INFO is a plist holding contextual information."
+  (let ((value (org-remove-indentation
+                (org-element-property :value quote-section))))
+    (when value (format ".DS L\n\\fI%s\\fP\n.DE\n" value))))
+
+;;; Radio Target
+
+(defun org-e-groff-radio-target (radio-target text info)
+  "Transcode a RADIO-TARGET object from Org to Groff.
+TEXT is the text of the target.  INFO is a plist holding
+contextual information."
+  (format "%s - %s"
+          (org-export-solidify-link-text
+           (org-element-property :value radio-target))
+          text))
+
+;;; Section
+
+(defun org-e-groff-section (section contents info)
+  "Transcode a SECTION element from Org to Groff.
+CONTENTS holds the contents of the section.  INFO is a plist
+holding contextual information."
+  contents)
+
+;;; Special Block
+
+(defun org-e-groff-special-block (special-block contents info)
+  "Transcode a SPECIAL-BLOCK element from Org to Groff.
+CONTENTS holds the contents of the block.  INFO is a plist
+holding contextual information."
+  (let ((type (downcase (org-element-property :type special-block))))
+    (org-e-groff--wrap-label
+     special-block
+     (format "%s\n" contents))))
+
+;;; Src Block
+
+(defun org-e-groff-src-block (src-block contents info)
+  "Transcode a SRC-BLOCK element from Org to Groff.
+CONTENTS holds the contents of the item.  INFO is a plist holding
+contextual information."
+  (let* ((lang (org-element-property :language src-block))
+         (caption (org-element-property :caption src-block))
+         (label (org-element-property :name src-block))
+         (code (org-element-property :value src-block))
+         (custom-env (and lang
+                          (cadr (assq (intern lang)
+                                      org-e-groff-custom-lang-environments))))
+         (num-start (case (org-element-property :number-lines src-block)
+                      (continued (org-export-get-loc src-block info))
+                      (new 0)))
+         (retain-labels (org-element-property :retain-labels src-block))
+         (attr
+          (read (format "(%s)"
+                   (mapconcat #'identity
+                              (org-element-property :attr_groff src-block)
+                              " "))))
+         (disable-caption (plist-get attr :disable-caption)))
+
+    (cond
+     ;; Case 1.  No source fontification.
+     ((not org-e-groff-source-highlight)
+      (let ((caption-str (org-e-groff--caption/label-string caption label info)))
+        (concat
+         (format ".DS I\n\\fC%s\\fP\n.DE\n"
+                 (org-export-format-code-default src-block info))
+         (unless  disable-caption (format ".EX \"%s\" "  caption-str)))))
+
+     ;; Case 2.  Source fontification.
+     (org-e-groff-source-highlight
+       (let* ((tmpdir (if (featurep 'xemacs)
+                          temp-directory
+                        temporary-file-directory))
+              (caption-str (org-e-groff--caption/label-string caption label info))
+              (in-file  (make-temp-name
+                         (expand-file-name "srchilite" tmpdir)))
+              (out-file (make-temp-name
+                         (expand-file-name "reshilite" tmpdir)))
+
+              (org-lang (org-element-property :language src-block))
+              (lst-lang (cadr (assq (intern org-lang)
+                                    org-e-groff-source-highlight-langs)))
+
+              (cmd (concat "source-highlight"
+                           " -s " lst-lang
+                           " -f groff_mm_color "
+                           " -i " in-file
+                           " -o " out-file)))
+
+         (concat
+          (if lst-lang
+              (let ((code-block ""))
+                (with-temp-file in-file (insert code))
+                (shell-command cmd)
+                (setq code-block  (org-file-contents out-file))
+                (delete-file in-file)
+                (delete-file out-file)
+                (format "%s\n"  code-block))
+            (format ".DS I\n\\fC\\m[black]%s\\m[]\\fP\n.DE\n"
+                    code))
+          (unless disable-caption (format ".EX \"%s\" " caption-str))))))))
+
+
+;;; Statistics Cookie
+
+(defun org-e-groff-statistics-cookie (statistics-cookie contents info)
+  "Transcode a STATISTICS-COOKIE object from Org to Groff.
+CONTENTS is nil.  INFO is a plist holding contextual information."
+  (org-element-property :value statistics-cookie))
+
+
+;;; Strike-Through
+
+(defun org-e-groff-strike-through (strike-through contents info)
+  "Transcode STRIKE-THROUGH from Org to Groff.
+CONTENTS is the text with strike-through markup.  INFO is a plist
+holding contextual information."
+  (org-e-groff--text-markup contents 'strike-through))
+
+;;; Subscript
+
+(defun org-e-groff-subscript (subscript contents info)
+  "Transcode a SUBSCRIPT object from Org to Groff.
+CONTENTS is the contents of the object.  INFO is a plist holding
+contextual information."
+  (format  "\\d\\s-2%s\\s+2\\u" contents))
+
+;;; Superscript "^_%s$
+
+(defun org-e-groff-superscript (superscript contents info)
+  "Transcode a SUPERSCRIPT object from Org to Groff.
+CONTENTS is the contents of the object.  INFO is a plist holding
+contextual information."
+  (format  "\\u\\s-2%s\\s+2\\d" contents))
+
+
+;;; Table
+;;
+;; `org-e-groff-table' is the entry point for table transcoding.  It
+;; takes care of tables with a "verbatim" attribute.  Otherwise, it
+;; delegates the job to  `org-e-groff-table--org-table' function,
+;; depending of the type of the table.
+;;
+;; `org-e-groff-table--align-string' is a subroutine used to build
+;; alignment string for Org tables.
+
+(defun org-e-groff-table (table contents info)
+  "Transcode a TABLE element from Org to Groff.
+CONTENTS is the contents of the table.  INFO is a plist holding
+contextual information."
+  (cond
+   ;; Case 1: verbatim table.
+   ((or org-e-groff-tables-verbatim
+        (let ((attr (read (format "(%s)"
+                 (mapconcat
+                  #'identity
+                                   (org-element-property :attr_groff table) " ")))))
+          (and attr (plist-get attr :verbatim))))
+
+    (format ".DS L\n\\fC%s\\fP\n.DE"
+            ;; Re-create table, without affiliated keywords.
+            (org-trim
+             (org-element-interpret-data
+              `(table nil ,@(org-element-contents table))))))
+
+   ;; Case 2: Standard table.
+   (t (org-e-groff-table--org-table table contents info))))
+
+(defun org-e-groff-table--align-string (divider table info)
+  "Return an appropriate Groff alignment string.
+TABLE is the considered table.  INFO is a plist used as
+a communication channel."
+    (let (alignment)
+      ;; Extract column groups and alignment from first (non-rule)
+      ;; row.
+      (org-element-map
+       (org-element-map
+        table 'table-row
+        (lambda (row)
+          (and (eq (org-element-property :type row) 'standard) row))
+        info 'first-match)
+       'table-cell
+       (lambda (cell)
+         (let* ((borders (org-export-table-cell-borders cell info))
+                (raw-width (org-export-table-cell-width cell info))
+                (width-cm (when raw-width (/ raw-width 5)))
+                (width (if raw-width (format "w(%dc)"
+                                             (if (< width-cm 1) 1 width-cm)) "")))
+           ;; Check left border for the first cell only.
+         ;; Alignment is nil on assignment
+
+           (when (and (memq 'left borders) (not alignment))
+             (push "|" alignment))
+           (push
+                (case (org-export-table-cell-alignment cell info)
+                  (left (concat "l" width divider))
+                  (right (concat "r" width divider))
+                  (center (concat "c" width divider)))
+            alignment)
+           (when (memq 'right borders) (push "|" alignment))))
+       info)
+    (apply 'concat (reverse alignment))))
+
+(defun org-e-groff-table--org-table (table contents info)
+  "Return appropriate Groff code for an Org table.
+
+TABLE is the table type element to transcode.  CONTENTS is its
+contents, as a string.  INFO is a plist used as a communication
+channel.
+
+This function assumes TABLE has `org' as its `:type' attribute."
+  (let* ((label (org-element-property :name table))
+         (caption (org-e-groff--caption/label-string
+                   (org-element-property :caption table) label info))
+         (attr (read (format "(%s)"
+                             (mapconcat #'identity
+             (org-element-property :attr_groff table)
+             " "))))
+         (divider (if (plist-get attr :divider) "|" " "))
+
+         ;; Determine alignment string.
+         (alignment (org-e-groff-table--align-string divider table info))
+
+         ;; Extract others display options.
+
+         (lines (org-split-string contents "\n"))
+
+         (attr-list
+          (let (result-list)
+            (dolist (attr-item
+                     (list
+                      (if (plist-get attr :expand)
+                          "expand" nil)
+
+                      (case (plist-get attr :placement)
+                        ('center "center")
+                        ('left nil)
+                        (t
+                         (if org-e-groff-tables-centered
+                             "center" "")))
+
+                      (case (plist-get attr :boxtype)
+                        ('box "box")
+                        ('doublebox "doublebox")
+                        ('allbox "allbox")
+                        ('none nil)
+                        (t "box"))))
+
+              (if (not (null attr-item))
+                  (add-to-list 'result-list attr-item)))
+            result-list))
+
+         (title-line  (plist-get attr :title-line))
+         (disable-caption (plist-get attr :disable-caption))
+         (long-cells (plist-get attr :long-cells))
+
+         (table-format
+          (concat
+           (format "%s"
+                   (or (car attr-list) ""))
+           (or
+            (let (output-list)
+                           (when (cdr attr-list)
+                             (dolist (attr-item (cdr attr-list))
+                  (setq output-list (concat output-list
+					    (format ",%s" attr-item)))))
+              output-list) "")))
+         (first-line
+          (when lines (org-split-string (car lines) "\t"))))
+    ;; Prepare the final format string for the table.
+
+
+    (cond
+     ;; Others.
+     (lines
+      (concat ".TS\n " table-format ";\n"
+                    (format "%s.\n"
+                            (let ((final-line ""))
+                              (when title-line
+                                (dotimes (i (length first-line))
+                                  (setq final-line (concat final-line "cb" divider))))
+
+                              (setq final-line (concat final-line "\n"))
+
+                              (if alignment
+                                  (setq final-line (concat final-line alignment))
+                                (dotimes (i (length first-line))
+                                  (setq final-line (concat final-line "c" divider))))
+                              final-line))
+
+                    (format "%s\n.TE\n"
+                            (let ((final-line "")
+                                  (long-line "")
+                                  (lines (org-split-string contents "\n")))
+
+                              (dolist (line-item lines)
+                                (setq long-line "")
+
+                                (if long-cells
+                                    (progn
+                                      (if (string= line-item "_")
+                                          (setq long-line (format "%s\n" line-item))
+                                        ;; else string =
+                                        (let ((cell-item-list (org-split-string line-item "\t")))
+                                          (dolist (cell-item cell-item-list)
+
+                                            (cond  ((eq cell-item (car (last cell-item-list)))
+                                                    (setq long-line (concat long-line
+                                                                            (format "T{\n%s\nT}\t\n"  cell-item))))
+                                                   (t
+                                                    (setq long-line (concat long-line
+                                                                            (format "T{\n%s\nT}\t"  cell-item))))))
+                                        long-line))
+                                     ;; else long cells
+                                  (setq final-line (concat final-line long-line)))
+
+                                  (setq final-line (concat final-line line-item "\n"))))
+                              final-line))
+
+                    (if (not disable-caption)
+                        (format ".TB \"%s\""
+                                caption) ""))))))
+
+;;; Table Cell
+
+(defun org-e-groff-table-cell (table-cell contents info)
+  "Transcode a TABLE-CELL element from Org to Groff
+CONTENTS is the cell contents.  INFO is a plist used as
+a communication channel."
+  (progn
+    (concat (if (and contents
+                     org-e-groff-table-scientific-notation
+                     (string-match orgtbl-exp-regexp contents))
+                ;; Use appropriate format string for scientific
+                ;; notation.
+                (format org-e-groff-table-scientific-notation
+                        (match-string 1 contents)
+                        (match-string 2 contents))
+              contents)
+            (when (org-export-get-next-element table-cell info) "\t"))))
+
+
+;;; Table Row
+
+(defun org-e-groff-table-row (table-row contents info)
+  "Transcode a TABLE-ROW element from Org to Groff
+CONTENTS is the contents of the row.  INFO is a plist used as
+a communication channel."
+  ;; Rules are ignored since table separators are deduced from
+  ;; borders of the current row.
+  (when (eq (org-element-property :type table-row) 'standard)
+    (let* ((attr (mapconcat 'identity
+                            (org-element-property
+                             :attr_groff (org-export-get-parent table-row))
+                            " "))
+           ;; TABLE-ROW's borders are extracted from its first cell.
+           (borders
+            (org-export-table-cell-borders
+             (car (org-element-contents table-row)) info)))
+      (concat
+       ;; Mark horizontal lines
+       (cond  ((and (memq 'top borders) (memq 'above borders)) "_\n"))
+       contents
+       (cond
+        ;; When BOOKTABS are activated enforce bottom rule even when
+        ;; no hline was specifically marked.
+        ((and (memq 'bottom borders) (memq 'below borders)) "\n_")
+        ((memq 'below borders) "\n_"))))))
+
+;;; Target
+
+(defun org-e-groff-target (target contents info)
+  "Transcode a TARGET object from Org to Groff.
+CONTENTS is nil.  INFO is a plist holding contextual
+information."
+  (format "\\fI%s\\fP"
+          (org-export-solidify-link-text (org-element-property :value target))))
+
+;;; Timestamp
+
+(defun org-e-groff-timestamp (timestamp contents info)
+  "Transcode a TIMESTAMP object from Org to Groff.
+CONTENTS is nil.  INFO is a plist holding contextual
+information."
+  (let ((value (org-translate-time (org-element-property :value timestamp)))
+        (type (org-element-property :type timestamp)))
+    (cond ((memq type '(active active-range))
+           (format org-e-groff-active-timestamp-format value))
+          ((memq type '(inactive inactive-range))
+           (format org-e-groff-inactive-timestamp-format value))
+          (t (format org-e-groff-diary-timestamp-format value)))))
+
+;;; Underline
+
+(defun org-e-groff-underline (underline contents info)
+  "Transcode UNDERLINE from Org to Groff.
+CONTENTS is the text with underline markup.  INFO is a plist
+holding contextual information."
+  (org-e-groff--text-markup contents 'underline))
+
+;;; Verbatim
+
+(defun org-e-groff-verbatim (verbatim contents info)
+  "Transcode a VERBATIM object from Org to Groff.
+CONTENTS is nil.  INFO is a plist used as a communication
+channel."
+  (org-e-groff--text-markup (org-element-property :value verbatim) 'verbatim))
+
+;;; Verse Block
+
+(defun org-e-groff-verse-block (verse-block contents info)
+  "Transcode a VERSE-BLOCK element from Org to Groff.
+CONTENTS is verse block contents. INFO is a plist holding
+contextual information."
+  (format ".DS C\n.ft HI\n%s\n.ft\n.DE" contents))
+
+
+;;; Interactive functions
+
+(defun org-e-groff-export-to-groff
+  (&optional subtreep visible-only body-only ext-plist pub-dir)
+  "Export current buffer to a Groff file.
+
+If narrowing is active in the current buffer, only export its
+narrowed part.
+
+If a region is active, export that region.
+
+When optional argument SUBTREEP is non-nil, export the sub-tree
+at point, extracting information from the headline properties
+first.
+
+When optional argument VISIBLE-ONLY is non-nil, don't export
+contents of hidden elements.
+
+EXT-PLIST, when provided, is a property list with external
+parameters overriding Org default settings, but still inferior to
+file-local settings.
+
+When optional argument PUB-DIR is set, use it as the publishing
+directory.
+
+Return output file's name."
+  (interactive)
+  (setq org-e-groff-registered-references nil)
+  (setq org-e-groff-special-content nil)
+  (let ((outfile (org-export-output-file-name ".groff" subtreep pub-dir)))
+    (org-export-to-file
+     'e-groff outfile subtreep visible-only body-only ext-plist)))
+
+(defun org-e-groff-export-to-pdf
+  (&optional subtreep visible-only body-only ext-plist pub-dir)
+  "Export current buffer to Groff then process through to PDF.
+
+If narrowing is active in the current buffer, only export its
+narrowed part.
+
+If a region is active, export that region.
+
+When optional argument SUBTREEP is non-nil, export the sub-tree
+at point, extracting information from the headline properties
+first.
+
+When optional argument VISIBLE-ONLY is non-nil, don't export
+contents of hidden elements.
+
+EXT-PLIST, when provided, is a property list with external
+parameters overriding Org default settings, but still inferior to
+file-local settings.
+
+When optional argument PUB-DIR is set, use it as the publishing
+directory.
+
+Return PDF file's name."
+  (interactive)
+  (org-e-groff-compile
+   (org-e-groff-export-to-groff
+    subtreep visible-only body-only ext-plist pub-dir)))
+
+(defun org-e-groff-compile (grofffile)
+  "Compile a Groff file.
+
+GROFFFILE is the name of the file being compiled.  Processing is
+done through the command specified in `org-e-groff-pdf-process'.
+
+Return PDF file name or an error if it couldn't be produced."
+  (let* ((wconfig (current-window-configuration))
+         (grofffile (file-truename grofffile))
+         (base (file-name-sans-extension grofffile))
+         errors)
+    (message (format "Processing Groff file %s ..." grofffile))
+    (unwind-protect
+        (progn
+          (cond
+           ;; A function is provided: Apply it.
+           ((functionp org-e-groff-pdf-process)
+            (funcall org-e-groff-pdf-process (shell-quote-argument grofffile)))
+           ;; A list is provided: Replace %b, %f and %o with appropriate
+           ;; values in each command before applying it.  Output is
+           ;; redirected to "*Org PDF Groff Output*" buffer.
+           ((consp org-e-groff-pdf-process)
+            (let* ((out-dir (or (file-name-directory grofffile) "./"))
+                   (outbuf (get-buffer-create "*Org PDF Groff Output*")))
+              (mapc
+               (lambda (command)
+                 (shell-command
+                  (replace-regexp-in-string
+                   "%b" (shell-quote-argument base)
+                   (replace-regexp-in-string
+                    "%f" (shell-quote-argument grofffile)
+                    (replace-regexp-in-string
+                     "%o" (shell-quote-argument out-dir) command t t)
+		    t t) t t)
+                  outbuf))
+               org-e-groff-pdf-process)
+              ;; Collect standard errors from output buffer.
+              (setq errors (org-e-groff-collect-errors outbuf))))
+           (t (error "No valid command to process to PDF")))
+          (let ((pdffile (concat base ".pdf")))
+            ;; Check for process failure.  Provide collected errors if
+            ;; possible.
+            (if (not (file-exists-p pdffile))
+                (error (concat (format "PDF file %s wasn't produced" pdffile)
+                               (when errors (concat ": " errors))))
+              ;; Else remove log files, when specified, and signal end of
+              ;; process to user, along with any error encountered.
+              (when org-e-groff-remove-logfiles
+                (dolist (ext org-e-groff-logfiles-extensions)
+                  (let ((file (concat base "." ext)))
+                    (when (file-exists-p file) (delete-file file)))))
+              (message (concat "Process completed"
+                               (if (not errors) "."
+                                 (concat " with errors: " errors)))))
+            ;; Return output file name.
+            pdffile))
+      (set-window-configuration wconfig))))
+
+(defun org-e-groff-collect-errors (buffer)
+  "Collect some kind of errors from \"groff\" output
+BUFFER is the buffer containing output.
+Return collected error types as a string, or nil if there was
+none."
+  (with-current-buffer buffer
+    (save-excursion
+      (goto-char (point-max))
+      ;; Find final run
+      nil)))
+
+
+(provide 'org-e-groff)
+;;; org-e-groff.el ends here
diff --git a/contrib/lisp/org-e-html.el b/contrib/lisp/org-e-html.el
new file mode 100644
index 0000000..f0ba5f9
--- /dev/null
+++ b/contrib/lisp/org-e-html.el
@@ -0,0 +1,3044 @@
+;;; org-e-html.el --- HTML Back-End For Org Export Engine
+
+;; Copyright (C) 2011-2012  Free Software Foundation, Inc.
+
+;; Author: Jambunathan K 
+;; Keywords: outlines, hypermedia, calendar, wp
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program.  If not, see .
+
+;;; Commentary:
+
+;; This library implements a HTML back-end for Org generic exporter.
+
+;; To test it, run
+;;
+;;   M-: (org-export-to-buffer 'e-html "*Test e-HTML*") RET
+;;
+;; in an org-mode buffer then switch to the buffer to see the HTML
+;; export.  See contrib/lisp/org-export.el for more details on how
+;; this exporter works.
+
+;;; Code:
+
+;;; org-e-html.el
+;;; Dependencies
+
+(require 'org-export)
+(require 'format-spec)
+(eval-when-compile (require 'cl) (require 'table))
+
+
+
+;;; Function Declarations
+
+(declare-function org-id-find-id-file "org-id" (id))
+(declare-function htmlize-region "ext:htmlize" (beg end))
+(declare-function org-pop-to-buffer-same-window
+		  "org-compat" (&optional buffer-or-name norecord label))
+
+
+;;; Define Back-End
+
+(org-export-define-backend e-html
+  ((bold . org-e-html-bold)
+   (center-block . org-e-html-center-block)
+   (clock . org-e-html-clock)
+   (code . org-e-html-code)
+   (drawer . org-e-html-drawer)
+   (dynamic-block . org-e-html-dynamic-block)
+   (entity . org-e-html-entity)
+   (example-block . org-e-html-example-block)
+   (export-block . org-e-html-export-block)
+   (export-snippet . org-e-html-export-snippet)
+   (fixed-width . org-e-html-fixed-width)
+   (footnote-definition . org-e-html-footnote-definition)
+   (footnote-reference . org-e-html-footnote-reference)
+   (headline . org-e-html-headline)
+   (horizontal-rule . org-e-html-horizontal-rule)
+   (inline-src-block . org-e-html-inline-src-block)
+   (inlinetask . org-e-html-inlinetask)
+   (italic . org-e-html-italic)
+   (item . org-e-html-item)
+   (keyword . org-e-html-keyword)
+   (latex-environment . org-e-html-latex-environment)
+   (latex-fragment . org-e-html-latex-fragment)
+   (line-break . org-e-html-line-break)
+   (link . org-e-html-link)
+   (macro . org-e-html-macro)
+   (paragraph . org-e-html-paragraph)
+   (plain-list . org-e-html-plain-list)
+   (plain-text . org-e-html-plain-text)
+   (planning . org-e-html-planning)
+   (property-drawer . org-e-html-property-drawer)
+   (quote-block . org-e-html-quote-block)
+   (quote-section . org-e-html-quote-section)
+   (radio-target . org-e-html-radio-target)
+   (section . org-e-html-section)
+   (special-block . org-e-html-special-block)
+   (src-block . org-e-html-src-block)
+   (statistics-cookie . org-e-html-statistics-cookie)
+   (strike-through . org-e-html-strike-through)
+   (subscript . org-e-html-subscript)
+   (superscript . org-e-html-superscript)
+   (table . org-e-html-table)
+   (table-cell . org-e-html-table-cell)
+   (table-row . org-e-html-table-row)
+   (target . org-e-html-target)
+   (template . org-e-html-template)
+   (timestamp . org-e-html-timestamp)
+   (underline . org-e-html-underline)
+   (verbatim . org-e-html-verbatim)
+   (verse-block . org-e-html-verse-block))
+  :export-block "HTML"
+  :filters-alist ((:filter-final-output . org-e-html-final-function))
+  :options-alist
+  ;; FIXME: Prefix KEYWORD and OPTION with "HTML_".  Prefix
+  ;; corresponding properties with `:html-".  If such a renaming is
+  ;; taken up, some changes will be required in `org-jsinfo.el',
+  ;; I think.  So defer renaming for now.
+  ((:agenda-style nil nil org-agenda-export-html-style)
+   (:creator "CREATOR" nil org-e-html-creator-string)
+   (:convert-org-links nil nil org-e-html-link-org-files-as-html)
+   ;; (:expand-quoted-html nil "@" org-e-html-expand)
+   (:inline-images nil nil org-e-html-inline-images)
+   (:link-home "LINK_HOME" nil org-e-html-link-home)
+   (:link-up "LINK_UP" nil org-e-html-link-up)
+   (:style nil nil org-e-html-style)
+   (:style-extra "STYLE" nil org-e-html-style-extra newline)
+   (:style-include-default nil nil org-e-html-style-include-default)
+   (:style-include-scripts nil nil org-e-html-style-include-scripts)
+   ;; (:timestamp nil nil org-e-html-with-timestamp)
+   (:html-extension nil nil org-e-html-extension)
+   (:html-postamble nil nil org-e-html-postamble)
+   (:html-preamble nil nil org-e-html-preamble)
+   (:html-table-tag nil nil org-e-html-table-tag)
+   (:xml-declaration nil nil org-e-html-xml-declaration)
+   (:LaTeX-fragments nil "LaTeX" org-export-with-LaTeX-fragments)
+   (:mathjax "MATHJAX" nil "" space)))
+
+
+
+;;; Internal Variables
+
+;; FIXME: it already exists in org-e-html.el
+(defconst org-e-html-cvt-link-fn
+   nil
+   "Function to convert link URLs to exportable URLs.
+Takes two arguments, TYPE and PATH.
+Returns exportable url as (TYPE PATH), or nil to signal that it
+didn't handle this case.
+Intended to be locally bound around a call to `org-export-as-html'." )
+
+(defvar org-e-html-format-table-no-css)
+(defvar htmlize-buffer-places)  ; from htmlize.el
+(defvar body-only) ; dynamically scoped into this.
+
+(defconst org-e-html-special-string-regexps
+  '(("\\\\-" . "­")
+    ("---\\([^-]\\)" . "—\\1")
+    ("--\\([^-]\\)" . "–\\1")
+    ("\\.\\.\\." . "…"))
+  "Regular expressions for special string conversion.")
+
+
+(defconst org-e-html-scripts
+""
+"Basic JavaScript that is needed by HTML files produced by Org-mode.")
+
+
+(defconst org-e-html-style-default
+""
+  "The default style specification for exported HTML files.
+Please use the variables `org-e-html-style' and
+`org-e-html-style-extra' to add to this style.  If you wish to not
+have the default style included, customize the variable
+`org-e-html-style-include-default'.")
+
+
+
+(defvar org-e-html-content-div "content"
+  "The name of the container DIV that holds all the page contents.
+
+This variable is obsolete since Org version 7.7.
+Please set `org-e-html-divs' instead.")
+
+
+
+;;; User Configuration Variables
+
+(defgroup org-export-e-html nil
+  "Options for exporting Org mode files to HTML."
+  :tag "Org Export HTML"
+  :group 'org-export)
+
+(defgroup org-export-e-htmlize nil
+  "Options for processing examples with htmlize.el."
+  :tag "Org Export Htmlize"
+  :group 'org-export-e-html)
+
+
+;;;; Bold etc
+
+(defcustom org-e-html-text-markup-alist
+  '((bold . "%s")
+    (code . "%s")
+    (italic . "%s")
+    (strike-through . "%s")
+    (underline . "%s")
+    (verbatim . "%s"))
+  "Alist of HTML expressions to convert text markup
+
+The key must be a symbol among `bold', `code', `italic',
+`strike-through', `underline' and `verbatim'.  The value is
+a formatting string to wrap fontified text with.
+
+If no association can be found for a given markup, text will be
+returned as-is."
+  :group 'org-export-e-html
+  :type '(alist :key-type (symbol :tag "Markup type")
+		:value-type (string :tag "Format string"))
+  :options '(bold code italic strike-through underline verbatim))
+
+
+;;;; Debugging
+
+(defcustom org-e-html-pretty-output nil
+  "Enable this to generate pretty HTML."
+  :group 'org-export-e-html
+  :type 'boolean)
+
+
+;;;; Drawers
+
+(defcustom org-e-html-format-drawer-function nil
+  "Function called to format a drawer in HTML code.
+
+The function must accept two parameters:
+  NAME      the drawer name, like \"LOGBOOK\"
+  CONTENTS  the contents of the drawer.
+
+The function should return the string to be exported.
+
+For example, the variable could be set to the following function
+in order to mimic default behaviour:
+
+\(defun org-e-html-format-drawer-default \(name contents\)
+  \"Format a drawer element for HTML export.\"
+  contents\)"
+  :group 'org-export-e-html
+  :type 'function)
+
+
+;;;; Footnotes
+
+(defcustom org-e-html-footnotes-section "
+

%s:

+
+%s +
+
" + "Format for the footnotes section. +Should contain a two instances of %s. The first will be replaced with the +language-specific word for \"Footnotes\", the second one will be replaced +by the footnotes themselves." + :group 'org-export-e-html + :type 'string) + +(defcustom org-e-html-footnote-format "%s" + "The format for the footnote reference. +%s will be replaced by the footnote reference itself." + :group 'org-export-e-html + :type 'string) + +(defcustom org-e-html-footnote-separator ", " + "Text used to separate footnotes." + :group 'org-export-e-html + :type 'string) + + +;;;; Headline + +(defcustom org-e-html-toplevel-hlevel 2 + "The level for level 1 headings in HTML export. +This is also important for the classes that will be wrapped around headlines +and outline structure. If this variable is 1, the top-level headlines will +be

, and the corresponding classes will be outline-1, section-number-1, +and outline-text-1. If this is 2, all of these will get a 2 instead. +The default for this variable is 2, because we use

for formatting the +document title." + :group 'org-export-e-html + :type 'string) + +(defcustom org-e-html-format-headline-function nil + "Function to format headline text. + +This function will be called with 5 arguments: +TODO the todo keyword (string or nil). +TODO-TYPE the type of todo (symbol: `todo', `done', nil) +PRIORITY the priority of the headline (integer or nil) +TEXT the main headline text (string). +TAGS the tags (string or nil). + +The function result will be used in the section format string. + +As an example, one could set the variable to the following, in +order to reproduce the default set-up: + +\(defun org-e-html-format-headline \(todo todo-type priority text tags) + \"Default format function for an headline.\" + \(concat \(when todo + \(format \"\\\\textbf{\\\\textsc{\\\\textsf{%s}}} \" todo)) + \(when priority + \(format \"\\\\framebox{\\\\#%c} \" priority)) + text + \(when tags (format \"\\\\hfill{}\\\\textsc{%s}\" tags))))" + :group 'org-export-e-html + :type 'function) + + +;;;; HTML-specific + +(defcustom org-e-html-allow-name-attribute-in-anchors t + "When nil, do not set \"name\" attribute in anchors. +By default, anchors are formatted with both \"id\" and \"name\" +attributes, when appropriate." + :group 'org-export-e-html + :type 'boolean) + + +;;;; Inlinetasks + +(defcustom org-e-html-format-inlinetask-function nil + "Function called to format an inlinetask in HTML code. + +The function must accept six parameters: + TODO the todo keyword, as a string + TODO-TYPE the todo type, a symbol among `todo', `done' and nil. + PRIORITY the inlinetask priority, as a string + NAME the inlinetask name, as a string. + TAGS the inlinetask tags, as a list of strings. + CONTENTS the contents of the inlinetask, as a string. + +The function should return the string to be exported. + +For example, the variable could be set to the following function +in order to mimic default behaviour: + +\(defun org-e-html-format-inlinetask \(todo type priority name tags contents\) +\"Format an inline task element for HTML export.\" + \(let \(\(full-title + \(concat + \(when todo + \(format \"\\\\textbf{\\\\textsf{\\\\textsc{%s}}} \" todo)) + \(when priority (format \"\\\\framebox{\\\\#%c} \" priority)) + title + \(when tags (format \"\\\\hfill{}\\\\textsc{%s}\" tags))))) + \(format (concat \"\\\\begin{center}\\n\" + \"\\\\fbox{\\n\" + \"\\\\begin{minipage}[c]{.6\\\\textwidth}\\n\" + \"%s\\n\\n\" + \"\\\\rule[.8em]{\\\\textwidth}{2pt}\\n\\n\" + \"%s\" + \"\\\\end{minipage}}\" + \"\\\\end{center}\") + full-title contents))" + :group 'org-export-e-html + :type 'function) + + +;;;; Links :: Generic + +(defcustom org-e-html-link-org-files-as-html t + "Non-nil means make file links to `file.org' point to `file.html'. +When org-mode is exporting an org-mode file to HTML, links to +non-html files are directly put into a href tag in HTML. +However, links to other Org-mode files (recognized by the +extension `.org.) should become links to the corresponding html +file, assuming that the linked org-mode file will also be +converted to HTML. +When nil, the links still point to the plain `.org' file." + :group 'org-export-e-html + :type 'boolean) + + +;;;; Links :: Inline images + +(defcustom org-e-html-inline-images 'maybe + "Non-nil means inline images into exported HTML pages. +This is done using an tag. When nil, an anchor with href is used to +link to the image. If this option is `maybe', then images in links with +an empty description will be inlined, while images with a description will +be linked only." + :group 'org-export-e-html + :type '(choice (const :tag "Never" nil) + (const :tag "Always" t) + (const :tag "When there is no description" maybe))) + +(defcustom org-e-html-inline-image-rules + '(("file" . "\\.\\(jpeg\\|jpg\\|png\\|gif\\|svg\\)\\'") + ("http" . "\\.\\(jpeg\\|jpg\\|png\\|gif\\|svg\\)\\'") + ("https" . "\\.\\(jpeg\\|jpg\\|png\\|gif\\|svg\\)\\'")) + "Rules characterizing image files that can be inlined into HTML. + +A rule consists in an association whose key is the type of link +to consider, and value is a regexp that will be matched against +link's path. + +Note that, by default, the image extension *actually* allowed +depend on the way the HTML file is processed. When used with +pdflatex, pdf, jpg and png images are OK. When processing +through dvi to Postscript, only ps and eps are allowed. The +default we use here encompasses both." + :group 'org-export-e-html + :type '(alist :key-type (string :tag "Type") + :value-type (regexp :tag "Path"))) + + +;;;; Plain Text + +(defcustom org-e-html-protect-char-alist + '(("&" . "&") + ("<" . "<") + (">" . ">")) + "Alist of characters to be converted by `org-e-html-protect'." + :group 'org-export-e-html + :type '(repeat (cons (string :tag "Character") + (string :tag "HTML equivalent")))) + +(defcustom org-e-html-quotes + '(("fr" + ("\\(\\s-\\|[[(]\\|^\\)\"" . "« ") + ("\\(\\S-\\)\"" . " »") + ("\\(\\s-\\|(\\|^\\)'" . "’")) + ("en" + ("\\(\\s-\\|[[(]\\|^\\)\"" . "“") + ("\\(\\S-\\)\"" . "”") + ("\\(\\s-\\|(\\|^\\)'" . "‘"))) + "Alist for quotes to use when converting english double-quotes. + +The CAR of each item in this alist is the language code. +The CDR of each item in this alist is a list of three CONS: +- the first CONS defines the opening quote; +- the second CONS defines the closing quote; +- the last CONS defines single quotes. + +For each item in a CONS, the first string is a regexp +for allowed characters before/after the quote, the second +string defines the replacement string for this quote." + :group 'org-export-e-html + :type '(list + (cons :tag "Opening quote" + (string :tag "Regexp for char before") + (string :tag "Replacement quote ")) + (cons :tag "Closing quote" + (string :tag "Regexp for char after ") + (string :tag "Replacement quote ")) + (cons :tag "Single quote" + (string :tag "Regexp for char before") + (string :tag "Replacement quote ")))) + + +;;;; Src Block + +(defcustom org-export-e-htmlize-output-type 'inline-css + "Output type to be used by htmlize when formatting code snippets. +Choices are `css', to export the CSS selectors only, or `inline-css', to +export the CSS attribute values inline in the HTML. We use as default +`inline-css', in order to make the resulting HTML self-containing. + +However, this will fail when using Emacs in batch mode for export, because +then no rich font definitions are in place. It will also not be good if +people with different Emacs setup contribute HTML files to a website, +because the fonts will represent the individual setups. In these cases, +it is much better to let Org/Htmlize assign classes only, and to use +a style file to define the look of these classes. +To get a start for your css file, start Emacs session and make sure that +all the faces you are interested in are defined, for example by loading files +in all modes you want. Then, use the command +\\[org-export-e-htmlize-generate-css] to extract class definitions." + :group 'org-export-e-htmlize + :type '(choice (const css) (const inline-css))) + +(defcustom org-export-e-htmlize-css-font-prefix "org-" + "The prefix for CSS class names for htmlize font specifications." + :group 'org-export-e-htmlize + :type 'string) + +(defcustom org-export-e-htmlized-org-css-url nil + "URL pointing to a CSS file defining text colors for htmlized Emacs buffers. +Normally when creating an htmlized version of an Org buffer, htmlize will +create CSS to define the font colors. However, this does not work when +converting in batch mode, and it also can look bad if different people +with different fontification setup work on the same website. +When this variable is non-nil, creating an htmlized version of an Org buffer +using `org-export-as-org' will remove the internal CSS section and replace it +with a link to this URL." + :group 'org-export-e-htmlize + :type '(choice + (const :tag "Keep internal css" nil) + (string :tag "URL or local href"))) + + +;;;; Table + +(defcustom org-e-html-table-tag + "" + "The HTML tag that is used to start a table. +This must be a
tag, but you may change the options like +borders and spacing." + :group 'org-export-e-html + :type 'string) + +(defcustom org-e-html-table-header-tags '("") + "The opening tag for table header fields. +This is customizable so that alignment options can be specified. +The first %s will be filled with the scope of the field, either row or col. +The second %s will be replaced by a style entry to align the field. +See also the variable `org-e-html-table-use-header-tags-for-first-column'. +See also the variable `org-e-html-table-align-individual-fields'." + :group 'org-export-tables ; FIXME: change group? + :type '(cons (string :tag "Opening tag") (string :tag "Closing tag"))) + +(defcustom org-e-html-table-data-tags '("" . "") + "The opening tag for table data fields. +This is customizable so that alignment options can be specified. +The first %s will be filled with the scope of the field, either row or col. +The second %s will be replaced by a style entry to align the field. +See also the variable `org-e-html-table-align-individual-fields'." + :group 'org-export-tables + :type '(cons (string :tag "Opening tag") (string :tag "Closing tag"))) + +(defcustom org-e-html-table-row-tags '("" . "") + "The opening tag for table data fields. +This is customizable so that alignment options can be specified. +Instead of strings, these can be Lisp forms that will be evaluated +for each row in order to construct the table row tags. During evaluation, +the variable `head' will be true when this is a header line, nil when this +is a body line. And the variable `nline' will contain the line number, +starting from 1 in the first header line. For example + + (setq org-e-html-table-row-tags + (cons '(if head + \"\" + (if (= (mod nline 2) 1) + \"\" + \"\")) + \"\")) + +will give even lines the class \"tr-even\" and odd lines the class \"tr-odd\"." + :group 'org-export-tables + :type '(cons + (choice :tag "Opening tag" + (string :tag "Specify") + (sexp)) + (choice :tag "Closing tag" + (string :tag "Specify") + (sexp)))) + +(defcustom org-e-html-table-align-individual-fields t + "Non-nil means attach style attributes for alignment to each table field. +When nil, alignment will only be specified in the column tags, but this +is ignored by some browsers (like Firefox, Safari). Opera does it right +though." + :group 'org-export-tables + :type 'boolean) + +(defcustom org-e-html-table-use-header-tags-for-first-column nil + "Non-nil means format column one in tables with header tags. +When nil, also column one will use data tags." + :group 'org-export-tables + :type 'boolean) + +(defcustom org-e-html-table-caption-above t + "When non-nil, place caption string at the beginning of the table. +Otherwise, place it near the end." + :group 'org-export-e-html + :type 'boolean) + + +;;;; Tags + +(defcustom org-e-html-tag-class-prefix "" + "Prefix to class names for TODO keywords. +Each tag gets a class given by the tag itself, with this prefix. +The default prefix is empty because it is nice to just use the keyword +as a class name. But if you get into conflicts with other, existing +CSS classes, then this prefix can be very useful." + :group 'org-export-e-html + :type 'string) + + +;;;; Template :: Generic + +(defcustom org-e-html-extension "html" + "The extension for exported HTML files." + :group 'org-export-e-html + :type 'string) + +(defcustom org-e-html-xml-declaration + '(("html" . "") + ("php" . "\"; ?>")) + "The extension for exported HTML files. +%s will be replaced with the charset of the exported file. +This may be a string, or an alist with export extensions +and corresponding declarations." + :group 'org-export-e-html + :type '(choice + (string :tag "Single declaration") + (repeat :tag "Dependent on extension" + (cons (string :tag "Extension") + (string :tag "Declaration"))))) + +(defcustom org-e-html-coding-system 'utf-8 + "Coding system for HTML export. +Use utf-8 as the default value." + :group 'org-export-e-html + :type 'coding-system) + +(defcustom org-e-html-divs '("preamble" "content" "postamble") + "The name of the main divs for HTML export. +This is a list of three strings, the first one for the preamble +DIV, the second one for the content DIV and the third one for the +postamble DIV." + :group 'org-export-e-html + :type '(list + (string :tag " Div for the preamble:") + (string :tag " Div for the content:") + (string :tag "Div for the postamble:"))) + + +;;;; Template :: Mathjax + +(defcustom org-e-html-mathjax-options + '((path "http://orgmode.org/mathjax/MathJax.js") + (scale "100") + (align "center") + (indent "2em") + (mathml nil)) + "Options for MathJax setup. + +path The path where to find MathJax +scale Scaling for the HTML-CSS backend, usually between 100 and 133 +align How to align display math: left, center, or right +indent If align is not center, how far from the left/right side? +mathml Should a MathML player be used if available? + This is faster and reduces bandwidth use, but currently + sometimes has lower spacing quality. Therefore, the default is + nil. When browsers get better, this switch can be flipped. + +You can also customize this for each buffer, using something like + +#+MATHJAX: scale:\"133\" align:\"right\" mathml:t path:\"/MathJax/\"" + :group 'org-export-e-html + :type '(list :greedy t + (list :tag "path (the path from where to load MathJax.js)" + (const :format " " path) (string)) + (list :tag "scale (scaling for the displayed math)" + (const :format " " scale) (string)) + (list :tag "align (alignment of displayed equations)" + (const :format " " align) (string)) + (list :tag "indent (indentation with left or right alignment)" + (const :format " " indent) (string)) + (list :tag "mathml (should MathML display be used is possible)" + (const :format " " mathml) (boolean)))) + +(defcustom org-e-html-mathjax-template + "" + "The MathJax setup for XHTML files." + :group 'org-export-e-html + :type 'string) + + +;;;; Template :: Postamble + +(defcustom org-e-html-postamble 'auto + "Non-nil means insert a postamble in HTML export. + +When `t', insert a string as defined by the formatting string in +`org-e-html-postamble-format'. When set to a string, this +string overrides `org-e-html-postamble-format'. When set to +'auto, discard `org-e-html-postamble-format' and honor +`org-export-author/email/creator-info' variables. When set to a +function, apply this function and insert the returned string. +The function takes the property list of export options as its +only argument. + +Setting :html-postamble in publishing projects will take +precedence over this variable." + :group 'org-export-e-html + :type '(choice (const :tag "No postamble" nil) + (const :tag "Auto preamble" 'auto) + (const :tag "Default formatting string" t) + (string :tag "Custom formatting string") + (function :tag "Function (must return a string)"))) + +(defcustom org-e-html-postamble-format + '(("en" "

Author: %a (%e)

+

Date: %d

+

Generated by %c

+

%v

+")) + "The format for the HTML postamble. + +%a stands for the author's name. +%e stands for the author's email. +%d stands for the date. +%c will be replaced by information about Org/Emacs versions. +%v will be replaced by `org-e-html-validation-link'. + +If you need to use a \"%\" character, you need to escape it +like that: \"%%\"." + :group 'org-export-e-html + :type 'string) + +(defcustom org-e-html-validation-link + "Validate XHTML 1.0" + "Link to HTML validation service." + :group 'org-export-e-html + :type 'string) + +(defcustom org-e-html-creator-string + (format "Generated by Org mode %s in Emacs %s." + (if (fboundp 'org-version) (org-version) "(Unknown)") + emacs-version) + "String to insert at the end of the HTML document." + :group 'org-export-e-html + :type '(string :tag "Creator string")) + + +;;;; Template :: Preamble + +(defcustom org-e-html-preamble t + "Non-nil means insert a preamble in HTML export. + +When `t', insert a string as defined by one of the formatting +strings in `org-e-html-preamble-format'. When set to a +string, this string overrides `org-e-html-preamble-format'. +When set to a function, apply this function and insert the +returned string. The function takes the property list of export +options as its only argument. + +Setting :html-preamble in publishing projects will take +precedence over this variable." + :group 'org-export-e-html + :type '(choice (const :tag "No preamble" nil) + (const :tag "Default preamble" t) + (string :tag "Custom formatting string") + (function :tag "Function (must return a string)"))) + +(defcustom org-e-html-preamble-format '(("en" "")) + "The format for the HTML preamble. + +%t stands for the title. +%a stands for the author's name. +%e stands for the author's email. +%d stands for the date. + +If you need to use a \"%\" character, you need to escape it +like that: \"%%\"." + :group 'org-export-e-html + :type 'string) + +(defcustom org-e-html-link-up "" + "Where should the \"UP\" link of exported HTML pages lead?" + :group 'org-export-e-html + :type '(string :tag "File or URL")) + +(defcustom org-e-html-link-home "" + "Where should the \"HOME\" link of exported HTML pages lead?" + :group 'org-export-e-html + :type '(string :tag "File or URL")) + +(defcustom org-e-html-home/up-format + "
+ UP + | + HOME +
" + "Snippet used to insert the HOME and UP links. +This is a format string, the first %s will receive the UP link, +the second the HOME link. If both `org-e-html-link-up' and +`org-e-html-link-home' are empty, the entire snippet will be +ignored." + :group 'org-export-e-html + :type 'string) + + +;;;; Template :: Scripts + +(defcustom org-e-html-style-include-scripts t + "Non-nil means include the JavaScript snippets in exported HTML files. +The actual script is defined in `org-e-html-scripts' and should +not be modified." + :group 'org-export-e-html + :type 'boolean) + + +;;;; Template :: Styles + +(defcustom org-e-html-style-include-default t + "Non-nil means include the default style in exported HTML files. +The actual style is defined in `org-e-html-style-default' and should +not be modified. Use the variables `org-e-html-style' to add +your own style information." + :group 'org-export-e-html + :type 'boolean) +;;;###autoload +(put 'org-e-html-style-include-default 'safe-local-variable 'booleanp) + +(defcustom org-e-html-style "" + "Org-wide style definitions for exported HTML files. + +This variable needs to contain the full HTML structure to provide a style, +including the surrounding HTML tags. If you set the value of this variable, +you should consider to include definitions for the following classes: + title, todo, done, timestamp, timestamp-kwd, tag, target. + +For example, a valid value would be: + + + +If you'd like to refer to an external style file, use something like + + + +As the value of this option simply gets inserted into the HTML header, +you can \"misuse\" it to add arbitrary text to the header. +See also the variable `org-e-html-style-extra'." + :group 'org-export-e-html + :type 'string) +;;;###autoload +(put 'org-e-html-style 'safe-local-variable 'stringp) + +(defcustom org-e-html-style-extra "" + "Additional style information for HTML export. +The value of this variable is inserted into the HTML buffer right after +the value of `org-e-html-style'. Use this variable for per-file +settings of style information, and do not forget to surround the style +settings with tags." + :group 'org-export-e-html + :type 'string) +;;;###autoload +(put 'org-e-html-style-extra 'safe-local-variable 'stringp) + + +;;;; Todos + +(defcustom org-e-html-todo-kwd-class-prefix "" + "Prefix to class names for TODO keywords. +Each TODO keyword gets a class given by the keyword itself, with this prefix. +The default prefix is empty because it is nice to just use the keyword +as a class name. But if you get into conflicts with other, existing +CSS classes, then this prefix can be very useful." + :group 'org-export-e-html + :type 'string) + + + +;;; Internal Functions + +(defun org-e-html-format-inline-image (src &optional + caption label attr standalone-p) + (let* ((id (if (not label) "" + (format " id=\"%s\"" (org-export-solidify-link-text label)))) + (attr (concat attr + (cond + ((string-match "\\" src attr))) + (format "\n%s%s\n" + id (format "\n

%s

" img) + (when caption (format "\n

%s

" caption))))) + (t (format "" src (concat attr id)))))) + +;;;; Bibliography + +(defun org-e-html-bibliography () + "Find bibliography, cut it out and return it." + (catch 'exit + (let (beg end (cnt 1) bib) + (save-excursion + (goto-char (point-min)) + (when (re-search-forward + "^[ \t]*
" nil t) + (setq cnt (+ cnt (if (string= (match-string 0) "") (forward-char 1)) + (setq bib (buffer-substring beg (point))) + (delete-region beg (point)) + (throw 'exit bib)))) + nil)))) + +;;;; Table + +(defun org-e-html-splice-attributes (tag attributes) + "Read attributes in string ATTRIBUTES, add and replace in HTML tag TAG." + (if (not attributes) + tag + (let (oldatt newatt) + (setq oldatt (org-extract-attributes-from-string tag) + tag (pop oldatt) + newatt (cdr (org-extract-attributes-from-string attributes))) + (while newatt + (setq oldatt (plist-put oldatt (pop newatt) (pop newatt)))) + (if (string-match ">" tag) + (setq tag + (replace-match (concat (org-attributes-to-string oldatt) ">") + t t tag))) + tag))) + +(defun org-export-splice-style (style extra) + "Splice EXTRA into STYLE, just before \"\"." + (if (and (stringp extra) + (string-match "\\S-" extra) + (string-match "" style)) + (concat (substring style 0 (match-beginning 0)) + "\n" extra "\n" + (substring style (match-beginning 0))) + style)) + +(defun org-export-e-htmlize-region-for-paste (beg end) + "Convert the region to HTML, using htmlize.el. +This is much like `htmlize-region-for-paste', only that it uses +the settings define in the org-... variables." + (let* ((htmlize-output-type org-export-e-htmlize-output-type) + (htmlize-css-name-prefix org-export-e-htmlize-css-font-prefix) + (htmlbuf (htmlize-region beg end))) + (unwind-protect + (with-current-buffer htmlbuf + (buffer-substring (plist-get htmlize-buffer-places 'content-start) + (plist-get htmlize-buffer-places 'content-end))) + (kill-buffer htmlbuf)))) + +;;;###autoload +(defun org-export-e-htmlize-generate-css () + "Create the CSS for all font definitions in the current Emacs session. +Use this to create face definitions in your CSS style file that can then +be used by code snippets transformed by htmlize. +This command just produces a buffer that contains class definitions for all +faces used in the current Emacs session. You can copy and paste the ones you +need into your CSS file. + +If you then set `org-export-e-htmlize-output-type' to `css', calls to +the function `org-export-e-htmlize-region-for-paste' will produce code +that uses these same face definitions." + (interactive) + (require 'htmlize) + (and (get-buffer "*html*") (kill-buffer "*html*")) + (with-temp-buffer + (let ((fl (face-list)) + (htmlize-css-name-prefix "org-") + (htmlize-output-type 'css) + f i) + (while (setq f (pop fl) + i (and f (face-attribute f :inherit))) + (when (and (symbolp f) (or (not i) (not (listp i)))) + (insert (org-add-props (copy-sequence "1") nil 'face f)))) + (htmlize-region (point-min) (point-max)))) + (org-pop-to-buffer-same-window "*html*") + (goto-char (point-min)) + (if (re-search-forward "" nil t) + (delete-region (1+ (match-end 0)) (point-max))) + (beginning-of-line 1) + (if (looking-at " +") (replace-match "")) + (goto-char (point-min))) + +(defun org-e-html-make-string (n string) + (let (out) (dotimes (i n out) (setq out (concat string out))))) + +(defun org-e-html-toc-text (toc-entries) + (let* ((prev-level (1- (nth 1 (car toc-entries)))) + (start-level prev-level)) + (concat + (mapconcat + (lambda (entry) + (let ((headline (nth 0 entry)) + (level (nth 1 entry))) + (concat + (let* ((cnt (- level prev-level)) + (times (if (> cnt 0) (1- cnt) (- cnt))) + rtn) + (setq prev-level level) + (concat + (org-e-html-make-string + times (cond ((> cnt 0) "\n
    \n
  • ") + ((< cnt 0) "
  • \n
\n"))) + (if (> cnt 0) "\n
    \n
  • " "
  • \n
  • "))) + headline))) + toc-entries "") + (org-e-html-make-string + (- prev-level start-level) "
  • \n
\n")))) + +(defun* org-e-html-format-toc-headline + (todo todo-type priority text tags + &key level section-number headline-label &allow-other-keys) + (let ((headline (concat + section-number (and section-number ". ") + text + (and tags "   ") (org-e-html--tags tags)))) + (format "%s" + (org-export-solidify-link-text headline-label) + (if (not nil) headline + (format "%s" todo-type headline))))) + +(defun org-e-html-toc (depth info) + (let* ((headlines (org-export-collect-headlines info depth)) + (toc-entries + (loop for headline in headlines collect + (list (org-e-html-format-headline--wrap + headline info 'org-e-html-format-toc-headline) + (org-export-get-relative-level headline info))))) + (when toc-entries + (concat + "
\n" + (format "%s\n" + org-e-html-toplevel-hlevel + (org-e-html--translate "Table of Contents" info) + org-e-html-toplevel-hlevel) + "
" + (org-e-html-toc-text toc-entries) + "
\n" + "
\n")))) + +(defun org-e-html-fix-class-name (kwd) ; audit callers of this function + "Turn todo keyword into a valid class name. +Replaces invalid characters with \"_\"." + (save-match-data + (while (string-match "[^a-zA-Z0-9_]" kwd) + (setq kwd (replace-match "_" t t kwd)))) + kwd) + +(defun org-e-html-format-footnote-reference (n def refcnt) + (let ((extra (if (= refcnt 1) "" (format ".%d" refcnt)))) + (format org-e-html-footnote-format + (let* ((id (format "fnr.%s%s" n extra)) + (href (format " href=\"#fn.%s\"" n)) + (attributes (concat " class=\"footref\"" href))) + (org-e-html--anchor id n attributes))))) + +(defun org-e-html-format-footnotes-section (section-name definitions) + (if (not definitions) "" + (format org-e-html-footnotes-section section-name definitions))) + +(defun org-e-html-format-footnote-definition (fn) + (let ((n (car fn)) (def (cdr fn))) + (format + "
\n\n\n\n" + (format org-e-html-footnote-format + (let* ((id (format "fn.%s" n)) + (href (format " href=\"#fnr.%s\"" n)) + (attributes (concat " class=\"footnum\"" href))) + (org-e-html--anchor id n attributes))) + def))) + +(defun org-e-html-footnote-section (info) + (let* ((fn-alist (org-export-collect-footnote-definitions + (plist-get info :parse-tree) info)) + + (fn-alist + (loop for (n type raw) in fn-alist collect + (cons n (if (eq (org-element-type raw) 'org-data) + (org-trim (org-export-data raw info)) + (format "

%s

" + (org-trim (org-export-data raw info)))))))) + (when fn-alist + (org-e-html-format-footnotes-section + (org-e-html--translate "Footnotes" info) + (format + "
" . "
%s%s
\n%s\n
\n" + (mapconcat 'org-e-html-format-footnote-definition fn-alist "\n")))))) + +(defun org-e-html-format-date (info) + (let ((date (org-export-data (plist-get info :date) info))) + (cond + ((and date (string-match "%" date)) + (format-time-string date)) + (date date) + (t (format-time-string "%Y-%m-%d %T %Z"))))) + +(defun org-e-html--caption/label-string (caption label info) + "Return caption and label HTML string for floats. + +CAPTION is a cons cell of secondary strings, the car being the +standard caption and the cdr its short form. LABEL is a string +representing the label. INFO is a plist holding contextual +information. + +If there's no caption nor label, return the empty string. + +For non-floats, see `org-e-html--wrap-label'." + (setq label nil) ;; FIXME + + (let ((label-str (if label (format "\\label{%s}" label) ""))) + (cond + ((and (not caption) (not label)) "") + ((not caption) (format "\\label{%s}\n" label)) + ;; Option caption format with short name. + ((cdr caption) + (format "\\caption[%s]{%s%s}\n" + (org-export-data (cdr caption) info) + label-str + (org-export-data (car caption) info))) + ;; Standard caption format. + ;; (t (format "\\caption{%s%s}\n" + ;; label-str + ;; (org-export-data (car caption) info))) + (t (org-export-data (car caption) info))))) + +(defun org-e-html--find-verb-separator (s) + "Return a character not used in string S. +This is used to choose a separator for constructs like \\verb." + (let ((ll "~,./?;':\"|!@#%^&-_=+abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ<>()[]{}")) + (loop for c across ll + when (not (string-match (regexp-quote (char-to-string c)) s)) + return (char-to-string c)))) + +(defun org-e-html--quotation-marks (text info) + "Export quotation marks depending on language conventions. +TEXT is a string containing quotation marks to be replaced. INFO +is a plist used as a communication channel." + (mapc (lambda(l) + (let ((start 0)) + (while (setq start (string-match (car l) text start)) + (let ((new-quote (concat (match-string 1 text) (cdr l)))) + (setq text (replace-match new-quote t t text)))))) + (cdr (or (assoc (plist-get info :language) org-e-html-quotes) + ;; Falls back on English. + (assoc "en" org-e-html-quotes)))) + text) + +(defun org-e-html--wrap-label (element output) + "Wrap label associated to ELEMENT around OUTPUT, if appropriate. +This function shouldn't be used for floats. See +`org-e-html--caption/label-string'." + ;; (let ((label (org-element-property :name element))) + ;; (if (or (not output) (not label) (string= output "") (string= label "")) + ;; output + ;; (concat (format "\\label{%s}\n" label) output))) + output) + + + +;;; Template + +(defun org-e-html-meta-info (info) + (let* ((title (org-export-data (plist-get info :title) info)) + (author (and (plist-get info :with-author) + (let ((auth (plist-get info :author))) + (and auth (org-export-data auth info))))) + (description (plist-get info :description)) + (keywords (plist-get info :keywords))) + (concat + (format "\n%s\n" title) + (format + "\n" + (or (and org-e-html-coding-system + (fboundp 'coding-system-get) + (coding-system-get org-e-html-coding-system + 'mime-charset)) + "iso-8859-1")) + (format "\n" title) + (format "\n") + (format "\n" + (org-e-html-format-date info)) + (format "\n" author) + (format "\n" description) + (format "\n" keywords)))) + +(defun org-e-html-style (info) + (concat + "\n" (when (plist-get info :style-include-default) org-e-html-style-default) + (plist-get info :style) + (plist-get info :style-extra) + "\n" + (when (plist-get info :style-include-scripts) + org-e-html-scripts))) + +(defun org-e-html-mathjax-config (info) + "Insert the user setup into the matchjax template." + (when (member (plist-get info :LaTeX-fragments) '(mathjax t)) + (let ((template org-e-html-mathjax-template) + (options org-e-html-mathjax-options) + (in-buffer (or (plist-get info :mathjax) "")) + name val (yes " ") (no "// ") x) + (mapc + (lambda (e) + (setq name (car e) val (nth 1 e)) + (if (string-match (concat "\\<" (symbol-name name) ":") in-buffer) + (setq val (car (read-from-string + (substring in-buffer (match-end 0)))))) + (if (not (stringp val)) (setq val (format "%s" val))) + (if (string-match (concat "%" (upcase (symbol-name name))) template) + (setq template (replace-match val t t template)))) + options) + (setq val (nth 1 (assq 'mathml options))) + (if (string-match (concat "\\ " (nth 0 org-e-html-divs)) + " +" + html-pre-real-contents + " +"))))) + +(defun org-e-html-postamble (info) + (concat + (when (and (not body-only) + (plist-get info :html-postamble)) + (let* ((html-post (plist-get info :html-postamble)) + (date (org-e-html-format-date info)) + (author (let ((author (plist-get info :author))) + (and author (org-export-data author info)))) + (email + (mapconcat (lambda(e) + (format "%s" e e)) + (split-string (plist-get info :email) ",+ *") + ", ")) + (html-validation-link (or org-e-html-validation-link "")) + (creator-info org-export-creator-string)) + (concat + ;; begin postamble + " +
" + (cond + ;; auto postamble + ((eq (plist-get info :html-postamble) 'auto) + (concat + (when (plist-get info :time-stamp-file) + (format " +

%s: %s

" (org-e-html--translate "Date" info) date)) + (when (and (plist-get info :with-author) author) + (format " +

%s : %s

" (org-e-html--translate "Author" info) author)) + (when (and (plist-get info :with-email) email) + (format " +

%s

" email)) + (when (plist-get info :with-creator) + (format " +

%s

" creator-info)) + html-validation-link "\n")) + ;; postamble from a string + ((stringp (plist-get info :html-postamble)) + (format-spec (plist-get info :html-postamble) + `((?a . ,author) (?e . ,email) + (?d . ,date) (?c . ,creator-info) + (?v . ,html-validation-link)))) + + ;; postamble from a function + ((functionp (plist-get info :html-postamble)) + (with-temp-buffer + (funcall (plist-get info :html-postamble)) + (buffer-string))) + ;; default postamble + (t + (format-spec + (or (cadr (assoc (plist-get info :language) + org-e-html-postamble-format)) + (cadr (assoc "en" org-e-html-postamble-format))) + `((?a . ,author) (?e . ,email) + (?d . ,date) (?c . ,creator-info) + (?v . ,html-validation-link))))) + " +
"))) + ;; org-e-html-html-helper-timestamp + )) + +(defun org-e-html-template (contents info) + "Return complete document string after HTML conversion. +CONTENTS is the transcoded contents string. RAW-DATA is the +original parsed data. INFO is a plist holding export options." + (concat + (format + (or (and (stringp org-e-html-xml-declaration) + org-e-html-xml-declaration) + (cdr (assoc (plist-get info :html-extension) + org-e-html-xml-declaration)) + (cdr (assoc "html" org-e-html-xml-declaration)) + + "") + (or (and org-e-html-coding-system + (fboundp 'coding-system-get) + (coding-system-get org-e-html-coding-system + 'mime-charset)) + "iso-8859-1")) + " +" + (format " + " + (plist-get info :language) (plist-get info :language)) + " +" + (org-e-html-meta-info info) ; meta + (org-e-html-style info) ; style + (org-e-html-mathjax-config info) ; mathjax + " +" + + " +" + (let ((link-up (org-trim (plist-get info :link-up))) + (link-home (org-trim (plist-get info :link-home)))) + (unless (and (string= link-up "") (string= link-up "")) + (format org-e-html-home/up-format + (or link-up link-home) + (or link-home link-up)))) + ;; preamble + (org-e-html-preamble info) + ;; begin content + (format " +
" (or org-e-html-content-div + (nth 1 org-e-html-divs))) + ;; document title + (format " +

%s

\n" (org-export-data (plist-get info :title) info)) + ;; table of contents + (let ((depth (plist-get info :with-toc))) + (when depth (org-e-html-toc depth info))) + ;; document contents + contents + ;; footnotes section + (org-e-html-footnote-section info) + ;; bibliography + (org-e-html-bibliography) + ;; end content + (unless body-only + " +
") + + ;; postamble + (org-e-html-postamble info) + + (unless body-only + " +") + " +")) + +(defun org-e-html--translate (s info) + "Transcode string S in to HTML. +INFO is a plist used as a communication channel. + +Lookup utf-8 equivalent of S in `org-export-dictionary' and +replace all non-ascii characters with its numeric reference." + (let ((s (org-export-translate s :utf-8 info))) + ;; Protect HTML metacharacters. + (setq s (org-e-html-encode-plain-text s)) + ;; Replace non-ascii characters with their numeric equivalents. + (replace-regexp-in-string + "[[:nonascii:]]" + (lambda (m) (format "&#%d;" (encode-char (string-to-char m) 'ucs))) + s t t))) + +;;;; Anchor + +(defun org-e-html--anchor (&optional id desc attributes) + (let* ((name (and org-e-html-allow-name-attribute-in-anchors id)) + (attributes (concat (and id (format " id=\"%s\"" id)) + (and name (format " name=\"%s\"" name)) + attributes))) + (format "%s" attributes (or desc "")))) + +;;;; Todo + +(defun org-e-html--todo (todo) + (when todo + (format "%s" + (if (member todo org-done-keywords) "done" "todo") + org-e-html-todo-kwd-class-prefix (org-e-html-fix-class-name todo) + todo))) + +;;;; Tags + +(defun org-e-html--tags (tags) + (when tags + (format "%s" + (mapconcat + (lambda (tag) + (format "%s" + (concat org-e-html-tag-class-prefix + (org-e-html-fix-class-name tag)) + tag)) + tags " ")))) + +;;;; Headline + +(defun* org-e-html-format-headline + (todo todo-type priority text tags + &key level section-number headline-label &allow-other-keys) + (let ((section-number + (when section-number + (format "%s " + level section-number))) + (todo (org-e-html--todo todo)) + (tags (org-e-html--tags tags))) + (concat section-number todo (and todo " ") text + (and tags "   ") tags))) + +;;;; Src Code + +(defun org-e-html-fontify-code (code lang) + (when code + (cond + ;; Case 1: No lang. Possibly an example block. + ((not lang) + ;; Simple transcoding. + (org-e-html-encode-plain-text code)) + ;; Case 2: No htmlize or an inferior version of htmlize + ((not (and (require 'htmlize nil t) (fboundp 'htmlize-region-for-paste))) + ;; Emit a warning. + (message "Cannot fontify src block (htmlize.el >= 1.34 required)") + ;; Simple transcoding. + (org-e-html-encode-plain-text code)) + (t + ;; Map language + (setq lang (or (assoc-default lang org-src-lang-modes) lang)) + (let* ((lang-mode (and lang (intern (format "%s-mode" lang))))) + (cond + ;; Case 1: Language is not associated with any Emacs mode + ((not (functionp lang-mode)) + ;; Simple transcoding. + (org-e-html-encode-plain-text code)) + ;; Case 2: Default. Fontify code. + (t + ;; htmlize + (setq code (with-temp-buffer + (insert code) + ;; Switch to language-specific mode. + (funcall lang-mode) + ;; Fontify buffer. + (font-lock-fontify-buffer) + ;; Remove formatting on newline characters. + (save-excursion + (let ((beg (point-min)) + (end (point-max))) + (goto-char beg) + (while (progn (end-of-line) (< (point) end)) + (put-text-property (point) (1+ (point)) 'face nil) + (forward-char 1)))) + (org-src-mode) + (set-buffer-modified-p nil) + ;; Htmlize region. + (org-export-e-htmlize-region-for-paste + (point-min) (point-max)))) + ;; Strip any encolosing
 tags.
+	  (if (string-match "]*>\n*\\([^\000]*\\)

" code) + (match-string 1 code) + code)))))))) + +(defun org-e-html-do-format-code + (code &optional lang refs retain-labels num-start textarea-p) + (when textarea-p + (setq num-start nil refs nil lang nil)) + (let* ((code-lines (org-split-string code "\n")) + (code-length (length code-lines)) + (num-fmt + (and num-start + (format "%%%ds: " + (length (number-to-string (+ code-length num-start)))))) + (code (org-e-html-fontify-code code lang))) + (assert (= code-length (length (org-split-string code "\n")))) + (org-export-format-code + code + (lambda (loc line-num ref) + (setq loc + (concat + ;; Add line number, if needed. + (when num-start + (format "%s" + (format num-fmt line-num))) + ;; Transcoded src line. + loc + ;; Add label, if needed. + (when (and ref retain-labels) (format " (%s)" ref)))) + ;; Mark transcoded line as an anchor, if needed. + (if (not ref) loc + (format "%s" + ref loc))) + num-start refs))) + +(defun org-e-html-format-code (element info) + (let* ((lang (org-element-property :language element)) + ;; (switches (org-element-property :switches element)) + (switches nil) ; FIXME + (textarea-p (and switches (string-match "-t\\>" switches))) + ;; Extract code and references. + (code-info (org-export-unravel-code element)) + (code (car code-info)) + (refs (cdr code-info)) + ;; Does the src block contain labels? + (retain-labels (org-element-property :retain-labels element)) + ;; Does it have line numbers? + (num-start (case (org-element-property :number-lines element) + (continued (org-export-get-loc element info)) + (new 0)))) + (org-e-html-do-format-code + code lang refs retain-labels num-start textarea-p))) + + + +;;; Transcode Functions + +;;;; Bold + +(defun org-e-html-bold (bold contents info) + "Transcode BOLD from Org to HTML. +CONTENTS is the text with bold markup. INFO is a plist holding +contextual information." + (format (or (cdr (assq 'bold org-e-html-text-markup-alist)) "%s") + contents)) + + +;;;; Center Block + +(defun org-e-html-center-block (center-block contents info) + "Transcode a CENTER-BLOCK element from Org to HTML. +CONTENTS holds the contents of the block. INFO is a plist +holding contextual information." + (org-e-html--wrap-label + center-block + (format "
\n%s
" contents))) + + +;;;; Clock + +(defun org-e-html-clock (clock contents info) + "Transcode a CLOCK element from Org to HTML. +CONTENTS is nil. INFO is a plist used as a communication +channel." + (format "

+ +%s %s%s + +

" + org-clock-string + (org-translate-time (org-element-property :value clock)) + (let ((time (org-element-property :time clock))) + (and time (format " (%s)" time))))) + + +;;;; Code + +(defun org-e-html-code (code contents info) + "Transcode CODE from Org to HTML. +CONTENTS is nil. INFO is a plist holding contextual +information." + (format (or (cdr (assq 'code org-e-html-text-markup-alist)) "%s") + (org-element-property :value code))) + + +;;;; Comment + +;; Comments are ignored. + + +;;;; Comment Block + +;; Comment Blocks are ignored. + + +;;;; Drawer + +(defun org-e-html-drawer (drawer contents info) + "Transcode a DRAWER element from Org to HTML. +CONTENTS holds the contents of the block. INFO is a plist +holding contextual information." + (let* ((name (org-element-property :drawer-name drawer)) + (output (if (functionp org-e-html-format-drawer-function) + (funcall org-e-html-format-drawer-function + name contents) + ;; If there's no user defined function: simply + ;; display contents of the drawer. + contents))) + (org-e-html--wrap-label drawer output))) + + +;;;; Dynamic Block + +(defun org-e-html-dynamic-block (dynamic-block contents info) + "Transcode a DYNAMIC-BLOCK element from Org to HTML. +CONTENTS holds the contents of the block. INFO is a plist +holding contextual information. See `org-export-data'." + (org-e-html--wrap-label dynamic-block contents)) + + +;;;; Entity + +(defun org-e-html-entity (entity contents info) + "Transcode an ENTITY object from Org to HTML. +CONTENTS are the definition itself. INFO is a plist holding +contextual information." + (org-element-property :html entity)) + + +;;;; Example Block + +(defun org-e-html-example-block (example-block contents info) + "Transcode a EXAMPLE-BLOCK element from Org to HTML. +CONTENTS is nil. INFO is a plist holding contextual information." + (let* ((options (or (org-element-property :options example-block) "")) + (lang (org-element-property :language example-block)) + (caption (org-element-property :caption example-block)) + (label (org-element-property :name example-block)) + (caption-str (org-e-html--caption/label-string caption label info)) + (attr (mapconcat #'identity + (org-element-property :attr_html example-block) + " ")) + ;; (switches (org-element-property :switches example-block)) + (switches nil) ; FIXME + (textarea-p (and switches (string-match "-t\\>" switches))) + (code (org-e-html-format-code example-block info))) + (cond + (textarea-p + (let ((cols (if (not (string-match "-w[ \t]+\\([0-9]+\\)" switches)) + 80 (string-to-number (match-string 1 switches)))) + (rows (if (string-match "-h[ \t]+\\([0-9]+\\)" switches) + (string-to-number (match-string 1 switches)) + (org-count-lines code)))) + (format + "

\n\n

" + cols rows code))) + (t (format "
\n%s
" code))))) + + +;;;; Export Snippet + +(defun org-e-html-export-snippet (export-snippet contents info) + "Transcode a EXPORT-SNIPPET object from Org to HTML. +CONTENTS is nil. INFO is a plist holding contextual information." + (when (eq (org-export-snippet-backend export-snippet) 'e-html) + (org-element-property :value export-snippet))) + + +;;;; Export Block + +(defun org-e-html-export-block (export-block contents info) + "Transcode a EXPORT-BLOCK element from Org to HTML. +CONTENTS is nil. INFO is a plist holding contextual information." + (when (string= (org-element-property :type export-block) "HTML") + (org-remove-indentation (org-element-property :value export-block)))) + + +;;;; Fixed Width + +(defun org-e-html-fixed-width (fixed-width contents info) + "Transcode a FIXED-WIDTH element from Org to HTML. +CONTENTS is nil. INFO is a plist holding contextual information." + (org-e-html--wrap-label + fixed-width + (format "
\n%s
" + (org-e-html-do-format-code + (org-remove-indentation + (org-element-property :value fixed-width)))))) + + +;;;; Footnote Definition + +;; Footnote Definitions are ignored. + + +;;;; Footnote Reference + +(defun org-e-html-footnote-reference (footnote-reference contents info) + "Transcode a FOOTNOTE-REFERENCE element from Org to HTML. +CONTENTS is nil. INFO is a plist holding contextual information." + (concat + ;; Insert separator between two footnotes in a row. + (let ((prev (org-export-get-previous-element footnote-reference info))) + (when (eq (org-element-type prev) 'footnote-reference) + org-e-html-footnote-separator)) + (cond + ((not (org-export-footnote-first-reference-p footnote-reference info)) + (org-e-html-format-footnote-reference + (org-export-get-footnote-number footnote-reference info) + "IGNORED" 100)) + ;; Inline definitions are secondary strings. + ((eq (org-element-property :type footnote-reference) 'inline) + (org-e-html-format-footnote-reference + (org-export-get-footnote-number footnote-reference info) + "IGNORED" 1)) + ;; Non-inline footnotes definitions are full Org data. + (t (org-e-html-format-footnote-reference + (org-export-get-footnote-number footnote-reference info) + "IGNORED" 1))))) + + +;;;; Headline + +(defun org-e-html-format-headline--wrap (headline info + &optional format-function + &rest extra-keys) + "Transcode an HEADLINE element from Org to HTML. +CONTENTS holds the contents of the headline. INFO is a plist +holding contextual information." + (let* ((level (+ (org-export-get-relative-level headline info) + (1- org-e-html-toplevel-hlevel))) + (headline-number (org-export-get-headline-number headline info)) + (section-number (and (org-export-numbered-headline-p headline info) + (mapconcat 'number-to-string + headline-number "."))) + (todo (and (plist-get info :with-todo-keywords) + (let ((todo (org-element-property :todo-keyword headline))) + (and todo (org-export-data todo info))))) + (todo-type (and todo (org-element-property :todo-type headline))) + (priority (and (plist-get info :with-priority) + (org-element-property :priority headline))) + (text (org-export-data (org-element-property :title headline) info)) + (tags (and (plist-get info :with-tags) + (org-export-get-tags headline info))) + (headline-label (or (org-element-property :custom-id headline) + (concat "sec-" (mapconcat 'number-to-string + headline-number "-")))) + (format-function (cond + ((functionp format-function) format-function) + ((functionp org-e-html-format-headline-function) + (function* + (lambda (todo todo-type priority text tags + &allow-other-keys) + (funcall org-e-html-format-headline-function + todo todo-type priority text tags)))) + (t 'org-e-html-format-headline)))) + (apply format-function + todo todo-type priority text tags + :headline-label headline-label :level level + :section-number section-number extra-keys))) + +(defun org-e-html-headline (headline contents info) + "Transcode an HEADLINE element from Org to HTML. +CONTENTS holds the contents of the headline. INFO is a plist +holding contextual information." + ;; Empty contents? + (setq contents (or contents "")) + (let* ((numberedp (org-export-numbered-headline-p headline info)) + (level (org-export-get-relative-level headline info)) + (text (org-export-data (org-element-property :title headline) info)) + (todo (and (plist-get info :with-todo-keywords) + (let ((todo (org-element-property :todo-keyword headline))) + (and todo (org-export-data todo info))))) + (todo-type (and todo (org-element-property :todo-type headline))) + (tags (and (plist-get info :with-tags) + (org-export-get-tags headline info))) + (priority (and (plist-get info :with-priority) + (org-element-property :priority headline))) + (section-number (and (org-export-numbered-headline-p headline info) + (mapconcat 'number-to-string + (org-export-get-headline-number + headline info) "."))) + ;; Create the headline text. + (full-text (org-e-html-format-headline--wrap headline info))) + (cond + ;; Case 1: This is a footnote section: ignore it. + ((org-element-property :footnote-section-p headline) nil) + ;; Case 2. This is a deep sub-tree: export it as a list item. + ;; Also export as items headlines for which no section + ;; format has been found. + ((org-export-low-level-p headline info) ; FIXME (or (not section-fmt)) + ;; Build the real contents of the sub-tree. + (let* ((type (if numberedp 'unordered 'unordered)) ; FIXME + (itemized-body (org-e-html-format-list-item + contents type nil nil full-text))) + (concat + (and (org-export-first-sibling-p headline info) + (org-e-html-begin-plain-list type)) + itemized-body + (and (org-export-last-sibling-p headline info) + (org-e-html-end-plain-list type))))) + ;; Case 3. Standard headline. Export it as a section. + (t + (let* ((section-number (mapconcat 'number-to-string + (org-export-get-headline-number + headline info) "-")) + (ids (remove 'nil + (list (org-element-property :custom-id headline) + (concat "sec-" section-number) + (org-element-property :id headline)))) + (preferred-id (car ids)) + (extra-ids (cdr ids)) + (extra-class (org-element-property :html-container-class headline)) + (level1 (+ level (1- org-e-html-toplevel-hlevel)))) + (format "
%s%s
\n" + (format "outline-container-%s" + (or (org-element-property :custom-id headline) + section-number)) + (concat (format "outline-%d" level1) (and extra-class " ") + extra-class) + (format "\n%s%s\n" + level1 + preferred-id + (mapconcat + (lambda (x) + (let ((id (org-export-solidify-link-text + (if (org-uuidgen-p x) (concat "ID-" x) + x)))) + (org-e-html--anchor id))) + extra-ids "") + full-text + level1) + contents)))))) + + +;;;; Horizontal Rule + +(defun org-e-html-horizontal-rule (horizontal-rule contents info) + "Transcode an HORIZONTAL-RULE object from Org to HTML. +CONTENTS is nil. INFO is a plist holding contextual information." + (let ((attr (mapconcat #'identity + (org-element-property :attr_html horizontal-rule) + " "))) + (org-e-html--wrap-label horizontal-rule "
"))) + + +;;;; Inline Babel Call + +;; Inline Babel Calls are ignored. + + +;;;; Inline Src Block + +(defun org-e-html-inline-src-block (inline-src-block contents info) + "Transcode an INLINE-SRC-BLOCK element from Org to HTML. +CONTENTS holds the contents of the item. INFO is a plist holding +contextual information." + (let* ((org-lang (org-element-property :language inline-src-block)) + (code (org-element-property :value inline-src-block)) + (separator (org-e-html--find-verb-separator code))) + (error "FIXME"))) + + +;;;; Inlinetask + +(defun org-e-html-format-section (text class &optional id) + (let ((extra (concat (when id (format " id=\"%s\"" id))))) + (concat (format "
\n" class extra) text "
\n"))) + +(defun org-e-html-inlinetask (inlinetask contents info) + "Transcode an INLINETASK element from Org to HTML. +CONTENTS holds the contents of the block. INFO is a plist +holding contextual information." + (cond + ;; If `org-e-html-format-inlinetask-function' is provided, call it + ;; with appropriate arguments. + ((functionp org-e-html-format-inlinetask-function) + (let ((format-function + (function* + (lambda (todo todo-type priority text tags + &key contents &allow-other-keys) + (funcall org-e-html-format-inlinetask-function + todo todo-type priority text tags contents))))) + (org-e-html-format-headline--wrap + inlinetask info format-function :contents contents))) + ;; Otherwise, use a default template. + (t (org-e-html--wrap-label + inlinetask + (format + "
\n%s
\n%s
" + (org-e-html-format-headline--wrap inlinetask info) + contents))))) + + +;;;; Italic + +(defun org-e-html-italic (italic contents info) + "Transcode ITALIC from Org to HTML. +CONTENTS is the text with italic markup. INFO is a plist holding +contextual information." + (format (or (cdr (assq 'italic org-e-html-text-markup-alist)) "%s") contents)) + + +;;;; Item + +(defun org-e-html-checkbox (checkbox) + (case checkbox (on "[X]") + (off "[ ]") + (trans "[-]") + (t ""))) + +(defun org-e-html-format-list-item (contents type checkbox + &optional term-counter-id + headline) + (let ((checkbox (concat (org-e-html-checkbox checkbox) (and checkbox " ")))) + (concat + (case type + (ordered + (let* ((counter term-counter-id) + (extra (if counter (format " value=\"%s\"" counter) ""))) + (format "" extra))) + (unordered + (let* ((id term-counter-id) + (extra (if id (format " id=\"%s\"" id) ""))) + (concat + (format "" extra) + (when headline (concat headline "
"))))) + (descriptive + (let* ((term term-counter-id)) + (setq term (or term "(no term)")) + ;; Check-boxes in descriptive lists are associated to tag. + (concat (format "
%s
" + (concat checkbox term)) + "
")))) + (unless (eq type 'descriptive) checkbox) + contents + (case type + (ordered "") + (unordered "") + (descriptive "
"))))) + +(defun org-e-html-item (item contents info) + "Transcode an ITEM element from Org to HTML. +CONTENTS holds the contents of the item. INFO is a plist holding +contextual information." + (let* ((plain-list (org-export-get-parent item)) + (type (org-element-property :type plain-list)) + (counter (org-element-property :counter item)) + (checkbox (org-element-property :checkbox item)) + (tag (let ((tag (org-element-property :tag item))) + (and tag (org-export-data tag info))))) + (org-e-html-format-list-item + contents type checkbox (or tag counter)))) + + +;;;; Keyword + +(defun org-e-html-keyword (keyword contents info) + "Transcode a KEYWORD element from Org to HTML. +CONTENTS is nil. INFO is a plist holding contextual information." + (let ((key (org-element-property :key keyword)) + (value (org-element-property :value keyword))) + (cond + ((string= key "HTML") value) + ((string= key "INDEX") (format "\\index{%s}" value)) + ;; Invisible targets. + ((string= key "TARGET") nil) + ((string= key "TOC") + (let ((value (downcase value))) + (cond + ((string-match "\\" value) + (let ((depth (or (and (string-match "[0-9]+" value) + (string-to-number (match-string 0 value))) + (plist-get info :with-toc)))) + (org-e-html-toc depth info))) + ((string= "tables" value) "\\listoftables") + ((string= "figures" value) "\\listoffigures") + ((string= "listings" value) + (cond + ;; At the moment, src blocks with a caption are wrapped + ;; into a figure environment. + (t "\\listoffigures"))))))))) + + +;;;; Latex Environment + +(defun org-e-html-format-latex (latex-frag processing-type) + (let* ((cache-relpath + (concat "ltxpng/" (file-name-sans-extension + (file-name-nondirectory (buffer-file-name))))) + (cache-dir (file-name-directory (buffer-file-name ))) + (display-msg "Creating LaTeX Image...")) + + (with-temp-buffer + (insert latex-frag) + (org-format-latex cache-relpath cache-dir nil display-msg + nil nil processing-type) + (buffer-string)))) + +(defun org-e-html-latex-environment (latex-environment contents info) + "Transcode a LATEX-ENVIRONMENT element from Org to HTML. +CONTENTS is nil. INFO is a plist holding contextual information." + (org-e-html--wrap-label + latex-environment + (let ((processing-type (plist-get info :LaTeX-fragments)) + (latex-frag (org-remove-indentation + (org-element-property :value latex-environment))) + (caption (org-e-html--caption/label-string + (org-element-property :caption latex-environment) + (org-element-property :name latex-environment) + info)) + (attr nil) ; FIXME + (label (org-element-property :name latex-environment))) + (cond + ((memq processing-type '(t mathjax)) + (org-e-html-format-latex latex-frag 'mathjax)) + ((eq processing-type 'dvipng) + (let* ((formula-link (org-e-html-format-latex + latex-frag processing-type))) + (when (and formula-link + (string-match "file:\\([^]]*\\)" formula-link)) + (org-e-html-format-inline-image + (match-string 1 formula-link) caption label attr t)))) + (t latex-frag))))) + + +;;;; Latex Fragment + +(defun org-e-html-latex-fragment (latex-fragment contents info) + "Transcode a LATEX-FRAGMENT object from Org to HTML. +CONTENTS is nil. INFO is a plist holding contextual information." + (let ((latex-frag (org-element-property :value latex-fragment)) + (processing-type (plist-get info :LaTeX-fragments))) + (case processing-type + ((t mathjax) + (org-e-html-format-latex latex-frag 'mathjax)) + (dvipng + (let* ((formula-link (org-e-html-format-latex + latex-frag processing-type))) + (when (and formula-link + (string-match "file:\\([^]]*\\)" formula-link)) + (org-e-html-format-inline-image + (match-string 1 formula-link))))) + (t latex-frag)))) + +;;;; Line Break + +(defun org-e-html-line-break (line-break contents info) + "Transcode a LINE-BREAK object from Org to HTML. +CONTENTS is nil. INFO is a plist holding contextual information." + "
") + + +;;;; Link + +(defun org-e-html-link--inline-image (link desc info) + "Return HTML code for an inline image. +LINK is the link pointing to the inline image. INFO is a plist +used as a communication channel." + (let* ((type (org-element-property :type link)) + (raw-path (org-element-property :path link)) + (path (cond ((member type '("http" "https")) + (concat type ":" raw-path)) + ((file-name-absolute-p raw-path) + (expand-file-name raw-path)) + (t raw-path))) + (parent (org-export-get-parent-element link)) + (caption (org-e-html--caption/label-string + (org-element-property :caption parent) + (org-element-property :name parent) + info)) + (label (org-element-property :name parent)) + ;; Retrieve latex attributes from the element around. + (attr (let ((raw-attr + (mapconcat #'identity + (org-element-property :attr_html parent) + " "))) + (unless (string= raw-attr "") raw-attr)))) + ;; Now clear ATTR from any special keyword and set a default + ;; value if nothing is left. + (setq attr (if (not attr) "" (org-trim attr))) + ;; Return proper string, depending on DISPOSITION. + (org-e-html-format-inline-image + path caption label attr (org-e-html-standalone-image-p link info)))) + +(defvar org-e-html-standalone-image-predicate) +(defun org-e-html-standalone-image-p (element info &optional predicate) + "Test if ELEMENT is a standalone image for the purpose HTML export. +INFO is a plist holding contextual information. + +Return non-nil, if ELEMENT is of type paragraph and it's sole +content, save for whitespaces, is a link that qualifies as an +inline image. + +Return non-nil, if ELEMENT is of type link and it's containing +paragraph has no other content save for leading and trailing +whitespaces. + +Return nil, otherwise. + +Bind `org-e-html-standalone-image-predicate' to constrain +paragraph further. For example, to check for only captioned +standalone images, do the following. + + \(setq org-e-html-standalone-image-predicate + \(lambda \(paragraph\) + \(org-element-property :caption paragraph\)\)\) +" + (let ((paragraph (case (org-element-type element) + (paragraph element) + (link (and (org-export-inline-image-p + element org-e-html-inline-image-rules) + (org-export-get-parent element))) + (t nil)))) + (when paragraph + (assert (eq (org-element-type paragraph) 'paragraph)) + (when (or (not (and (boundp 'org-e-html-standalone-image-predicate) + (functionp org-e-html-standalone-image-predicate))) + (funcall org-e-html-standalone-image-predicate paragraph)) + (let ((contents (org-element-contents paragraph))) + (loop for x in contents + with inline-image-count = 0 + always (cond + ((eq (org-element-type x) 'plain-text) + (not (org-string-nw-p x))) + ((eq (org-element-type x) 'link) + (when (org-export-inline-image-p + x org-e-html-inline-image-rules) + (= (incf inline-image-count) 1))) + (t nil)))))))) + +(defun org-e-html-link (link desc info) + "Transcode a LINK object from Org to HTML. + +DESC is the description part of the link, or the empty string. +INFO is a plist holding contextual information. See +`org-export-data'." + (let* ((--link-org-files-as-html-maybe + (function + (lambda (raw-path info) + "Treat links to `file.org' as links to `file.html', if needed. + See `org-e-html-link-org-files-as-html'." + (cond + ((and org-e-html-link-org-files-as-html + (string= ".org" + (downcase (file-name-extension raw-path ".")))) + (concat (file-name-sans-extension raw-path) "." + (plist-get info :html-extension))) + (t raw-path))))) + (type (org-element-property :type link)) + (raw-path (org-element-property :path link)) + ;; Ensure DESC really exists, or set it to nil. + (desc (and (not (string= desc "")) desc)) + (path (cond + ((member type '("http" "https" "ftp" "mailto")) + (concat type ":" raw-path)) + ((string= type "file") + ;; Extract just the file path and strip all other + ;; components. + (when (string-match "\\(.+\\)::.+" raw-path) + (setq raw-path (match-string 1 raw-path))) + ;; Treat links to ".org" files as ".html", if needed. + (setq raw-path (funcall --link-org-files-as-html-maybe + raw-path info)) + ;; If file path is absolute, prepend it with protocol + ;; component - "file://". + (if (not (file-name-absolute-p raw-path)) raw-path + (concat "file://" (expand-file-name raw-path)))) + (t raw-path))) + ;; Extract attributes from parent's paragraph. + (attributes + (let ((attr (mapconcat + 'identity + (org-element-property + :attr_html (org-export-get-parent-element link)) + " "))) + (if attr (concat " " attr) ""))) + protocol) + (cond + ;; Image file. + ((and (or (eq t org-e-html-inline-images) + (and org-e-html-inline-images (not desc))) + (org-export-inline-image-p link org-e-html-inline-image-rules)) + (org-e-html-link--inline-image link desc info)) + ;; Radio target: Transcode target's contents and use them as + ;; link's description. + ((string= type "radio") + (let ((destination (org-export-resolve-radio-link link info))) + (when destination + (format "%s" + (org-export-solidify-link-text path) + attributes + (org-export-data (org-element-contents destination) info))))) + ;; Links pointing to an headline: Find destination and build + ;; appropriate referencing command. + ((member type '("custom-id" "fuzzy" "id")) + (let ((destination (if (string= type "fuzzy") + (org-export-resolve-fuzzy-link link info) + (org-export-resolve-id-link link info)))) + (case (org-element-type destination) + ;; ID link points to an external file. + (plain-text + (assert (org-uuidgen-p path)) + (let ((fragment (concat "ID-" path)) + ;; Treat links to ".org" files as ".html", if needed. + (path (funcall --link-org-files-as-html-maybe + destination info))) + (format "%s" + path fragment attributes (or desc destination)))) + ;; Fuzzy link points nowhere. + ((nil) + (format "%s" + (or desc + (org-export-data + (org-element-property :raw-link link) info)))) + ;; Fuzzy link points to an invisible target. + (keyword nil) + ;; Link points to an headline. + (headline + (let ((href + ;; What href to use? + (cond + ;; Case 1: Headline is linked via it's CUSTOM_ID + ;; property. Use CUSTOM_ID. + ((string= type "custom-id") + (org-element-property :custom-id destination)) + ;; Case 2: Headline is linked via it's ID property + ;; or through other means. Use the default href. + ((member type '("id" "fuzzy")) + (format "sec-%s" + (mapconcat 'number-to-string + (org-export-get-headline-number + destination info) "-"))) + (t (error "Shouldn't reach here")))) + ;; What description to use? + (desc + ;; Case 1: Headline is numbered and LINK has no + ;; description or LINK's description matches + ;; headline's title. Display section number. + (if (and (org-export-numbered-headline-p destination info) + (or (not desc) + (string= desc (org-element-property + :raw-value destination)))) + (mapconcat 'number-to-string + (org-export-get-headline-number + destination info) ".") + ;; Case 2: Either the headline is un-numbered or + ;; LINK has a custom description. Display LINK's + ;; description or headline's title. + (or desc (org-export-data (org-element-property + :title destination) info))))) + (format "%s" + (org-export-solidify-link-text href) attributes desc))) + ;; Fuzzy link points to a target. Do as above. + (t + (let ((path (org-export-solidify-link-text path)) number) + (unless desc + (setq number (cond + ((org-e-html-standalone-image-p destination info) + (org-export-get-ordinal + (assoc 'link (org-element-contents destination)) + info 'link 'org-e-html-standalone-image-p)) + (t (org-export-get-ordinal destination info)))) + (setq desc (when number + (if (atom number) (number-to-string number) + (mapconcat 'number-to-string number "."))))) + (format "%s" + path attributes (or desc "FIXME"))))))) + ;; Coderef: replace link with the reference name or the + ;; equivalent line number. + ((string= type "coderef") + (let ((fragment (concat "coderef-" path))) + (format "%s" + fragment + (format (concat "class=\"coderef\"" + " onmouseover=\"CodeHighlightOn(this, '%s');\"" + " onmouseout=\"CodeHighlightOff(this, '%s');\"") + fragment fragment) + attributes + (format (org-export-get-coderef-format path desc) + (org-export-resolve-coderef path info))))) + ;; Link type is handled by a special function. + ((functionp (setq protocol (nth 2 (assoc type org-link-protocols)))) + (funcall protocol (org-link-unescape path) desc 'html)) + ;; External link with a description part. + ((and path desc) (format "%s" path attributes desc)) + ;; External link without a description part. + (path (format "%s" path attributes path)) + ;; No path, only description. Try to do something useful. + (t (format "%s" desc))))) + + +;;;; Babel Call + +;; Babel Calls are ignored. + + +;;;; Macro + +(defun org-e-html-macro (macro contents info) + "Transcode a MACRO element from Org to HTML. +CONTENTS is nil. INFO is a plist holding contextual information." + ;; Use available tools. + (org-export-expand-macro macro info)) + + +;;;; Paragraph + +(defun org-e-html-paragraph (paragraph contents info) + "Transcode a PARAGRAPH element from Org to HTML. +CONTENTS is the contents of the paragraph, as a string. INFO is +the plist used as a communication channel." + (let* ((style nil) ; FIXME + (class (cdr (assoc style '((footnote . "footnote") + (verse . nil))))) + (extra (if class (format " class=\"%s\"" class) "")) + (parent (org-export-get-parent paragraph))) + (cond + ((and (eq (org-element-type parent) 'item) + (= (org-element-property :begin paragraph) + (org-element-property :contents-begin parent))) + ;; leading paragraph in a list item have no tags + contents) + ((org-e-html-standalone-image-p paragraph info) + ;; standalone image + contents) + (t (format "\n%s

" extra contents))))) + + +;;;; Plain List + +(defun org-e-html-begin-plain-list (type &optional arg1) + (case type + (ordered + (format "" (if arg1 ; FIXME + (format " start=\"%d\"" arg1) + ""))) + (unordered "
    ") + (descriptive "
    "))) + +(defun org-e-html-end-plain-list (type) + (case type + (ordered "") + (unordered "
") + (descriptive ""))) + +(defun org-e-html-plain-list (plain-list contents info) + "Transcode a PLAIN-LIST element from Org to HTML. +CONTENTS is the contents of the list. INFO is a plist holding +contextual information." + (let* (arg1 ;; FIXME + (type (org-element-property :type plain-list)) + (attr (mapconcat #'identity + (org-element-property :attr_html plain-list) + " "))) + (org-e-html--wrap-label + plain-list (format "%s\n%s%s" + (org-e-html-begin-plain-list type) + contents (org-e-html-end-plain-list type))))) + +;;;; Plain Text + +(defun org-e-html-convert-special-strings (string) + "Convert special characters in STRING to HTML." + (let ((all org-e-html-special-string-regexps) + e a re rpl start) + (while (setq a (pop all)) + (setq re (car a) rpl (cdr a) start 0) + (while (string-match re string start) + (setq string (replace-match rpl t nil string)))) + string)) + +(defun org-e-html-encode-plain-text (text) + "Convert plain text characters to HTML equivalent. +Possible conversions are set in `org-export-html-protect-char-alist'." + (mapc + (lambda (pair) + (setq text (replace-regexp-in-string (car pair) (cdr pair) text t t))) + org-e-html-protect-char-alist) + text) + +(defun org-e-html-plain-text (text info) + "Transcode a TEXT string from Org to HTML. +TEXT is the string to transcode. INFO is a plist holding +contextual information." + ;; Protect following characters: <, >, &. + (setq text (org-e-html-encode-plain-text text)) + ;; Handle quotation marks. + (setq text (org-e-html--quotation-marks text info)) + ;; Handle special strings. + (when (plist-get info :with-special-strings) + (setq text (org-e-html-convert-special-strings text))) + ;; Handle break preservation if required. + (when (plist-get info :preserve-breaks) + (setq text (replace-regexp-in-string "\\(\\\\\\\\\\)?[ \t]*\n" " \\\\\\\\\n" + text))) + ;; Return value. + text) + + +;; Planning + +(defun org-e-html-planning (planning contents info) + "Transcode a PLANNING element from Org to HTML. +CONTENTS is nil. INFO is a plist used as a communication +channel." + (let ((span-fmt "%s %s")) + (format + "

%s

" + (mapconcat + 'identity + (delq nil + (list + (let ((closed (org-element-property :closed planning))) + (when closed + (format span-fmt org-closed-string + (org-translate-time closed)))) + (let ((deadline (org-element-property :deadline planning))) + (when deadline + (format span-fmt org-deadline-string + (org-translate-time deadline)))) + (let ((scheduled (org-element-property :scheduled planning))) + (when scheduled + (format span-fmt org-scheduled-string + (org-translate-time scheduled)))))) + " ")))) + + +;;;; Property Drawer + +(defun org-e-html-property-drawer (property-drawer contents info) + "Transcode a PROPERTY-DRAWER element from Org to HTML. +CONTENTS is nil. INFO is a plist holding contextual +information." + ;; The property drawer isn't exported but we want separating blank + ;; lines nonetheless. + "") + + +;;;; Quote Block + +(defun org-e-html-quote-block (quote-block contents info) + "Transcode a QUOTE-BLOCK element from Org to HTML. +CONTENTS holds the contents of the block. INFO is a plist +holding contextual information." + (org-e-html--wrap-label + quote-block (format "
\n%s
" contents))) + + +;;;; Quote Section + +(defun org-e-html-quote-section (quote-section contents info) + "Transcode a QUOTE-SECTION element from Org to HTML. +CONTENTS is nil. INFO is a plist holding contextual information." + (let ((value (org-remove-indentation + (org-element-property :value quote-section)))) + (when value (format "
\n%s
" value)))) + + +;;;; Section + +(defun org-e-html-section (section contents info) + "Transcode a SECTION element from Org to HTML. +CONTENTS holds the contents of the section. INFO is a plist +holding contextual information." + (let ((parent (org-export-get-parent-headline section))) + ;; Before first headline: no container, just return CONTENTS. + (if (not parent) contents + ;; Get div's class and id references. + (let* ((class-num (+ (org-export-get-relative-level parent info) + (1- org-e-html-toplevel-hlevel))) + (section-number + (mapconcat + 'number-to-string + (org-export-get-headline-number parent info) "-"))) + ;; Build return value. + (format "
\n%s
" + class-num + (or (org-element-property :custom-id parent) section-number) + contents))))) + +;;;; Radio Target + +(defun org-e-html-radio-target (radio-target text info) + "Transcode a RADIO-TARGET object from Org to HTML. +TEXT is the text of the target. INFO is a plist holding +contextual information." + (let ((id (org-export-solidify-link-text + (org-element-property :value radio-target)))) + (org-e-html--anchor id text))) + + +;;;; Special Block + +(defun org-e-html-special-block (special-block contents info) + "Transcode a SPECIAL-BLOCK element from Org to HTML. +CONTENTS holds the contents of the block. INFO is a plist +holding contextual information." + (let ((type (downcase (org-element-property :type special-block)))) + (org-e-html--wrap-label + special-block + (format "
\n%s\n
" type contents)))) + + +;;;; Src Block + +(defun org-e-html-src-block (src-block contents info) + "Transcode a SRC-BLOCK element from Org to HTML. +CONTENTS holds the contents of the item. INFO is a plist holding +contextual information." + (let* ((lang (org-element-property :language src-block)) + (caption (org-element-property :caption src-block)) + (label (org-element-property :name src-block)) + (caption-str (org-e-html--caption/label-string caption label info)) + (attr (mapconcat #'identity + (org-element-property :attr_html src-block) + " ")) + ;; (switches (org-element-property :switches src-block)) + (switches nil) ; FIXME + (textarea-p (and switches (string-match "-t\\>" switches))) + (code (org-e-html-format-code src-block info))) + (cond + (lang (format + "
\n%s%s\n
" + (if (not caption) "" + (format "" caption-str)) + (format "\n
%s
" lang code))) + (textarea-p + (let ((cols (if (not (string-match "-w[ \t]+\\([0-9]+\\)" switches)) + 80 (string-to-number (match-string 1 switches)))) + (rows (if (string-match "-h[ \t]+\\([0-9]+\\)" switches) + (string-to-number (match-string 1 switches)) + (org-count-lines code)))) + (format + "

\n\n

" + cols rows code))) + (t (format "
\n%s
" code))))) + +;;;; Statistics Cookie + +(defun org-e-html-statistics-cookie (statistics-cookie contents info) + "Transcode a STATISTICS-COOKIE object from Org to HTML. +CONTENTS is nil. INFO is a plist holding contextual information." + (let ((cookie-value (org-element-property :value statistics-cookie))) + (format "%s" cookie-value))) + + +;;;; Strike-Through + +(defun org-e-html-strike-through (strike-through contents info) + "Transcode STRIKE-THROUGH from Org to HTML. +CONTENTS is the text with strike-through markup. INFO is a plist +holding contextual information." + (format (or (cdr (assq 'strike-through org-e-html-text-markup-alist)) "%s") + contents)) + + +;;;; Subscript + +(defun org-e-html-subscript (subscript contents info) + "Transcode a SUBSCRIPT object from Org to HTML. +CONTENTS is the contents of the object. INFO is a plist holding +contextual information." + (format "%s" contents)) + + +;;;; Superscript + +(defun org-e-html-superscript (superscript contents info) + "Transcode a SUPERSCRIPT object from Org to HTML. +CONTENTS is the contents of the object. INFO is a plist holding +contextual information." + (format "%s" contents)) + + +;;;; Tabel Cell + +(defun org-e-html-table-cell (table-cell contents info) + "Transcode a TABLE-CELL element from Org to HTML. +CONTENTS is nil. INFO is a plist used as a communication +channel." + (let* ((table-row (org-export-get-parent table-cell)) + (table (org-export-get-parent-table table-cell)) + (cell-attrs + (if (not org-e-html-table-align-individual-fields) "" + (format (if (and (boundp 'org-e-html-format-table-no-css) + org-e-html-format-table-no-css) + " align=\"%s\"" " class=\"%s\"") + (org-export-table-cell-alignment table-cell info))))) + (when (or (not contents) (string= "" (org-trim contents))) + (setq contents " ")) + (cond + ((and (org-export-table-has-header-p table info) + (= 1 (org-export-table-row-group table-row info))) + (concat "\n" (format (car org-e-html-table-header-tags) "col" cell-attrs) + contents (cdr org-e-html-table-header-tags))) + ((and org-e-html-table-use-header-tags-for-first-column + (zerop (cdr (org-export-table-cell-address table-cell info)))) + (concat "\n" (format (car org-e-html-table-header-tags) "row" cell-attrs) + contents (cdr org-e-html-table-header-tags))) + (t (concat "\n" (format (car org-e-html-table-data-tags) cell-attrs) + contents (cdr org-e-html-table-data-tags)))))) + + +;;;; Table Row + +(defun org-e-html-table-row (table-row contents info) + "Transcode a TABLE-ROW element from Org to HTML. +CONTENTS is the contents of the row. INFO is a plist used as a +communication channel." + ;; Rules are ignored since table separators are deduced from + ;; borders of the current row. + (when (eq (org-element-property :type table-row) 'standard) + (let* ((first-rowgroup-p (= 1 (org-export-table-row-group table-row info))) + (rowgroup-tags + (cond + ;; Case 1: Row belongs to second or subsequent rowgroups. + ((not (= 1 (org-export-table-row-group table-row info))) + '("" . "\n")) + ;; Case 2: Row is from first rowgroup. Table has >=1 rowgroups. + ((org-export-table-has-header-p + (org-export-get-parent-table table-row) info) + '("" . "\n")) + ;; Case 2: Row is from first and only row group. + (t '("" . "\n"))))) + (concat + ;; Begin a rowgroup? + (when (org-export-table-row-starts-rowgroup-p table-row info) + (car rowgroup-tags)) + ;; Actual table row + (concat "\n" (eval (car org-e-html-table-row-tags)) + contents + "\n" + (eval (cdr org-e-html-table-row-tags))) + ;; End a rowgroup? + (when (org-export-table-row-ends-rowgroup-p table-row info) + (cdr rowgroup-tags)))))) + + +;;;; Table + +(defun org-e-html-table-first-row-data-cells (table info) + (let ((table-row + (org-element-map + table 'table-row + (lambda (row) + (unless (eq (org-element-property :type row) 'rule) row)) + info 'first-match)) + (special-column-p (org-export-table-has-special-column-p table))) + (if (not special-column-p) (org-element-contents table-row) + (cdr (org-element-contents table-row))))) + +(defun org-e-html-table--table.el-table (table info) + (when (eq (org-element-property :type table) 'table.el) + (require 'table) + (let ((outbuf (with-current-buffer + (get-buffer-create "*org-export-table*") + (erase-buffer) (current-buffer)))) + (with-temp-buffer + (insert (org-element-property :value table)) + (goto-char 1) + (re-search-forward "^[ \t]*|[^|]" nil t) + (table-generate-source 'html outbuf)) + (with-current-buffer outbuf + (prog1 (org-trim (buffer-string)) + (kill-buffer) ))))) + +(defun org-e-html-table (table contents info) + "Transcode a TABLE element from Org to HTML. +CONTENTS is the contents of the table. INFO is a plist holding +contextual information." + (case (org-element-property :type table) + ;; Case 1: table.el table. Convert it using appropriate tools. + (table.el (org-e-html-table--table.el-table table info)) + ;; Case 2: Standard table. + (t + (let* ((label (org-element-property :name table)) + (caption (org-e-html--caption/label-string + (org-element-property :caption table) label info)) + (attributes (mapconcat #'identity + (org-element-property :attr_html table) + " ")) + (alignspec + (if (and (boundp 'org-e-html-format-table-no-css) + org-e-html-format-table-no-css) + "align=\"%s\"" "class=\"%s\"")) + (table-column-specs + (function + (lambda (table info) + (mapconcat + (lambda (table-cell) + (let ((alignment (org-export-table-cell-alignment + table-cell info))) + (concat + ;; Begin a colgroup? + (when (org-export-table-cell-starts-colgroup-p + table-cell info) + "\n") + ;; Add a column. Also specify it's alignment. + (format "\n" (format alignspec alignment)) + ;; End a colgroup? + (when (org-export-table-cell-ends-colgroup-p + table-cell info) + "\n")))) + (org-e-html-table-first-row-data-cells table info) "\n")))) + (table-attributes + (let ((table-tag (plist-get info :html-table-tag))) + (concat + (and (string-match "" table-tag) + (match-string 1 table-tag)) + (and label (format " id=\"%s\"" + (org-export-solidify-link-text label))))))) + ;; Remove last blank line. + (setq contents (substring contents 0 -1)) + (format "\n%s\n%s\n%s\n" + table-attributes + (if (not caption) "" (format "%s" caption)) + (funcall table-column-specs table info) + contents))))) + +;;;; Target + +(defun org-e-html-target (target contents info) + "Transcode a TARGET object from Org to HTML. +CONTENTS is nil. INFO is a plist holding contextual +information." + (let ((id (org-export-solidify-link-text + (org-element-property :value target)))) + (org-e-html--anchor id))) + + +;;;; Timestamp + +(defun org-e-html-timestamp (timestamp contents info) + "Transcode a TIMESTAMP object from Org to HTML. +CONTENTS is nil. INFO is a plist holding contextual +information." + (let* ((f (if (eq (org-element-property :type timestamp) 'inactive) "[%s]" "<%s>")) + (value (org-translate-time (format f (org-element-property :value timestamp)))) + (range-end (org-element-property :range-end timestamp))) + (format "%s" + (if (not range-end) value + (concat value "–" (org-translate-time (format f range-end))))))) + + +;;;; Underline + +(defun org-e-html-underline (underline contents info) + "Transcode UNDERLINE from Org to HTML. +CONTENTS is the text with underline markup. INFO is a plist +holding contextual information." + (format (or (cdr (assq 'underline org-e-html-text-markup-alist)) "%s") + contents)) + + +;;;; Verbatim + +(defun org-e-html-verbatim (verbatim contents info) + "Transcode VERBATIM from Org to HTML. +CONTENTS is nil. INFO is a plist holding contextual +information." + (format (or (cdr (assq 'verbatim org-e-html-text-markup-alist)) "%s") + (org-element-property :value verbatim))) + + +;;;; Verse Block + +(defun org-e-html-verse-block (verse-block contents info) + "Transcode a VERSE-BLOCK element from Org to HTML. +CONTENTS is verse block contents. INFO is a plist holding +contextual information." + ;; Replace each newline character with line break. Also replace + ;; each blank line with a line break. + (setq contents (replace-regexp-in-string + "^ *\\\\\\\\$" "
\n" + (replace-regexp-in-string + "\\(\\\\\\\\\\)?[ \t]*\n" "
\n" contents))) + ;; Replace each white space at beginning of a line with a + ;; non-breaking space. + (while (string-match "^[ \t]+" contents) + (let* ((num-ws (length (match-string 0 contents))) + (ws (let (out) (dotimes (i num-ws out) + (setq out (concat out " ")))))) + (setq contents (replace-match ws nil t contents)))) + (org-e-html--wrap-label + verse-block (format "

\n%s

" contents))) + + + + +;;; Filter Functions + +(defun org-e-html-final-function (contents backend info) + (if (not org-e-html-pretty-output) contents + (with-temp-buffer + (html-mode) + (insert contents) + (indent-region (point-min) (point-max)) + (buffer-substring-no-properties (point-min) (point-max))))) + + +;;; Interactive functions + +;;;###autoload +(defun org-e-html-export-as-html + (&optional subtreep visible-only body-only ext-plist) + "Export current buffer to an HTML buffer. + +If narrowing is active in the current buffer, only export its +narrowed part. + +If a region is active, export that region. + +When optional argument SUBTREEP is non-nil, export the sub-tree +at point, extracting information from the headline properties +first. + +When optional argument VISIBLE-ONLY is non-nil, don't export +contents of hidden elements. + +When optional argument BODY-ONLY is non-nil, only write code +between \"\" and \"\" tags. + +EXT-PLIST, when provided, is a property list with external +parameters overriding Org default settings, but still inferior to +file-local settings. + +Export is done in a buffer named \"*Org E-HTML Export*\", which +will be displayed when `org-export-show-temporary-export-buffer' +is non-nil." + (interactive) + (let ((outbuf + (org-export-to-buffer + 'e-html "*Org E-HTML Export*" + subtreep visible-only body-only ext-plist))) + ;; Set major mode. + (with-current-buffer outbuf (nxml-mode)) + (when org-export-show-temporary-export-buffer + (switch-to-buffer-other-window outbuf)))) + +;;;###autoload +(defun org-e-html-export-to-html + (&optional subtreep visible-only body-only ext-plist pub-dir) + "Export current buffer to a HTML file. + +If narrowing is active in the current buffer, only export its +narrowed part. + +If a region is active, export that region. + +When optional argument SUBTREEP is non-nil, export the sub-tree +at point, extracting information from the headline properties +first. + +When optional argument VISIBLE-ONLY is non-nil, don't export +contents of hidden elements. + +When optional argument BODY-ONLY is non-nil, only write code +between \"\" and \"\" tags. + +EXT-PLIST, when provided, is a property list with external +parameters overriding Org default settings, but still inferior to +file-local settings. + +When optional argument PUB-DIR is set, use it as the publishing +directory. + +Return output file's name." + (interactive) + (let* ((extension (concat "." org-e-html-extension)) + (file (org-export-output-file-name extension subtreep pub-dir)) + (org-export-coding-system org-e-html-coding-system)) + (org-export-to-file + 'e-html file subtreep visible-only body-only ext-plist))) + + + +;;; FIXME + +;;;; org-format-table-html +;;;; org-format-org-table-html +;;;; org-format-table-table-html +;;;; org-table-number-fraction +;;;; org-table-number-regexp +;;;; org-e-html-table-caption-above + +;;;; org-e-html-with-timestamp +;;;; org-e-html-html-helper-timestamp + +;;;; org-export-as-html-and-open +;;;; org-export-as-html-batch +;;;; org-export-as-html-to-buffer +;;;; org-replace-region-by-html +;;;; org-export-region-as-html +;;;; org-export-as-html + +;;;; (org-export-directory :html opt-plist) +;;;; (plist-get opt-plist :html-extension) +;;;; org-e-html-toplevel-hlevel +;;;; org-e-html-special-string-regexps +;;;; org-e-html-inline-images +;;;; org-e-html-inline-image-extensions +;;;; org-e-html-protect-char-alist +;;;; org-e-html-table-use-header-tags-for-first-column +;;;; org-e-html-todo-kwd-class-prefix +;;;; org-e-html-tag-class-prefix +;;;; org-e-html-footnote-separator + +;;;; org-export-preferred-target-alist +;;;; org-export-solidify-link-text +;;;; class for anchors +;;;; org-export-with-section-numbers, body-only +;;;; org-export-mark-todo-in-toc + +;;;; org-e-html-format-org-link +;;;; (caption (and caption (org-xml-encode-org-text caption))) +;;;; alt = (file-name-nondirectory path) + +;;;; org-export-time-stamp-file' + +(provide 'org-e-html) +;;; org-e-html.el ends here diff --git a/contrib/lisp/org-e-latex.el b/contrib/lisp/org-e-latex.el new file mode 100644 index 0000000..8712f5a --- /dev/null +++ b/contrib/lisp/org-e-latex.el @@ -0,0 +1,2726 @@ +;;; org-e-latex.el --- LaTeX Back-End For Org Export Engine + +;; Copyright (C) 2011-2012 Free Software Foundation, Inc. + +;; Author: Nicolas Goaziou +;; Keywords: outlines, hypermedia, calendar, wp + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: +;; +;; This library implements a LaTeX back-end for Org generic exporter. +;; +;; To test it, run +;; +;; M-: (org-export-to-buffer 'e-latex "*Test e-LaTeX*") RET +;; +;; in an org-mode buffer then switch to the buffer to see the LaTeX +;; export. See contrib/lisp/org-export.el for more details on how +;; this exporter works. +;; +;; It introduces three new buffer keywords: "LATEX_CLASS", +;; "LATEX_CLASS_OPTIONS" and "LATEX_HEADER". + +;;; Code: + +(eval-when-compile (require 'cl)) +(require 'org-export) + +(defvar org-export-latex-default-packages-alist) +(defvar org-export-latex-packages-alist) +(defvar orgtbl-exp-regexp) + + + +;;; Define Back-End + +(org-export-define-backend e-latex + ((bold . org-e-latex-bold) + (center-block . org-e-latex-center-block) + (clock . org-e-latex-clock) + (code . org-e-latex-code) + (drawer . org-e-latex-drawer) + (dynamic-block . org-e-latex-dynamic-block) + (entity . org-e-latex-entity) + (example-block . org-e-latex-example-block) + (export-block . org-e-latex-export-block) + (export-snippet . org-e-latex-export-snippet) + (fixed-width . org-e-latex-fixed-width) + (footnote-definition . org-e-latex-footnote-definition) + (footnote-reference . org-e-latex-footnote-reference) + (headline . org-e-latex-headline) + (horizontal-rule . org-e-latex-horizontal-rule) + (inline-src-block . org-e-latex-inline-src-block) + (inlinetask . org-e-latex-inlinetask) + (italic . org-e-latex-italic) + (item . org-e-latex-item) + (keyword . org-e-latex-keyword) + (latex-environment . org-e-latex-latex-environment) + (latex-fragment . org-e-latex-latex-fragment) + (line-break . org-e-latex-line-break) + (link . org-e-latex-link) + (macro . org-e-latex-macro) + (paragraph . org-e-latex-paragraph) + (plain-list . org-e-latex-plain-list) + (plain-text . org-e-latex-plain-text) + (planning . org-e-latex-planning) + (property-drawer . org-e-latex-property-drawer) + (quote-block . org-e-latex-quote-block) + (quote-section . org-e-latex-quote-section) + (radio-target . org-e-latex-radio-target) + (section . org-e-latex-section) + (special-block . org-e-latex-special-block) + (src-block . org-e-latex-src-block) + (statistics-cookie . org-e-latex-statistics-cookie) + (strike-through . org-e-latex-strike-through) + (subscript . org-e-latex-subscript) + (superscript . org-e-latex-superscript) + (table . org-e-latex-table) + (table-cell . org-e-latex-table-cell) + (table-row . org-e-latex-table-row) + (target . org-e-latex-target) + (template . org-e-latex-template) + (timestamp . org-e-latex-timestamp) + (underline . org-e-latex-underline) + (verbatim . org-e-latex-verbatim) + (verse-block . org-e-latex-verse-block)) + :export-block "LATEX" + :options-alist ((:date "DATE" nil org-e-latex-date-format t) + (:latex-class "LATEX_CLASS" nil org-e-latex-default-class t) + (:latex-class-options "LATEX_CLASS_OPTIONS" nil nil t) + (:latex-header-extra "LATEX_HEADER" nil nil newline))) + + + +;;; Internal Variables + +(defconst org-e-latex-babel-language-alist + '(("af" . "afrikaans") + ("bg" . "bulgarian") + ("bt-br" . "brazilian") + ("ca" . "catalan") + ("cs" . "czech") + ("cy" . "welsh") + ("da" . "danish") + ("de" . "germanb") + ("de-at" . "naustrian") + ("de-de" . "ngerman") + ("el" . "greek") + ("en" . "english") + ("en-au" . "australian") + ("en-ca" . "canadian") + ("en-gb" . "british") + ("en-ie" . "irish") + ("en-nz" . "newzealand") + ("en-us" . "american") + ("es" . "spanish") + ("et" . "estonian") + ("eu" . "basque") + ("fi" . "finnish") + ("fr" . "frenchb") + ("fr-ca" . "canadien") + ("gl" . "galician") + ("hr" . "croatian") + ("hu" . "hungarian") + ("id" . "indonesian") + ("is" . "icelandic") + ("it" . "italian") + ("la" . "latin") + ("ms" . "malay") + ("nl" . "dutch") + ("no-no" . "nynorsk") + ("pl" . "polish") + ("pt" . "portuguese") + ("ro" . "romanian") + ("ru" . "russian") + ("sa" . "sanskrit") + ("sb" . "uppersorbian") + ("sk" . "slovak") + ("sl" . "slovene") + ("sq" . "albanian") + ("sr" . "serbian") + ("sv" . "swedish") + ("ta" . "tamil") + ("tr" . "turkish") + ("uk" . "ukrainian")) + "Alist between language code and corresponding Babel option.") + + + +;;; User Configurable Variables + +(defgroup org-export-e-latex nil + "Options for exporting Org mode files to LaTeX." + :tag "Org Export LaTeX" + :group 'org-export) + + +;;;; Preamble + +(defcustom org-e-latex-default-class "article" + "The default LaTeX class." + :group 'org-export-e-latex + :type '(string :tag "LaTeX class")) + +(defcustom org-e-latex-classes + '(("article" + "\\documentclass[11pt]{article}" + ("\\section{%s}" . "\\section*{%s}") + ("\\subsection{%s}" . "\\subsection*{%s}") + ("\\subsubsection{%s}" . "\\subsubsection*{%s}") + ("\\paragraph{%s}" . "\\paragraph*{%s}") + ("\\subparagraph{%s}" . "\\subparagraph*{%s}")) + ("report" + "\\documentclass[11pt]{report}" + ("\\part{%s}" . "\\part*{%s}") + ("\\chapter{%s}" . "\\chapter*{%s}") + ("\\section{%s}" . "\\section*{%s}") + ("\\subsection{%s}" . "\\subsection*{%s}") + ("\\subsubsection{%s}" . "\\subsubsection*{%s}")) + ("book" + "\\documentclass[11pt]{book}" + ("\\part{%s}" . "\\part*{%s}") + ("\\chapter{%s}" . "\\chapter*{%s}") + ("\\section{%s}" . "\\section*{%s}") + ("\\subsection{%s}" . "\\subsection*{%s}") + ("\\subsubsection{%s}" . "\\subsubsection*{%s}"))) + "Alist of LaTeX classes and associated header and structure. +If #+LaTeX_CLASS is set in the buffer, use its value and the +associated information. Here is the structure of each cell: + + \(class-name + header-string + \(numbered-section . unnumbered-section\) + ...\) + +The header string +----------------- + +The HEADER-STRING is the header that will be inserted into the +LaTeX file. It should contain the \\documentclass macro, and +anything else that is needed for this setup. To this header, the +following commands will be added: + +- Calls to \\usepackage for all packages mentioned in the + variables `org-export-latex-default-packages-alist' and + `org-export-latex-packages-alist'. Thus, your header + definitions should avoid to also request these packages. + +- Lines specified via \"#+LaTeX_HEADER:\" + +If you need more control about the sequence in which the header +is built up, or if you want to exclude one of these building +blocks for a particular class, you can use the following +macro-like placeholders. + + [DEFAULT-PACKAGES] \\usepackage statements for default packages + [NO-DEFAULT-PACKAGES] do not include any of the default packages + [PACKAGES] \\usepackage statements for packages + [NO-PACKAGES] do not include the packages + [EXTRA] the stuff from #+LaTeX_HEADER + [NO-EXTRA] do not include #+LaTeX_HEADER stuff + +So a header like + + \\documentclass{article} + [NO-DEFAULT-PACKAGES] + [EXTRA] + \\providecommand{\\alert}[1]{\\textbf{#1}} + [PACKAGES] + +will omit the default packages, and will include the +#+LaTeX_HEADER lines, then have a call to \\providecommand, and +then place \\usepackage commands based on the content of +`org-export-latex-packages-alist'. + +If your header, `org-export-latex-default-packages-alist' or +`org-export-latex-packages-alist' inserts +\"\\usepackage[AUTO]{inputenc}\", AUTO will automatically be +replaced with a coding system derived from +`buffer-file-coding-system'. See also the variable +`org-e-latex-inputenc-alist' for a way to influence this +mechanism. + +The sectioning structure +------------------------ + +The sectioning structure of the class is given by the elements +following the header string. For each sectioning level, a number +of strings is specified. A %s formatter is mandatory in each +section string and will be replaced by the title of the section. + +Instead of a cons cell \(numbered . unnumbered\), you can also +provide a list of 2 or 4 elements, + + \(numbered-open numbered-close\) + +or + + \(numbered-open numbered-close unnumbered-open unnumbered-close\) + +providing opening and closing strings for a LaTeX environment +that should represent the document section. The opening clause +should have a %s to represent the section title. + +Instead of a list of sectioning commands, you can also specify +a function name. That function will be called with two +parameters, the \(reduced) level of the headline, and a predicate +non-nil when the headline should be numbered. It must return +a format string in which the section title will be added." + :group 'org-export-e-latex + :type '(repeat + (list (string :tag "LaTeX class") + (string :tag "LaTeX header") + (repeat :tag "Levels" :inline t + (choice + (cons :tag "Heading" + (string :tag " numbered") + (string :tag "unnumbered")) + (list :tag "Environment" + (string :tag "Opening (numbered)") + (string :tag "Closing (numbered)") + (string :tag "Opening (unnumbered)") + (string :tag "Closing (unnumbered)")) + (function :tag "Hook computing sectioning")))))) + +(defcustom org-e-latex-inputenc-alist nil + "Alist of inputenc coding system names, and what should really be used. +For example, adding an entry + + (\"utf8\" . \"utf8x\") + +will cause \\usepackage[utf8x]{inputenc} to be used for buffers that +are written as utf8 files." + :group 'org-export-e-latex + :type '(repeat + (cons + (string :tag "Derived from buffer") + (string :tag "Use this instead")))) + +(defcustom org-e-latex-date-format + "\\today" + "Format string for \\date{...}." + :group 'org-export-e-latex + :type 'boolean) + +(defcustom org-e-latex-title-command "\\maketitle" + "The command used to insert the title just after \\begin{document}. +If this string contains the formatting specification \"%s\" then +it will be used as a formatting string, passing the title as an +argument." + :group 'org-export-e-latex + :type 'string) + + +;;;; Headline + +(defcustom org-e-latex-format-headline-function nil + "Function to format headline text. + +This function will be called with 5 arguments: +TODO the todo keyword (string or nil). +TODO-TYPE the type of todo (symbol: `todo', `done', nil) +PRIORITY the priority of the headline (integer or nil) +TEXT the main headline text (string). +TAGS the tags as a list of strings (list of strings or nil). + +The function result will be used in the section format string. + +As an example, one could set the variable to the following, in +order to reproduce the default set-up: + +\(defun org-e-latex-format-headline (todo todo-type priority text tags) + \"Default format function for an headline.\" + \(concat (when todo + \(format \"\\\\textbf{\\\\textsc{\\\\textsf{%s}}} \" todo)) + \(when priority + \(format \"\\\\framebox{\\\\#%c} \" priority)) + text + \(when tags + \(format \"\\\\hfill{}\\\\textsc{%s}\" + \(mapconcat 'identity tags \":\"))))" + :group 'org-export-e-latex + :type 'function) + + +;;;; Footnotes + +(defcustom org-e-latex-footnote-separator "\\textsuperscript{,}\\," + "Text used to separate footnotes." + :group 'org-export-e-latex + :type 'string) + + +;;;; Timestamps + +(defcustom org-e-latex-active-timestamp-format "\\textit{%s}" + "A printf format string to be applied to active timestamps." + :group 'org-export-e-latex + :type 'string) + +(defcustom org-e-latex-inactive-timestamp-format "\\textit{%s}" + "A printf format string to be applied to inactive timestamps." + :group 'org-export-e-latex + :type 'string) + +(defcustom org-e-latex-diary-timestamp-format "\\textit{%s}" + "A printf format string to be applied to diary timestamps." + :group 'org-export-e-latex + :type 'string) + + +;;;; Links + +(defcustom org-e-latex-image-default-option "width=.9\\linewidth" + "Default option for images." + :group 'org-export-e-latex + :type 'string) + +(defcustom org-e-latex-default-figure-position "htb" + "Default position for latex figures." + :group 'org-export-e-latex + :type 'string) + +(defcustom org-e-latex-inline-image-rules + '(("file" . "\\.\\(pdf\\|jpeg\\|jpg\\|png\\|ps\\|eps\\)\\'")) + "Rules characterizing image files that can be inlined into LaTeX. + +A rule consists in an association whose key is the type of link +to consider, and value is a regexp that will be matched against +link's path. + +Note that, by default, the image extension *actually* allowed +depend on the way the LaTeX file is processed. When used with +pdflatex, pdf, jpg and png images are OK. When processing +through dvi to Postscript, only ps and eps are allowed. The +default we use here encompasses both." + :group 'org-export-e-latex + :type '(alist :key-type (string :tag "Type") + :value-type (regexp :tag "Path"))) + +(defcustom org-e-latex-link-with-unknown-path-format "\\texttt{%s}" + "Format string for links with unknown path type." + :group 'org-export-latex + :type 'string) + + +;;;; Tables + +(defcustom org-e-latex-default-table-environment "tabular" + "Default environment used to build tables." + :group 'org-export-e-latex + :type 'string) + +(defcustom org-e-latex-tables-centered t + "When non-nil, tables are exported in a center environment." + :group 'org-export-e-latex + :type 'boolean) + +(defcustom org-e-latex-tables-verbatim nil + "When non-nil, tables are exported verbatim." + :group 'org-export-e-latex + :type 'boolean) + +(defcustom org-e-latex-tables-booktabs nil + "When non-nil, display tables in a formal \"booktabs\" style. +This option assumes that the \"booktabs\" package is properly +loaded in the header of the document. This value can be ignored +locally with \"booktabs=yes\" and \"booktabs=no\" LaTeX +attributes." + :group 'org-export-e-latex + :type 'boolean) + +(defcustom org-e-latex-table-caption-above t + "When non-nil, place caption string at the beginning of the table. +Otherwise, place it near the end." + :group 'org-export-e-latex + :type 'boolean) + +(defcustom org-e-latex-table-scientific-notation "%s\\,(%s)" + "Format string to display numbers in scientific notation. +The format should have \"%s\" twice, for mantissa and exponent +\(i.e. \"%s\\\\times10^{%s}\"). + +When nil, no transformation is made." + :group 'org-export-e-latex + :type '(choice + (string :tag "Format string") + (const :tag "No formatting"))) + + +;;;; Text markup + +(defcustom org-e-latex-text-markup-alist '((bold . "\\textbf{%s}") + (code . verb) + (italic . "\\emph{%s}") + (strike-through . "\\st{%s}") + (underline . "\\underline{%s}") + (verbatim . protectedtexttt)) + "Alist of LaTeX expressions to convert text markup. + +The key must be a symbol among `bold', `code', `italic', +`strike-through', `underline' and `verbatim'. The value is +a formatting string to wrap fontified text with. + +Value can also be set to the following symbols: `verb' and +`protectedtexttt'. For the former, Org will use \"\\verb\" to +create a format string and select a delimiter character that +isn't in the string. For the latter, Org will use \"\\texttt\" +to typeset and try to protect special characters. + +If no association can be found for a given markup, text will be +returned as-is." + :group 'org-export-e-latex + :type 'alist + :options '(bold code italic strike-through underline verbatim)) + + +;;;; Drawers + +(defcustom org-e-latex-format-drawer-function nil + "Function called to format a drawer in LaTeX code. + +The function must accept two parameters: + NAME the drawer name, like \"LOGBOOK\" + CONTENTS the contents of the drawer. + +The function should return the string to be exported. + +For example, the variable could be set to the following function +in order to mimic default behaviour: + +\(defun org-e-latex-format-drawer-default \(name contents\) + \"Format a drawer element for LaTeX export.\" + contents\)" + :group 'org-export-e-latex + :type 'function) + + +;;;; Inlinetasks + +(defcustom org-e-latex-format-inlinetask-function nil + "Function called to format an inlinetask in LaTeX code. + +The function must accept six parameters: + TODO the todo keyword, as a string + TODO-TYPE the todo type, a symbol among `todo', `done' and nil. + PRIORITY the inlinetask priority, as a string + NAME the inlinetask name, as a string. + TAGS the inlinetask tags, as a list of strings. + CONTENTS the contents of the inlinetask, as a string. + +The function should return the string to be exported. + +For example, the variable could be set to the following function +in order to mimic default behaviour: + +\(defun org-e-latex-format-inlinetask \(todo type priority name tags contents\) +\"Format an inline task element for LaTeX export.\" + \(let ((full-title + \(concat + \(when todo + \(format \"\\\\textbf{\\\\textsf{\\\\textsc{%s}}} \" todo)) + \(when priority (format \"\\\\framebox{\\\\#%c} \" priority)) + title + \(when tags + \(format \"\\\\hfill{}\\\\textsc{:%s:}\" + \(mapconcat 'identity tags \":\"))))) + \(format (concat \"\\\\begin{center}\\n\" + \"\\\\fbox{\\n\" + \"\\\\begin{minipage}[c]{.6\\\\textwidth}\\n\" + \"%s\\n\\n\" + \"\\\\rule[.8em]{\\\\textwidth}{2pt}\\n\\n\" + \"%s\" + \"\\\\end{minipage}}\" + \"\\\\end{center}\") + full-title contents))" + :group 'org-export-e-latex + :type 'function) + + +;; Src blocks + +(defcustom org-e-latex-listings nil + "Non-nil means export source code using the listings package. +This package will fontify source code, possibly even with color. +If you want to use this, you also need to make LaTeX use the +listings package, and if you want to have color, the color +package. Just add these to `org-export-latex-packages-alist', +for example using customize, or with something like: + + \(require 'org-e-latex) + \(add-to-list 'org-export-latex-packages-alist '\(\"\" \"listings\")) + \(add-to-list 'org-export-latex-packages-alist '\(\"\" \"color\")) + +Alternatively, + + \(setq org-e-latex-listings 'minted) + +causes source code to be exported using the minted package as +opposed to listings. If you want to use minted, you need to add +the minted package to `org-export-latex-packages-alist', for +example using customize, or with + + \(require 'org-e-latex) + \(add-to-list 'org-export-latex-packages-alist '\(\"\" \"minted\")) + +In addition, it is necessary to install pygments +\(http://pygments.org), and to configure the variable +`org-e-latex-pdf-process' so that the -shell-escape option is +passed to pdflatex." + :group 'org-export-e-latex + :type '(choice + (const :tag "Use listings" t) + (const :tag "Use minted" 'minted) + (const :tag "Export verbatim" nil))) + +(defcustom org-e-latex-listings-langs + '((emacs-lisp "Lisp") (lisp "Lisp") (clojure "Lisp") + (c "C") (cc "C++") + (fortran "fortran") + (perl "Perl") (cperl "Perl") (python "Python") (ruby "Ruby") + (html "HTML") (xml "XML") + (tex "TeX") (latex "TeX") + (shell-script "bash") + (gnuplot "Gnuplot") + (ocaml "Caml") (caml "Caml") + (sql "SQL") (sqlite "sql")) + "Alist mapping languages to their listing language counterpart. +The key is a symbol, the major mode symbol without the \"-mode\". +The value is the string that should be inserted as the language +parameter for the listings package. If the mode name and the +listings name are the same, the language does not need an entry +in this list - but it does not hurt if it is present." + :group 'org-export-e-latex + :type '(repeat + (list + (symbol :tag "Major mode ") + (string :tag "Listings language")))) + +(defcustom org-e-latex-listings-options nil + "Association list of options for the latex listings package. + +These options are supplied as a comma-separated list to the +\\lstset command. Each element of the association list should be +a list containing two strings: the name of the option, and the +value. For example, + + (setq org-e-latex-listings-options + '((\"basicstyle\" \"\\small\") + (\"keywordstyle\" \"\\color{black}\\bfseries\\underbar\"))) + +will typeset the code in a small size font with underlined, bold +black keywords. + +Note that the same options will be applied to blocks of all +languages." + :group 'org-export-e-latex + :type '(repeat + (list + (string :tag "Listings option name ") + (string :tag "Listings option value")))) + +(defcustom org-e-latex-minted-langs + '((emacs-lisp "common-lisp") + (cc "c++") + (cperl "perl") + (shell-script "bash") + (caml "ocaml")) + "Alist mapping languages to their minted language counterpart. +The key is a symbol, the major mode symbol without the \"-mode\". +The value is the string that should be inserted as the language +parameter for the minted package. If the mode name and the +listings name are the same, the language does not need an entry +in this list - but it does not hurt if it is present. + +Note that minted uses all lower case for language identifiers, +and that the full list of language identifiers can be obtained +with: + + pygmentize -L lexers" + :group 'org-export-e-latex + :type '(repeat + (list + (symbol :tag "Major mode ") + (string :tag "Minted language")))) + +(defcustom org-e-latex-minted-options nil + "Association list of options for the latex minted package. + +These options are supplied within square brackets in +\\begin{minted} environments. Each element of the alist should +be a list containing two strings: the name of the option, and the +value. For example, + + \(setq org-e-latex-minted-options + '\((\"bgcolor\" \"bg\") \(\"frame\" \"lines\"))) + +will result in src blocks being exported with + +\\begin{minted}[bgcolor=bg,frame=lines]{} + +as the start of the minted environment. Note that the same +options will be applied to blocks of all languages." + :group 'org-export-e-latex + :type '(repeat + (list + (string :tag "Minted option name ") + (string :tag "Minted option value")))) + +(defvar org-e-latex-custom-lang-environments nil + "Alist mapping languages to language-specific LaTeX environments. + +It is used during export of src blocks by the listings and minted +latex packages. For example, + + \(setq org-e-latex-custom-lang-environments + '\(\(python \"pythoncode\"\)\)\) + +would have the effect that if org encounters begin_src python +during latex export it will output + + \\begin{pythoncode} + + \\end{pythoncode}") + + +;;;; Plain text + +(defcustom org-e-latex-quotes + '(("fr" + ("\\(\\s-\\|[[(]\\|^\\)\"" . "«~") + ("\\(\\S-\\)\"" . "~»") + ("\\(\\s-\\|(\\|^\\)'" . "'")) + ("en" + ("\\(\\s-\\|[[(]\\|^\\)\"" . "``") + ("\\(\\S-\\)\"" . "''") + ("\\(\\s-\\|(\\|^\\)'" . "`"))) + "Alist for quotes to use when converting english double-quotes. + +The CAR of each item in this alist is the language code. +The CDR of each item in this alist is a list of three CONS: +- the first CONS defines the opening quote; +- the second CONS defines the closing quote; +- the last CONS defines single quotes. + +For each item in a CONS, the first string is a regexp +for allowed characters before/after the quote, the second +string defines the replacement string for this quote." + :group 'org-export-e-latex + :type '(list + (cons :tag "Opening quote" + (string :tag "Regexp for char before") + (string :tag "Replacement quote ")) + (cons :tag "Closing quote" + (string :tag "Regexp for char after ") + (string :tag "Replacement quote ")) + (cons :tag "Single quote" + (string :tag "Regexp for char before") + (string :tag "Replacement quote ")))) + + +;;;; Compilation + +(defcustom org-e-latex-pdf-process + '("pdflatex -interaction nonstopmode -output-directory %o %f" + "pdflatex -interaction nonstopmode -output-directory %o %f" + "pdflatex -interaction nonstopmode -output-directory %o %f") + "Commands to process a LaTeX file to a PDF file. +This is a list of strings, each of them will be given to the +shell as a command. %f in the command will be replaced by the +full file name, %b by the file base name \(i.e. without +extension) and %o by the base directory of the file. + +The reason why this is a list is that it usually takes several +runs of `pdflatex', maybe mixed with a call to `bibtex'. Org +does not have a clever mechanism to detect which of these +commands have to be run to get to a stable result, and it also +does not do any error checking. + +By default, Org uses 3 runs of `pdflatex' to do the processing. +If you have texi2dvi on your system and if that does not cause +the infamous egrep/locale bug: + + http://lists.gnu.org/archive/html/bug-texinfo/2010-03/msg00031.html + +then `texi2dvi' is the superior choice. Org does offer it as one +of the customize options. + +Alternatively, this may be a Lisp function that does the +processing, so you could use this to apply the machinery of +AUCTeX or the Emacs LaTeX mode. This function should accept the +file name as its single argument." + :group 'org-export-pdf + :type '(choice + (repeat :tag "Shell command sequence" + (string :tag "Shell command")) + (const :tag "2 runs of pdflatex" + ("pdflatex -interaction nonstopmode -output-directory %o %f" + "pdflatex -interaction nonstopmode -output-directory %o %f")) + (const :tag "3 runs of pdflatex" + ("pdflatex -interaction nonstopmode -output-directory %o %f" + "pdflatex -interaction nonstopmode -output-directory %o %f" + "pdflatex -interaction nonstopmode -output-directory %o %f")) + (const :tag "pdflatex,bibtex,pdflatex,pdflatex" + ("pdflatex -interaction nonstopmode -output-directory %o %f" + "bibtex %b" + "pdflatex -interaction nonstopmode -output-directory %o %f" + "pdflatex -interaction nonstopmode -output-directory %o %f")) + (const :tag "texi2dvi" + ("texi2dvi -p -b -c -V %f")) + (const :tag "rubber" + ("rubber -d --into %o %f")) + (function))) + +(defcustom org-e-latex-logfiles-extensions + '("aux" "idx" "log" "out" "toc" "nav" "snm" "vrb") + "The list of file extensions to consider as LaTeX logfiles." + :group 'org-export-e-latex + :type '(repeat (string :tag "Extension"))) + +(defcustom org-e-latex-remove-logfiles t + "Non-nil means remove the logfiles produced by PDF production. +These are the .aux, .log, .out, and .toc files." + :group 'org-export-e-latex + :type 'boolean) + + + +;;; Internal Functions + +(defun org-e-latex--caption/label-string (caption label info) + "Return caption and label LaTeX string for floats. + +CAPTION is a cons cell of secondary strings, the car being the +standard caption and the cdr its short form. LABEL is a string +representing the label. INFO is a plist holding contextual +information. + +If there's no caption nor label, return the empty string. + +For non-floats, see `org-e-latex--wrap-label'." + (let ((label-str (if label (format "\\label{%s}" label) ""))) + (cond + ((and (not caption) (not label)) "") + ((not caption) (format "\\label{%s}\n" label)) + ;; Option caption format with short name. + ((cdr caption) + (format "\\caption[%s]{%s%s}\n" + (org-export-data (cdr caption) info) + label-str + (org-export-data (car caption) info))) + ;; Standard caption format. + (t (format "\\caption{%s%s}\n" + label-str + (org-export-data (car caption) info)))))) + +(defun org-e-latex--guess-babel-language (header info) + "Set Babel's language according to LANGUAGE keyword. + +HEADER is the LaTeX header string. INFO is the plist used as +a communication channel. + +Insertion of guessed language only happens when Babel package has +explicitly been loaded. Then it is added to the rest of +package's options. + +Return the new header." + (let ((language-code (plist-get info :language))) + ;; If no language is set or Babel package is not loaded, return + ;; HEADER as-is. + (if (or (not (stringp language-code)) + (not (string-match "\\\\usepackage\\[\\(.*\\)\\]{babel}" header))) + header + (let ((options (save-match-data + (org-split-string (match-string 1 header) ","))) + (language (cdr (assoc language-code + org-e-latex-babel-language-alist)))) + ;; If LANGUAGE is already loaded, return header. Otherwise, + ;; append LANGUAGE to other options. + (if (member language options) header + (replace-match (mapconcat 'identity + (append options (list language)) + ",") + nil nil header 1)))))) + +(defun org-e-latex--guess-inputenc (header) + "Set the coding system in inputenc to what the buffer is. +HEADER is the LaTeX header string. Return the new header." + (let* ((cs (or (ignore-errors + (latexenc-coding-system-to-inputenc + buffer-file-coding-system)) + "utf8"))) + (if (not cs) header + ;; First translate if that is requested. + (setq cs (or (cdr (assoc cs org-e-latex-inputenc-alist)) cs)) + ;; Then find the \usepackage statement and replace the option. + (replace-regexp-in-string "\\\\usepackage\\[\\(AUTO\\)\\]{inputenc}" + cs header t nil 1)))) + +(defun org-e-latex--find-verb-separator (s) + "Return a character not used in string S. +This is used to choose a separator for constructs like \\verb." + (let ((ll "~,./?;':\"|!@#%^&-_=+abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ<>()[]{}")) + (loop for c across ll + when (not (string-match (regexp-quote (char-to-string c)) s)) + return (char-to-string c)))) + +(defun org-e-latex--make-option-string (options) + "Return a comma separated string of keywords and values. +OPTIONS is an alist where the key is the options keyword as +a string, and the value a list containing the keyword value, or +nil." + (mapconcat (lambda (pair) + (concat (first pair) + (when (> (length (second pair)) 0) + (concat "=" (second pair))))) + options + ",")) + +(defun org-e-latex--quotation-marks (text info) + "Export quotation marks depending on language conventions. +TEXT is a string containing quotation marks to be replaced. INFO +is a plist used as a communication channel." + (mapc (lambda(l) + (let ((start 0)) + (while (setq start (string-match (car l) text start)) + (let ((new-quote (concat (match-string 1 text) (cdr l)))) + (setq text (replace-match new-quote t t text)))))) + (cdr (or (assoc (plist-get info :language) org-e-latex-quotes) + ;; Falls back on English. + (assoc "en" org-e-latex-quotes)))) + text) + +(defun org-e-latex--wrap-label (element output) + "Wrap label associated to ELEMENT around OUTPUT, if appropriate. +This function shouldn't be used for floats. See +`org-e-latex--caption/label-string'." + (let ((label (org-element-property :name element))) + (if (or (not output) (not label) (string= output "") (string= label "")) + output + (concat (format "\\label{%s}\n" label) output)))) + +(defun org-e-latex--text-markup (text markup) + "Format TEXT depending on MARKUP text markup. +See `org-e-latex-text-markup-alist' for details." + (let ((fmt (cdr (assq markup org-e-latex-text-markup-alist)))) + (cond + ;; No format string: Return raw text. + ((not fmt) text) + ;; Handle the `verb' special case: Find and appropriate separator + ;; and use "\\verb" command. + ((eq 'verb fmt) + (let ((separator (org-e-latex--find-verb-separator text))) + (concat "\\verb" separator text separator))) + ;; Handle the `protectedtexttt' special case: Protect some + ;; special chars and use "\texttt{%s}" format string. + ((eq 'protectedtexttt fmt) + (let ((start 0) + (trans '(("\\" . "\\textbackslash{}") + ("~" . "\\textasciitilde{}") + ("^" . "\\textasciicircum{}"))) + (rtn "") + char) + (while (string-match "[\\{}$%&_#~^]" text) + (setq char (match-string 0 text)) + (if (> (match-beginning 0) 0) + (setq rtn (concat rtn (substring text 0 (match-beginning 0))))) + (setq text (substring text (1+ (match-beginning 0)))) + (setq char (or (cdr (assoc char trans)) (concat "\\" char)) + rtn (concat rtn char))) + (setq text (concat rtn text) + fmt "\\texttt{%s}") + (while (string-match "--" text) + (setq text (replace-match "-{}-" t t text))) + (format fmt text))) + ;; Else use format string. + (t (format fmt text))))) + +(defun org-e-latex--delayed-footnotes-definitions (element info) + "Return footnotes definitions in ELEMENT as a string. + +INFO is a plist used as a communication channel. + +Footnotes definitions are returned within \"\\footnotetxt{}\" +commands. + +This function is used within constructs that don't support +\"\\footnote{}\" command (i.e. an item's tag). In that case, +\"\\footnotemark\" is used within the construct and the function +just outside of it." + (mapconcat + (lambda (ref) + (format + "\\footnotetext[%s]{%s}" + (org-export-get-footnote-number ref info) + (org-trim + (org-export-data + (org-export-get-footnote-definition ref info) info)))) + ;; Find every footnote reference in ELEMENT. + (let* (all-refs + search-refs ; For byte-compiler. + (search-refs + (function + (lambda (data) + ;; Return a list of all footnote references never seen + ;; before in DATA. + (org-element-map + data 'footnote-reference + (lambda (ref) + (when (org-export-footnote-first-reference-p ref info) + (push ref all-refs) + (when (eq (org-element-property :type ref) 'standard) + (funcall search-refs + (org-export-get-footnote-definition ref info))))) + info) + (reverse all-refs))))) + (funcall search-refs element)) + "")) + + + +;;; Template + +(defun org-e-latex-template (contents info) + "Return complete document string after LaTeX conversion. +CONTENTS is the transcoded contents string. INFO is a plist +holding export options." + (let ((title (org-export-data (plist-get info :title) info))) + (concat + ;; Time-stamp. + (and (plist-get info :time-stamp-file) + (format-time-string "%% Created %Y-%m-%d %a %H:%M\n")) + ;; Document class and packages. + (let ((class (plist-get info :latex-class)) + (class-options (plist-get info :latex-class-options))) + (org-element-normalize-string + (let* ((header (nth 1 (assoc class org-e-latex-classes))) + (document-class-string + (and (stringp header) + (if class-options + (replace-regexp-in-string + "^[ \t]*\\\\documentclass\\(\\[.*?\\]\\)" + class-options header t nil 1) + header)))) + (when document-class-string + (org-e-latex--guess-babel-language + (org-e-latex--guess-inputenc + (org-splice-latex-header + document-class-string + org-export-latex-default-packages-alist ; defined in org.el + org-export-latex-packages-alist nil ; defined in org.el + (plist-get info :latex-header-extra))) + info))))) + ;; Possibly limit depth for headline numbering. + (let ((sec-num (plist-get info :section-numbers))) + (when (integerp sec-num) + (format "\\setcounter{secnumdepth}{%d}\n" sec-num))) + ;; Author. + (let ((author (and (plist-get info :with-author) + (let ((auth (plist-get info :author))) + (and auth (org-export-data auth info))))) + (email (and (plist-get info :with-email) + (org-export-data (plist-get info :email) info)))) + (cond ((and author email (not (string= "" email))) + (format "\\author{%s\\thanks{%s}}\n" author email)) + (author (format "\\author{%s}\n" author)) + (t "\\author{}\n"))) + ;; Date. + (let ((date (org-export-data (plist-get info :date) info))) + (and date (format "\\date{%s}\n" date))) + ;; Title + (format "\\title{%s}\n" title) + ;; Hyperref options. + (format "\\hypersetup{\n pdfkeywords={%s},\n pdfsubject={%s},\n pdfcreator={%s}}\n" + (or (plist-get info :keywords) "") + (or (plist-get info :description) "") + (if (not (plist-get info :with-creator)) "" + (plist-get info :creator))) + ;; Document start. + "\\begin{document}\n\n" + ;; Title command. + (org-element-normalize-string + (cond ((string= "" title) nil) + ((not (stringp org-e-latex-title-command)) nil) + ((string-match "\\(?:[^%]\\|^\\)%s" + org-e-latex-title-command) + (format org-e-latex-title-command title)) + (t org-e-latex-title-command))) + ;; Table of contents. + (let ((depth (plist-get info :with-toc))) + (when depth + (concat (when (wholenump depth) + (format "\\setcounter{tocdepth}{%d}\n" depth)) + "\\tableofcontents\n\\vspace*{1cm}\n\n"))) + ;; Document's body. + contents + ;; Creator. + (let ((creator-info (plist-get info :with-creator))) + (cond + ((not creator-info) "") + ((eq creator-info 'comment) + (format "%% %s\n" (plist-get info :creator))) + (t (concat (plist-get info :creator) "\n")))) + ;; Document end. + "\\end{document}"))) + + + +;;; Transcode Functions + +;;;; Babel Call +;; +;; Babel Calls are ignored. + + +;;;; Bold + +(defun org-e-latex-bold (bold contents info) + "Transcode BOLD from Org to LaTeX. +CONTENTS is the text with bold markup. INFO is a plist holding +contextual information." + (org-e-latex--text-markup contents 'bold)) + + +;;;; Center Block + +(defun org-e-latex-center-block (center-block contents info) + "Transcode a CENTER-BLOCK element from Org to LaTeX. +CONTENTS holds the contents of the center block. INFO is a plist +holding contextual information." + (org-e-latex--wrap-label + center-block + (format "\\begin{center}\n%s\\end{center}" contents))) + + +;;;; Clock + +(defun org-e-latex-clock (clock contents info) + "Transcode a CLOCK element from Org to LaTeX. +CONTENTS is nil. INFO is a plist holding contextual +information." + (concat + "\\noindent" + (format "\\textbf{%s} " org-clock-string) + (format org-e-latex-inactive-timestamp-format + (concat (org-translate-time (org-element-property :value clock)) + (let ((time (org-element-property :time clock))) + (and time (format " (%s)" time))))) + "\\\\")) + + +;;;; Code + +(defun org-e-latex-code (code contents info) + "Transcode a CODE object from Org to LaTeX. +CONTENTS is nil. INFO is a plist used as a communication +channel." + (org-e-latex--text-markup (org-element-property :value code) 'code)) + + +;;;; Comment +;; +;; Comments are ignored. + + +;;;; Comment Block +;; +;; Comment Blocks are ignored. + + +;;;; Drawer + +(defun org-e-latex-drawer (drawer contents info) + "Transcode a DRAWER element from Org to LaTeX. +CONTENTS holds the contents of the block. INFO is a plist +holding contextual information." + (let* ((name (org-element-property :drawer-name drawer)) + (output (if (functionp org-e-latex-format-drawer-function) + (funcall org-e-latex-format-drawer-function + name contents) + ;; If there's no user defined function: simply + ;; display contents of the drawer. + contents))) + (org-e-latex--wrap-label drawer output))) + + +;;;; Dynamic Block + +(defun org-e-latex-dynamic-block (dynamic-block contents info) + "Transcode a DYNAMIC-BLOCK element from Org to LaTeX. +CONTENTS holds the contents of the block. INFO is a plist +holding contextual information. See `org-export-data'." + (org-e-latex--wrap-label dynamic-block contents)) + + +;;;; Entity + +(defun org-e-latex-entity (entity contents info) + "Transcode an ENTITY object from Org to LaTeX. +CONTENTS are the definition itself. INFO is a plist holding +contextual information." + (let ((ent (org-element-property :latex entity))) + (if (org-element-property :latex-math-p entity) (format "$%s$" ent) ent))) + + +;;;; Example Block + +(defun org-e-latex-example-block (example-block contents info) + "Transcode an EXAMPLE-BLOCK element from Org to LaTeX. +CONTENTS is nil. INFO is a plist holding contextual +information." + (org-e-latex--wrap-label + example-block + (format "\\begin{verbatim}\n%s\\end{verbatim}" + (org-export-format-code-default example-block info)))) + + +;;;; Export Block + +(defun org-e-latex-export-block (export-block contents info) + "Transcode a EXPORT-BLOCK element from Org to LaTeX. +CONTENTS is nil. INFO is a plist holding contextual information." + (when (string= (org-element-property :type export-block) "LATEX") + (org-remove-indentation (org-element-property :value export-block)))) + + +;;;; Export Snippet + +(defun org-e-latex-export-snippet (export-snippet contents info) + "Transcode a EXPORT-SNIPPET object from Org to LaTeX. +CONTENTS is nil. INFO is a plist holding contextual information." + (when (eq (org-export-snippet-backend export-snippet) 'e-latex) + (org-element-property :value export-snippet))) + + +;;;; Fixed Width + +(defun org-e-latex-fixed-width (fixed-width contents info) + "Transcode a FIXED-WIDTH element from Org to LaTeX. +CONTENTS is nil. INFO is a plist holding contextual information." + (org-e-latex--wrap-label + fixed-width + (format "\\begin{verbatim}\n%s\\end{verbatim}" + (org-remove-indentation + (org-element-property :value fixed-width))))) + + +;;;; Footnote Definition +;; +;; Footnote Definitions are ignored. + + +;;;; Footnote Reference +;; +;; Footnote reference export is handled by +;; `org-e-latex-footnote-reference'. +;; +;; Internally, `org-e-latex--get-footnote-counter' is used to restore +;; the value of the LaTeX "footnote" counter after a jump due to +;; a reference to an already defined footnote. It is only needed in +;; item tags since the optional argument to \footnotemark is not +;; allowed there. + +(defun org-e-latex--get-footnote-counter (footnote-reference info) + "Return \"footnote\" counter before FOOTNOTE-REFERENCE is encountered. +INFO is a plist used as a communication channel." + ;; Find original counter value by counting number of footnote + ;; references appearing for the first time before the current + ;; footnote reference. + (let* ((label (org-element-property :label footnote-reference)) + seen-refs + search-ref ; For byte-compiler. + (search-ref + (function + (lambda (data) + ;; Search footnote references through DATA, filling + ;; SEEN-REFS along the way. + (org-element-map + data 'footnote-reference + (lambda (fn) + (let ((fn-lbl (org-element-property :label fn))) + (cond + ;; Anonymous footnote match: return number. + ((eq fn footnote-reference) (length seen-refs)) + ;; Anonymous footnote: it's always a new one. + ;; Also, be sure to return nil from the `cond' so + ;; `first-match' doesn't get us out of the loop. + ((not fn-lbl) (push 'inline seen-refs) nil) + ;; Label not seen so far: add it so SEEN-REFS. + ;; + ;; Also search for subsequent references in + ;; footnote definition so numbering follows reading + ;; logic. Note that we don't have to care about + ;; inline definitions, since `org-element-map' + ;; already traverse them at the right time. + ((not (member fn-lbl seen-refs)) + (push fn-lbl seen-refs) + (funcall search-ref + (org-export-get-footnote-definition fn info)))))) + ;; Don't enter footnote definitions since it will happen + ;; when their first reference is found. + info 'first-match 'footnote-definition))))) + (funcall search-ref (plist-get info :parse-tree)))) + +(defun org-e-latex-footnote-reference (footnote-reference contents info) + "Transcode a FOOTNOTE-REFERENCE element from Org to LaTeX. +CONTENTS is nil. INFO is a plist holding contextual information." + (concat + ;; Insert separator between two footnotes in a row. + (let ((prev (org-export-get-previous-element footnote-reference info))) + (when (eq (org-element-type prev) 'footnote-reference) + org-e-latex-footnote-separator)) + (cond + ;; Use \footnotemark if reference is within an item's tag. + ((eq (org-element-type (org-export-get-parent-element footnote-reference)) + 'item) + (if (org-export-footnote-first-reference-p footnote-reference info) + "\\footnotemark" + ;; Since we can't specify footnote number as an optional + ;; argument within an item tag, some extra work has to be done + ;; when the footnote has already been referenced. In that + ;; case, set footnote counter to the desired number, use the + ;; footnotemark, then set counter back to its original value. + (format + "\\setcounter{footnote}{%s}\\footnotemark\\setcounter{footnote}{%s}" + (1- (org-export-get-footnote-number footnote-reference info)) + (org-e-latex--get-footnote-counter footnote-reference info)))) + ;; Use \footnotemark if the footnote has already been defined. + ((not (org-export-footnote-first-reference-p footnote-reference info)) + (format "\\footnotemark[%s]{}" + (org-export-get-footnote-number footnote-reference info))) + ;; Use \footnotemark if reference is within another footnote + ;; reference or footnote definition. + ((loop for parent in (org-export-get-genealogy footnote-reference) + thereis (memq (org-element-type parent) + '(footnote-reference footnote-definition))) + "\\footnotemark") + ;; Otherwise, define it with \footnote command. + (t + (let ((def (org-export-get-footnote-definition footnote-reference info))) + (unless (eq (org-element-type def) 'org-data) + (setq def (cons 'org-data (cons nil def)))) + (concat + (format "\\footnote{%s}" (org-trim (org-export-data def info))) + ;; Retrieve all footnote references within the footnote and + ;; add their definition after it, since LaTeX doesn't support + ;; them inside. + (org-e-latex--delayed-footnotes-definitions def info))))))) + + +;;;; Headline + +(defun org-e-latex-headline (headline contents info) + "Transcode an HEADLINE element from Org to LaTeX. +CONTENTS holds the contents of the headline. INFO is a plist +holding contextual information." + (let* ((class (plist-get info :latex-class)) + (level (org-export-get-relative-level headline info)) + (numberedp (org-export-numbered-headline-p headline info)) + (class-sectionning (assoc class org-e-latex-classes)) + ;; Section formatting will set two placeholders: one for the + ;; title and the other for the contents. + (section-fmt + (let ((sec (if (and (symbolp (nth 2 class-sectionning)) + (fboundp (nth 2 class-sectionning))) + (funcall (nth 2 class-sectionning) level numberedp) + (nth (1+ level) class-sectionning)))) + (cond + ;; No section available for that LEVEL. + ((not sec) nil) + ;; Section format directly returned by a function. + ((stringp sec) sec) + ;; (numbered-section . unnumbered-section) + ((not (consp (cdr sec))) + (concat (funcall (if numberedp #'car #'cdr) sec) "\n%s")) + ;; (numbered-open numbered-close) + ((= (length sec) 2) + (when numberedp (concat (car sec) "\n%s" (nth 1 sec)))) + ;; (num-in num-out no-num-in no-num-out) + ((= (length sec) 4) + (if numberedp (concat (car sec) "\n%s" (nth 1 sec)) + (concat (nth 2 sec) "\n%s" (nth 3 sec))))))) + (text (org-export-data (org-element-property :title headline) info)) + (todo + (and (plist-get info :with-todo-keywords) + (let ((todo (org-element-property :todo-keyword headline))) + (and todo (org-export-data todo info))))) + (todo-type (and todo (org-element-property :todo-type headline))) + (tags (and (plist-get info :with-tags) + (org-export-get-tags headline info))) + (priority (and (plist-get info :with-priority) + (org-element-property :priority headline))) + ;; Create the headline text along with a no-tag version. The + ;; latter is required to remove tags from table of contents. + (full-text (if (functionp org-e-latex-format-headline-function) + ;; User-defined formatting function. + (funcall org-e-latex-format-headline-function + todo todo-type priority text tags) + ;; Default formatting. + (concat + (when todo + (format "\\textbf{\\textsf{\\textsc{%s}}} " todo)) + (when priority (format "\\framebox{\\#%c} " priority)) + text + (when tags + (format "\\hfill{}\\textsc{:%s:}" + (mapconcat 'identity tags ":")))))) + (full-text-no-tag + (if (functionp org-e-latex-format-headline-function) + ;; User-defined formatting function. + (funcall org-e-latex-format-headline-function + todo todo-type priority text nil) + ;; Default formatting. + (concat + (when todo (format "\\textbf{\\textsf{\\textsc{%s}}} " todo)) + (when priority (format "\\framebox{\\#%c} " priority)) + text))) + ;; Associate some \label to the headline for internal links. + (headline-label + (format "\\label{sec-%s}\n" + (mapconcat 'number-to-string + (org-export-get-headline-number headline info) + "-"))) + (pre-blanks + (make-string (org-element-property :pre-blank headline) 10))) + (cond + ;; Case 1: This is a footnote section: ignore it. + ((org-element-property :footnote-section-p headline) nil) + ;; Case 2. This is a deep sub-tree: export it as a list item. + ;; Also export as items headlines for which no section + ;; format has been found. + ((or (not section-fmt) (org-export-low-level-p headline info)) + ;; Build the real contents of the sub-tree. + (let ((low-level-body + (concat + ;; If the headline is the first sibling, start a list. + (when (org-export-first-sibling-p headline info) + (format "\\begin{%s}\n" (if numberedp 'enumerate 'itemize))) + ;; Itemize headline + "\\item " full-text "\n" headline-label pre-blanks contents))) + ;; If headline is not the last sibling simply return + ;; LOW-LEVEL-BODY. Otherwise, also close the list, before any + ;; blank line. + (if (not (org-export-last-sibling-p headline info)) low-level-body + (replace-regexp-in-string + "[ \t\n]*\\'" + (format "\n\\\\end{%s}" (if numberedp 'enumerate 'itemize)) + low-level-body)))) + ;; Case 3. Standard headline. Export it as a section. + (t + (cond + ((not (and tags (eq (plist-get info :with-tags) 'not-in-toc))) + ;; Regular section. Use specified format string. + (format section-fmt full-text + (concat headline-label pre-blanks contents))) + ((string-match "\\`\\\\\\(.*?\\){" section-fmt) + ;; If tags should be removed from table of contents, insert + ;; title without tags as an alternative heading in sectioning + ;; command. + (format (replace-match (concat (match-string 1 section-fmt) "[%s]") + nil nil section-fmt 1) + ;; Replace square brackets with parenthesis since + ;; square brackets are not supported in optional + ;; arguments. + (replace-regexp-in-string + "\\[" "(" + (replace-regexp-in-string + "\\]" ")" + full-text-no-tag)) + full-text + (concat headline-label pre-blanks contents))) + (t + ;; Impossible to add an alternative heading. Fallback to + ;; regular sectioning format string. + (format section-fmt full-text + (concat headline-label pre-blanks contents)))))))) + + +;;;; Horizontal Rule + +(defun org-e-latex-horizontal-rule (horizontal-rule contents info) + "Transcode an HORIZONTAL-RULE object from Org to LaTeX. +CONTENTS is nil. INFO is a plist holding contextual information." + (let ((attr (org-export-read-attribute :attr_latex horizontal-rule)) + (prev (org-export-get-previous-element horizontal-rule info))) + (concat + ;; Make sure the rule doesn't start at the end of the current + ;; line by separating it with a blank line from previous element. + (when (and prev + (let ((prev-blank (org-element-property :post-blank prev))) + (or (not prev-blank) (zerop prev-blank)))) + "\n") + (org-e-latex--wrap-label + horizontal-rule + (format "\\rule{%s}{%s}" + (or (plist-get attr :width) "\\linewidth") + (or (plist-get attr :thickness) "0.5pt")))))) + + +;;;; Inline Babel Call +;; +;; Inline Babel Calls are ignored. + + +;;;; Inline Src Block + +(defun org-e-latex-inline-src-block (inline-src-block contents info) + "Transcode an INLINE-SRC-BLOCK element from Org to LaTeX. +CONTENTS holds the contents of the item. INFO is a plist holding +contextual information." + (let* ((code (org-element-property :value inline-src-block)) + (separator (org-e-latex--find-verb-separator code))) + (cond + ;; Do not use a special package: transcode it verbatim. + ((not org-e-latex-listings) + (concat "\\verb" separator code separator)) + ;; Use minted package. + ((eq org-e-latex-listings 'minted) + (let* ((org-lang (org-element-property :language inline-src-block)) + (mint-lang (or (cadr (assq (intern org-lang) + org-e-latex-minted-langs)) + org-lang)) + (options (org-e-latex--make-option-string + org-e-latex-minted-options))) + (concat (format "\\mint%s{%s}" + (if (string= options "") "" (format "[%s]" options)) + mint-lang) + separator code separator))) + ;; Use listings package. + (t + ;; Maybe translate language's name. + (let* ((org-lang (org-element-property :language inline-src-block)) + (lst-lang (or (cadr (assq (intern org-lang) + org-e-latex-listings-langs)) + org-lang)) + (options (org-e-latex--make-option-string + (append org-e-latex-listings-options + `(("language" ,lst-lang)))))) + (concat (format "\\lstinline[%s]" options) + separator code separator)))))) + + +;;;; Inlinetask + +(defun org-e-latex-inlinetask (inlinetask contents info) + "Transcode an INLINETASK element from Org to LaTeX. +CONTENTS holds the contents of the block. INFO is a plist +holding contextual information." + (let ((title (org-export-data (org-element-property :title inlinetask) info)) + (todo (and (plist-get info :with-todo-keywords) + (let ((todo (org-element-property :todo-keyword inlinetask))) + (and todo (org-export-data todo info))))) + (todo-type (org-element-property :todo-type inlinetask)) + (tags (and (plist-get info :with-tags) + (org-export-get-tags inlinetask info))) + (priority (and (plist-get info :with-priority) + (org-element-property :priority inlinetask)))) + ;; If `org-e-latex-format-inlinetask-function' is provided, call it + ;; with appropriate arguments. + (if (functionp org-e-latex-format-inlinetask-function) + (funcall org-e-latex-format-inlinetask-function + todo todo-type priority title tags contents) + ;; Otherwise, use a default template. + (org-e-latex--wrap-label + inlinetask + (let ((full-title + (concat + (when todo (format "\\textbf{\\textsf{\\textsc{%s}}} " todo)) + (when priority (format "\\framebox{\\#%c} " priority)) + title + (when tags (format "\\hfill{}\\textsc{:%s:}" + (mapconcat 'identity tags ":")))))) + (format (concat "\\begin{center}\n" + "\\fbox{\n" + "\\begin{minipage}[c]{.6\\textwidth}\n" + "%s\n\n" + "\\rule[.8em]{\\textwidth}{2pt}\n\n" + "%s" + "\\end{minipage}\n" + "}\n" + "\\end{center}") + full-title contents)))))) + + +;;;; Italic + +(defun org-e-latex-italic (italic contents info) + "Transcode ITALIC from Org to LaTeX. +CONTENTS is the text with italic markup. INFO is a plist holding +contextual information." + (org-e-latex--text-markup contents 'italic)) + + +;;;; Item + +(defun org-e-latex-item (item contents info) + "Transcode an ITEM element from Org to LaTeX. +CONTENTS holds the contents of the item. INFO is a plist holding +contextual information." + (let* ((counter + (let ((count (org-element-property :counter item)) + (level + (loop for parent in (org-export-get-genealogy item) + count (eq (org-element-type parent) 'plain-list) + until (eq (org-element-type parent) 'headline)))) + (and count + (< level 5) + (format "\\setcounter{enum%s}{%s}\n" + (nth (1- level) '("i" "ii" "iii" "iv")) + (1- count))))) + (checkbox (case (org-element-property :checkbox item) + (on "$\\boxtimes$ ") + (off "$\\Box$ ") + (trans "$\\boxminus$ "))) + (tag (let ((tag (org-element-property :tag item))) + ;; Check-boxes must belong to the tag. + (and tag (format "[%s] " + (concat checkbox + (org-export-data tag info))))))) + (concat counter "\\item" (or tag (concat " " checkbox)) + (and contents (org-trim contents)) + ;; If there are footnotes references in tag, be sure to + ;; add their definition at the end of the item. This + ;; workaround is necessary since "\footnote{}" command is + ;; not supported in tags. + (and tag + (org-e-latex--delayed-footnotes-definitions + (org-element-property :tag item) info))))) + + +;;;; Keyword + +(defun org-e-latex-keyword (keyword contents info) + "Transcode a KEYWORD element from Org to LaTeX. +CONTENTS is nil. INFO is a plist holding contextual information." + (let ((key (org-element-property :key keyword)) + (value (org-element-property :value keyword))) + (cond + ((string= key "LATEX") value) + ((string= key "INDEX") (format "\\index{%s}" value)) + ;; Invisible targets. + ((string= key "TARGET") nil) + ((string= key "TOC") + (let ((value (downcase value))) + (cond + ((string-match "\\" value) + (let ((depth (or (and (string-match "[0-9]+" value) + (string-to-number (match-string 0 value))) + (plist-get info :with-toc)))) + (concat + (when (wholenump depth) + (format "\\setcounter{tocdepth}{%s}\n" depth)) + "\\tableofcontents"))) + ((string= "tables" value) "\\listoftables") + ((string= "figures" value) "\\listoffigures") + ((string= "listings" value) + (cond + ((eq org-e-latex-listings 'minted) "\\listoflistings") + (org-e-latex-listings "\\lstlistoflistings") + ;; At the moment, src blocks with a caption are wrapped + ;; into a figure environment. + (t "\\listoffigures"))))))))) + + +;;;; Latex Environment + +(defun org-e-latex-latex-environment (latex-environment contents info) + "Transcode a LATEX-ENVIRONMENT element from Org to LaTeX. +CONTENTS is nil. INFO is a plist holding contextual information." + (let ((label (org-element-property :name latex-environment)) + (value (org-remove-indentation + (org-element-property :value latex-environment)))) + (if (not (org-string-nw-p label)) value + ;; Environment is labelled: label must be within the environment + ;; (otherwise, a reference pointing to that element will count + ;; the section instead). + (with-temp-buffer + (insert value) + (goto-char (point-min)) + (forward-line) + (insert (format "\\label{%s}\n" label)) + (buffer-string))))) + + +;;;; Latex Fragment + +(defun org-e-latex-latex-fragment (latex-fragment contents info) + "Transcode a LATEX-FRAGMENT object from Org to LaTeX. +CONTENTS is nil. INFO is a plist holding contextual information." + (org-element-property :value latex-fragment)) + + +;;;; Line Break + +(defun org-e-latex-line-break (line-break contents info) + "Transcode a LINE-BREAK object from Org to LaTeX. +CONTENTS is nil. INFO is a plist holding contextual information." + "\\\\") + + +;;;; Link + +(defun org-e-latex-link--inline-image (link info) + "Return LaTeX code for an inline image. +LINK is the link pointing to the inline image. INFO is a plist +used as a communication channel." + (let* ((parent (org-export-get-parent-element link)) + (path (let ((raw-path (org-element-property :path link))) + (if (not (file-name-absolute-p raw-path)) raw-path + (expand-file-name raw-path)))) + (caption (org-e-latex--caption/label-string + (org-element-property :caption parent) + (org-element-property :name parent) + info)) + ;; Retrieve latex attributes from the element around. + (attr (let ((raw-attr + (mapconcat #'identity + (org-element-property :attr_latex parent) + " "))) + (unless (string= raw-attr "") raw-attr))) + (disposition + (cond + ((and attr (string-match "\\" attr)) 'wrap) + ((and attr (string-match "\\" attr)) 'multicolumn) + ((or (and attr (string-match "\\" attr)) + (not (string= caption ""))) + 'float))) + (placement + (cond + ((and attr (string-match "\\" paralist-regexp) attr)) + (match-string 1 attr)) + ((eq type 'ordered) "enumerate") + ((eq type 'unordered) "itemize") + ((eq type 'descriptive) "description")))) + (org-e-latex--wrap-label + plain-list + (format "\\begin{%s}%s\n%s\\end{%s}" + latex-type + ;; Once special environment, if any, has been removed, the + ;; rest of the attributes will be optional arguments. + ;; They will be put inside square brackets if necessary. + (let ((opt (replace-regexp-in-string + (format " *%s *" paralist-regexp) "" attr))) + (cond ((string= opt "") "") + ((string-match "\\`\\[[^][]+\\]\\'" opt) opt) + (t (format "[%s]" opt)))) + contents + latex-type)))) + + +;;;; Plain Text + +(defun org-e-latex-plain-text (text info) + "Transcode a TEXT string from Org to LaTeX. +TEXT is the string to transcode. INFO is a plist holding +contextual information." + ;; Protect %, #, &, $, ~, ^, _, { and }. + (while (string-match "\\([^\\]\\|^\\)\\([%$#&{}~^_]\\)" text) + (setq text + (replace-match (format "\\%s" (match-string 2 text)) nil t text 2))) + ;; Protect \ + (setq text (replace-regexp-in-string + "\\(?:[^\\]\\|^\\)\\(\\\\\\)\\(?:[^%$#&{}~^_\\]\\|$\\)" + "$\\backslash$" text nil t 1)) + ;; LaTeX into \LaTeX{} and TeX into \TeX{}. + (let ((case-fold-search nil) + (start 0)) + (while (string-match "\\<\\(\\(?:La\\)?TeX\\)\\>" text start) + (setq text (replace-match + (format "\\%s{}" (match-string 1 text)) nil t text) + start (match-end 0)))) + ;; Handle quotation marks + (setq text (org-e-latex--quotation-marks text info)) + ;; Convert special strings. + (when (plist-get info :with-special-strings) + (while (string-match (regexp-quote "...") text) + (setq text (replace-match "\\ldots{}" nil t text)))) + ;; Handle break preservation if required. + (when (plist-get info :preserve-breaks) + (setq text (replace-regexp-in-string "\\(\\\\\\\\\\)?[ \t]*\n" " \\\\\\\\\n" + text))) + ;; Return value. + text) + + +;;;; Planning + +(defun org-e-latex-planning (planning contents info) + "Transcode a PLANNING element from Org to LaTeX. +CONTENTS is nil. INFO is a plist holding contextual +information." + (concat + "\\noindent" + (mapconcat + 'identity + (delq nil + (list + (let ((closed (org-element-property :closed planning))) + (when closed + (concat + (format "\\textbf{%s} " org-closed-string) + (format org-e-latex-inactive-timestamp-format + (org-translate-time closed))))) + (let ((deadline (org-element-property :deadline planning))) + (when deadline + (concat + (format "\\textbf{%s} " org-deadline-string) + (format org-e-latex-active-timestamp-format + (org-translate-time deadline))))) + (let ((scheduled (org-element-property :scheduled planning))) + (when scheduled + (concat + (format "\\textbf{%s} " org-scheduled-string) + (format org-e-latex-active-timestamp-format + (org-translate-time scheduled))))))) + " ") + "\\\\")) + + +;;;; Property Drawer + +(defun org-e-latex-property-drawer (property-drawer contents info) + "Transcode a PROPERTY-DRAWER element from Org to LaTeX. +CONTENTS is nil. INFO is a plist holding contextual +information." + ;; The property drawer isn't exported but we want separating blank + ;; lines nonetheless. + "") + + +;;;; Quote Block + +(defun org-e-latex-quote-block (quote-block contents info) + "Transcode a QUOTE-BLOCK element from Org to LaTeX. +CONTENTS holds the contents of the block. INFO is a plist +holding contextual information." + (org-e-latex--wrap-label + quote-block + (format "\\begin{quote}\n%s\\end{quote}" contents))) + + +;;;; Quote Section + +(defun org-e-latex-quote-section (quote-section contents info) + "Transcode a QUOTE-SECTION element from Org to LaTeX. +CONTENTS is nil. INFO is a plist holding contextual information." + (let ((value (org-remove-indentation + (org-element-property :value quote-section)))) + (when value (format "\\begin{verbatim}\n%s\\end{verbatim}" value)))) + + +;;;; Radio Target + +(defun org-e-latex-radio-target (radio-target text info) + "Transcode a RADIO-TARGET object from Org to LaTeX. +TEXT is the text of the target. INFO is a plist holding +contextual information." + (format "\\label{%s}%s" + (org-export-solidify-link-text + (org-element-property :value radio-target)) + text)) + + +;;;; Section + +(defun org-e-latex-section (section contents info) + "Transcode a SECTION element from Org to LaTeX. +CONTENTS holds the contents of the section. INFO is a plist +holding contextual information." + contents) + + +;;;; Special Block + +(defun org-e-latex-special-block (special-block contents info) + "Transcode a SPECIAL-BLOCK element from Org to LaTeX. +CONTENTS holds the contents of the block. INFO is a plist +holding contextual information." + (let ((type (downcase (org-element-property :type special-block)))) + (org-e-latex--wrap-label + special-block + (format "\\begin{%s}\n%s\\end{%s}" type contents type)))) + + +;;;; Src Block + +(defun org-e-latex-src-block (src-block contents info) + "Transcode a SRC-BLOCK element from Org to LaTeX. +CONTENTS holds the contents of the item. INFO is a plist holding +contextual information." + (let* ((lang (org-element-property :language src-block)) + (caption (org-element-property :caption src-block)) + (label (org-element-property :name src-block)) + (custom-env (and lang + (cadr (assq (intern lang) + org-e-latex-custom-lang-environments)))) + (num-start (case (org-element-property :number-lines src-block) + (continued (org-export-get-loc src-block info)) + (new 0))) + (retain-labels (org-element-property :retain-labels src-block))) + (cond + ;; Case 1. No source fontification. + ((not org-e-latex-listings) + (let ((caption-str (org-e-latex--caption/label-string caption label info)) + (float-env (when caption "\\begin{figure}[H]\n%s\n\\end{figure}"))) + (format + (or float-env "%s") + (concat caption-str + (format "\\begin{verbatim}\n%s\\end{verbatim}" + (org-export-format-code-default src-block info)))))) + ;; Case 2. Custom environment. + (custom-env (format "\\begin{%s}\n%s\\end{%s}\n" + custom-env + (org-export-format-code-default src-block info) + custom-env)) + ;; Case 3. Use minted package. + ((eq org-e-latex-listings 'minted) + (let ((float-env (when (or label caption) + (format "\\begin{listing}[H]\n%%s\n%s\\end{listing}" + (org-e-latex--caption/label-string + caption label info)))) + (body + (format + "\\begin{minted}[%s]{%s}\n%s\\end{minted}" + ;; Options. + (org-e-latex--make-option-string + (if (not num-start) org-e-latex-minted-options + (append `(("linenos") + ("firstnumber" ,(number-to-string (1+ num-start)))) + org-e-latex-minted-options))) + ;; Language. + (or (cadr (assq (intern lang) org-e-latex-minted-langs)) lang) + ;; Source code. + (let* ((code-info (org-export-unravel-code src-block)) + (max-width + (apply 'max + (mapcar 'length + (org-split-string (car code-info) "\n"))))) + (org-export-format-code + (car code-info) + (lambda (loc num ref) + (concat + loc + (when ref + ;; Ensure references are flushed to the right, + ;; separated with 6 spaces from the widest line + ;; of code. + (concat (make-string (+ (- max-width (length loc)) 6) ? ) + (format "(%s)" ref))))) + nil (and retain-labels (cdr code-info))))))) + ;; Return value. + (if float-env (format float-env body) body))) + ;; Case 4. Use listings package. + (t + (let ((lst-lang + (or (cadr (assq (intern lang) org-e-latex-listings-langs)) lang)) + (caption-str + (when caption + (let ((main (org-export-data (car caption) info))) + (if (not (cdr caption)) (format "{%s}" main) + (format "{[%s]%s}" + (org-export-data (cdr caption) info) + main)))))) + (concat + ;; Options. + (format "\\lstset{%s}\n" + (org-e-latex--make-option-string + (append org-e-latex-listings-options + `(("language" ,lst-lang)) + (when label `(("label" ,label))) + (when caption-str `(("caption" ,caption-str))) + (cond ((not num-start) '(("numbers" "none"))) + ((zerop num-start) '(("numbers" "left"))) + (t `(("numbers" "left") + ("firstnumber" + ,(number-to-string (1+ num-start))))))))) + ;; Source code. + (format + "\\begin{lstlisting}\n%s\\end{lstlisting}" + (let* ((code-info (org-export-unravel-code src-block)) + (max-width + (apply 'max + (mapcar 'length + (org-split-string (car code-info) "\n"))))) + (org-export-format-code + (car code-info) + (lambda (loc num ref) + (concat + loc + (when ref + ;; Ensure references are flushed to the right, + ;; separated with 6 spaces from the widest line of + ;; code + (concat (make-string (+ (- max-width (length loc)) 6) ? ) + (format "(%s)" ref))))) + nil (and retain-labels (cdr code-info))))))))))) + + +;;;; Statistics Cookie + +(defun org-e-latex-statistics-cookie (statistics-cookie contents info) + "Transcode a STATISTICS-COOKIE object from Org to LaTeX. +CONTENTS is nil. INFO is a plist holding contextual information." + (replace-regexp-in-string + "%" "\\%" (org-element-property :value statistics-cookie) nil t)) + + +;;;; Strike-Through + +(defun org-e-latex-strike-through (strike-through contents info) + "Transcode STRIKE-THROUGH from Org to LaTeX. +CONTENTS is the text with strike-through markup. INFO is a plist +holding contextual information." + (org-e-latex--text-markup contents 'strike-through)) + + +;;;; Subscript + +(defun org-e-latex-subscript (subscript contents info) + "Transcode a SUBSCRIPT object from Org to LaTeX. +CONTENTS is the contents of the object. INFO is a plist holding +contextual information." + (if (= (length contents) 1) (format "$_%s$" contents) + ;; Handle multiple objects in SUBSCRIPT by creating a subscript + ;; command for each of them. + (let ((prev-blanks 0)) + (mapconcat + (lambda (obj) + (case (org-element-type obj) + ((entity latex-fragment) + (setq prev-blanks (org-element-property :post-blank obj)) + (let ((data (org-trim (org-export-data obj info)))) + (string-match + "\\`\\(?:\\\\[([]\\|\\$+\\)?\\(.*?\\)\\(?:\\\\[])]\\|\\$+\\)?\\'" + data) + (format "$_{%s}$" (match-string 1 data)))) + (plain-text + (format "$_\\mathrm{%s}$" + (concat (make-string prev-blanks ? ) + ;; mathrm command doesn't handle spaces, + ;; so we have to enforce them. + (replace-regexp-in-string + " " "\\\\ " (org-export-data obj info))))) + (otherwise + (setq prev-blanks (org-element-property :post-blank obj)) + (format "$_{%s}$" (org-export-data obj info))))) + (org-element-contents subscript) "")))) + + +;;;; Superscript + +(defun org-e-latex-superscript (superscript contents info) + "Transcode a SUPERSCRIPT object from Org to LaTeX. +CONTENTS is the contents of the object. INFO is a plist holding +contextual information." + (if (= (length contents) 1) (format "$^%s$" contents) + ;; Handle multiple objects in SUPERSCRIPT by creating + ;; a superscript command for each of them. + (let ((prev-blanks 0)) + (mapconcat + (lambda (obj) + (case (org-element-type obj) + ((entity latex-fragment) + (setq prev-blanks (org-element-property :post-blank obj)) + (let ((data (org-trim (org-export-data obj info)))) + (string-match + "\\`\\(?:\\\\[([]\\|\\$+\\)?\\(.*?\\)\\(?:\\\\[])]\\|\\$+\\)?\\'" + data) + (format "$^{%s}$" (match-string 1 data)))) + (plain-text + (format "$^\\mathrm{%s}$" + (concat (make-string prev-blanks ? ) + ;; mathrm command doesn't handle spaces, + ;; so we have to enforce them. + (replace-regexp-in-string + " " "\\\\ " (org-export-data obj info))))) + (otherwise + (setq prev-blanks (org-element-property :post-blank obj)) + (format "$^{%s}$" (org-export-data obj info))))) + (org-element-contents superscript) "")))) + + +;;;; Table +;; +;; `org-e-latex-table' is the entry point for table transcoding. It +;; takes care of tables with a "verbatim" attribute. Otherwise, it +;; delegates the job to either `org-e-latex-table--table.el-table' or +;; `org-e-latex-table--org-table' functions, depending of the type of +;; the table. +;; +;; `org-e-latex-table--align-string' is a subroutine used to build +;; alignment string for Org tables. + +(defun org-e-latex-table (table contents info) + "Transcode a TABLE element from Org to LaTeX. +CONTENTS is the contents of the table. INFO is a plist holding +contextual information." + (cond + ;; Case 1: verbatim table. + ((or org-e-latex-tables-verbatim + (let ((attr (mapconcat 'identity + (org-element-property :attr_latex table) + " "))) + (and attr (string-match "\\" attr)))) + (format "\\begin{verbatim}\n%s\n\\end{verbatim}" + ;; Re-create table, without affiliated keywords. + (org-trim + (org-element-interpret-data + `(table nil ,@(org-element-contents table)))))) + ;; Case 2: table.el table. Convert it using appropriate tools. + ((eq (org-element-property :type table) 'table.el) + (org-e-latex-table--table.el-table table contents info)) + ;; Case 3: Standard table. + (t (org-e-latex-table--org-table table contents info)))) + +(defun org-e-latex-table--align-string (table info) + "Return an appropriate LaTeX alignment string. +TABLE is the considered table. INFO is a plist used as +a communication channel." + (let ((attr (mapconcat 'identity + (org-element-property :attr_latex table) + " "))) + (if (string-match "\\" attr) "longtable") + ((string-match "\\" attr) + (org-match-string-no-properties 0 attr)) + (t org-e-latex-default-table-environment))) + ;; If table is a float, determine environment: table, table* + ;; or sidewaystable. + (float-env (cond + ((string= "longtable" table-env) nil) + ((and attr (string-match "\\" attr)) + "sidewaystable") + ((and attr + (or (string-match (regexp-quote "table*") attr) + (string-match "\\" attr))) + "table*") + ((or (not (string= caption "")) label) "table"))) + ;; Extract others display options. + (width (and attr (string-match "\\" attr)) + (let ((n 0) (pos 0)) + (while (and (< (length output) pos) + (setq pos (string-match "^\\\\hline\n?" output pos))) + (incf n) + (unless (= n 2) + (setq output (replace-match "" nil nil output))))))) + (if (not org-e-latex-tables-centered) output + (format "\\begin{center}\n%s\n\\end{center}" output)))) + + +;;;; Table Cell + +(defun org-e-latex-table-cell (table-cell contents info) + "Transcode a TABLE-CELL element from Org to LaTeX. +CONTENTS is the cell contents. INFO is a plist used as +a communication channel." + (concat (if (and contents + org-e-latex-table-scientific-notation + (string-match orgtbl-exp-regexp contents)) + ;; Use appropriate format string for scientific + ;; notation. + (format org-e-latex-table-scientific-notation + (match-string 1 contents) + (match-string 2 contents)) + contents) + (when (org-export-get-next-element table-cell info) " & "))) + + +;;;; Table Row + +(defun org-e-latex-table-row (table-row contents info) + "Transcode a TABLE-ROW element from Org to LaTeX. +CONTENTS is the contents of the row. INFO is a plist used as +a communication channel." + ;; Rules are ignored since table separators are deduced from + ;; borders of the current row. + (when (eq (org-element-property :type table-row) 'standard) + (let* ((attr (mapconcat 'identity + (org-element-property + :attr_latex (org-export-get-parent table-row)) + " ")) + (longtablep (and attr (string-match "\\" attr))) + (booktabsp + (or (and attr (string-match "\\" attr)) + org-e-latex-tables-booktabs)) + ;; TABLE-ROW's borders are extracted from its first cell. + (borders + (org-export-table-cell-borders + (car (org-element-contents table-row)) info))) + (concat + ;; When BOOKTABS are activated enforce top-rule even when no + ;; hline was specifically marked. + (cond ((and booktabsp (memq 'top borders)) "\\toprule\n") + ((and (memq 'top borders) (memq 'above borders)) "\\hline\n")) + contents "\\\\\n" + (cond + ;; Special case for long tables. Define header and footers. + ((and longtablep (org-export-table-row-ends-header-p table-row info)) + (format "%s +\\endhead +%s\\multicolumn{%d}{r}{Continued on next page} \\\\ +\\endfoot +\\endlastfoot" + (if booktabsp "\\midrule" "\\hline") + (if booktabsp "\\midrule" "\\hline") + ;; Number of columns. + (cdr (org-export-table-dimensions + (org-export-get-parent-table table-row) info)))) + ;; When BOOKTABS are activated enforce bottom rule even when + ;; no hline was specifically marked. + ((and booktabsp (memq 'bottom borders)) "\\bottomrule") + ((and (memq 'bottom borders) (memq 'below borders)) "\\hline") + ((memq 'below borders) (if booktabsp "\\midrule" "\\hline"))))))) + + +;;;; Target + +(defun org-e-latex-target (target contents info) + "Transcode a TARGET object from Org to LaTeX. +CONTENTS is nil. INFO is a plist holding contextual +information." + (format "\\label{%s}" + (org-export-solidify-link-text (org-element-property :value target)))) + + +;;;; Timestamp + +(defun org-e-latex-timestamp (timestamp contents info) + "Transcode a TIMESTAMP object from Org to LaTeX. +CONTENTS is nil. INFO is a plist holding contextual +information." + (let ((value (org-translate-time (org-element-property :value timestamp))) + (range-end (org-element-property :range-end timestamp))) + (case (org-element-property :type timestamp) + (active (format org-e-latex-active-timestamp-format value)) + (active-range + (concat (format org-e-latex-active-timestamp-format value) + "--" + (format org-e-latex-active-timestamp-format + (org-translate-time range-end)))) + (inactive (format org-e-latex-inactive-timestamp-format value)) + (inactive-range + (concat (format org-e-latex-inactive-timestamp-format value) + "--" + (format org-e-latex-inactive-timestamp-format + (org-translate-time range-end)))) + (otherwise (format org-e-latex-diary-timestamp-format value))))) + + +;;;; Underline + +(defun org-e-latex-underline (underline contents info) + "Transcode UNDERLINE from Org to LaTeX. +CONTENTS is the text with underline markup. INFO is a plist +holding contextual information." + (org-e-latex--text-markup contents 'underline)) + + +;;;; Verbatim + +(defun org-e-latex-verbatim (verbatim contents info) + "Transcode a VERBATIM object from Org to LaTeX. +CONTENTS is nil. INFO is a plist used as a communication +channel." + (org-e-latex--text-markup (org-element-property :value verbatim) 'verbatim)) + + +;;;; Verse Block + +(defun org-e-latex-verse-block (verse-block contents info) + "Transcode a VERSE-BLOCK element from Org to LaTeX. +CONTENTS is verse block contents. INFO is a plist holding +contextual information." + (org-e-latex--wrap-label + verse-block + ;; In a verse environment, add a line break to each newline + ;; character and change each white space at beginning of a line + ;; into a space of 1 em. Also change each blank line with + ;; a vertical space of 1 em. + (progn + (setq contents (replace-regexp-in-string + "^ *\\\\\\\\$" "\\\\vspace*{1em}" + (replace-regexp-in-string + "\\(\\\\\\\\\\)?[ \t]*\n" " \\\\\\\\\n" contents))) + (while (string-match "^[ \t]+" contents) + (let ((new-str (format "\\hspace*{%dem}" + (length (match-string 0 contents))))) + (setq contents (replace-match new-str nil t contents)))) + (format "\\begin{verse}\n%s\\end{verse}" contents)))) + + + +;;; Interactive functions + +;;;###autoload +(defun org-e-latex-export-as-latex + (&optional subtreep visible-only body-only ext-plist) + "Export current buffer as a LaTeX buffer. + +If narrowing is active in the current buffer, only export its +narrowed part. + +If a region is active, export that region. + +When optional argument SUBTREEP is non-nil, export the sub-tree +at point, extracting information from the headline properties +first. + +When optional argument VISIBLE-ONLY is non-nil, don't export +contents of hidden elements. + +When optional argument BODY-ONLY is non-nil, only write code +between \"\\begin{document}\" and \"\\end{document}\". + +EXT-PLIST, when provided, is a property list with external +parameters overriding Org default settings, but still inferior to +file-local settings. + +Export is done in a buffer named \"*Org E-LATEX Export*\", which +will be displayed when `org-export-show-temporary-export-buffer' +is non-nil." + (interactive) + (let ((outbuf (org-export-to-buffer + 'e-latex "*Org E-LATEX Export*" + subtreep visible-only body-only ext-plist))) + (with-current-buffer outbuf (LaTeX-mode)) + (when org-export-show-temporary-export-buffer + (switch-to-buffer-other-window outbuf)))) + +;;;###autoload +(defun org-e-latex-export-to-latex + (&optional subtreep visible-only body-only ext-plist pub-dir) + "Export current buffer to a LaTeX file. + +If narrowing is active in the current buffer, only export its +narrowed part. + +If a region is active, export that region. + +When optional argument SUBTREEP is non-nil, export the sub-tree +at point, extracting information from the headline properties +first. + +When optional argument VISIBLE-ONLY is non-nil, don't export +contents of hidden elements. + +When optional argument BODY-ONLY is non-nil, only write code +between \"\\begin{document}\" and \"\\end{document}\". + +EXT-PLIST, when provided, is a property list with external +parameters overriding Org default settings, but still inferior to +file-local settings. + +When optional argument PUB-DIR is set, use it as the publishing +directory. + +Return output file's name." + (interactive) + (let ((outfile (org-export-output-file-name ".tex" subtreep pub-dir))) + (org-export-to-file + 'e-latex outfile subtreep visible-only body-only ext-plist))) + +;;;###autoload +(defun org-e-latex-export-to-pdf + (&optional subtreep visible-only body-only ext-plist pub-dir) + "Export current buffer to LaTeX then process through to PDF. + +If narrowing is active in the current buffer, only export its +narrowed part. + +If a region is active, export that region. + +When optional argument SUBTREEP is non-nil, export the sub-tree +at point, extracting information from the headline properties +first. + +When optional argument VISIBLE-ONLY is non-nil, don't export +contents of hidden elements. + +When optional argument BODY-ONLY is non-nil, only write code +between \"\\begin{document}\" and \"\\end{document}\". + +EXT-PLIST, when provided, is a property list with external +parameters overriding Org default settings, but still inferior to +file-local settings. + +When optional argument PUB-DIR is set, use it as the publishing +directory. + +Return PDF file's name." + (interactive) + (org-e-latex-compile + (org-e-latex-export-to-latex + subtreep visible-only body-only ext-plist pub-dir))) + +(defun org-e-latex-compile (texfile) + "Compile a TeX file. + +TEXFILE is the name of the file being compiled. Processing is +done through the command specified in `org-e-latex-pdf-process'. + +Return PDF file name or an error if it couldn't be produced." + (let* ((wconfig (current-window-configuration)) + (texfile (file-truename texfile)) + (base (file-name-sans-extension texfile)) + errors) + (message (format "Processing LaTeX file %s ..." texfile)) + (unwind-protect + (progn + (cond + ;; A function is provided: Apply it. + ((functionp org-e-latex-pdf-process) + (funcall org-e-latex-pdf-process (shell-quote-argument texfile))) + ;; A list is provided: Replace %b, %f and %o with appropriate + ;; values in each command before applying it. Output is + ;; redirected to "*Org PDF LaTeX Output*" buffer. + ((consp org-e-latex-pdf-process) + (let* ((out-dir (or (file-name-directory texfile) "./")) + (outbuf (get-buffer-create "*Org PDF LaTeX Output*"))) + (mapc + (lambda (command) + (shell-command + (replace-regexp-in-string + "%b" (shell-quote-argument base) + (replace-regexp-in-string + "%f" (shell-quote-argument texfile) + (replace-regexp-in-string + "%o" (shell-quote-argument out-dir) command t t) t t) t t) + outbuf)) + org-e-latex-pdf-process) + ;; Collect standard errors from output buffer. + (setq errors (org-e-latex--collect-errors outbuf)))) + (t (error "No valid command to process to PDF"))) + (let ((pdffile (concat base ".pdf"))) + ;; Check for process failure. Provide collected errors if + ;; possible. + (if (not (file-exists-p pdffile)) + (error (concat (format "PDF file %s wasn't produced" pdffile) + (when errors (concat ": " errors)))) + ;; Else remove log files, when specified, and signal end of + ;; process to user, along with any error encountered. + (when org-e-latex-remove-logfiles + (dolist (ext org-e-latex-logfiles-extensions) + (let ((file (concat base "." ext))) + (when (file-exists-p file) (delete-file file))))) + (message (concat "Process completed" + (if (not errors) "." + (concat " with errors: " errors))))) + ;; Return output file name. + pdffile)) + (set-window-configuration wconfig)))) + +(defun org-e-latex--collect-errors (buffer) + "Collect some kind of errors from \"pdflatex\" command output. + +BUFFER is the buffer containing output. + +Return collected error types as a string, or nil if there was +none." + (with-current-buffer buffer + (save-excursion + (goto-char (point-max)) + ;; Find final "pdflatex" run. + (when (re-search-backward "^[ \t]*This is pdf.*?TeX.*?Version" nil t) + (let ((case-fold-search t) + (errors "")) + (when (save-excursion + (re-search-forward "Reference.*?undefined" nil t)) + (setq errors (concat errors " [undefined reference]"))) + (when (save-excursion + (re-search-forward "Citation.*?undefined" nil t)) + (setq errors (concat errors " [undefined citation]"))) + (when (save-excursion + (re-search-forward "Undefined control sequence" nil t)) + (setq errors (concat errors " [undefined control sequence]"))) + (when (save-excursion + (re-search-forward "^! LaTeX.*?Error" nil t)) + (setq errors (concat errors " [LaTeX error]"))) + (when (save-excursion + (re-search-forward "^! Package.*?Error" nil t)) + (setq errors (concat errors " [package error]"))) + (and (org-string-nw-p errors) (org-trim errors))))))) + + +(provide 'org-e-latex) +;;; org-e-latex.el ends here diff --git a/contrib/lisp/org-e-man.el b/contrib/lisp/org-e-man.el new file mode 100644 index 0000000..981f831 --- /dev/null +++ b/contrib/lisp/org-e-man.el @@ -0,0 +1,1363 @@ +;; org-e-man.el --- Man Back-End For Org Export Engine + +;; Copyright (C) 2011-2012 Free Software Foundation, Inc. + +;; Author: Nicolas Goaziou +;; Author: Luis R Anaya +;; Keywords: outlines, hypermedia, calendar, wp +;; + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: +;; +;; This library implements a Man back-end for Org generic exporter. +;; +;; To test it, run +;; +;; M-: (org-export-to-buffer 'e-man "*Test e-Man*") RET +;; +;; in an org-mode buffer then switch to the buffer to see the Man +;; export. See contrib/lisp/org-export.el for more details on how +;; this exporter works. +;; +;; It introduces one new buffer keywords: +;; "MAN_CLASS_OPTIONS". + +;;;; Code: + +(require 'org-export) + +(eval-when-compile (require 'cl)) + +(defvar org-export-man-default-packages-alist) +(defvar org-export-man-packages-alist) + + + + + + +;;;; Define Back-End + +(defvar org-e-man-translate-alist + '((babel-call . org-e-man-babel-call) + (bold . org-e-man-bold) + (center-block . org-e-man-center-block) + (clock . org-e-man-clock) + (code . org-e-man-code) + (comment . org-e-man-comment) + (comment-block . org-e-man-comment-block) + (drawer . org-e-man-drawer) + (dynamic-block . org-e-man-dynamic-block) + (entity . org-e-man-entity) + (example-block . org-e-man-example-block) + (export-block . org-e-man-export-block) + (export-snippet . org-e-man-export-snippet) + (fixed-width . org-e-man-fixed-width) + (footnote-definition . org-e-man-footnote-definition) + (footnote-reference . org-e-man-footnote-reference) + (headline . org-e-man-headline) + (horizontal-rule . org-e-man-horizontal-rule) + (inline-babel-call . org-e-man-inline-babel-call) + (inline-src-block . org-e-man-inline-src-block) + (inlinetask . org-e-man-inlinetask) + (italic . org-e-man-italic) + (item . org-e-man-item) + (keyword . org-e-man-keyword) + (man-environment . org-e-man-man-environment) + (man-fragment . org-e-man-man-fragment) + (line-break . org-e-man-line-break) + (link . org-e-man-link) + (macro . org-e-man-macro) + (paragraph . org-e-man-paragraph) + (plain-list . org-e-man-plain-list) + (plain-text . org-e-man-plain-text) + (planning . org-e-man-planning) + (property-drawer . org-e-man-property-drawer) + (quote-block . org-e-man-quote-block) + (quote-section . org-e-man-quote-section) + (radio-target . org-e-man-radio-target) + (section . org-e-man-section) + (special-block . org-e-man-special-block) + (src-block . org-e-man-src-block) + (statistics-cookie . org-e-man-statistics-cookie) + (strike-through . org-e-man-strike-through) + (subscript . org-e-man-subscript) + (superscript . org-e-man-superscript) + (table . org-e-man-table) + (table-cell . org-e-man-table-cell) + (table-row . org-e-man-table-row) + (target . org-e-man-target) + (template . org-e-man-template) + (timestamp . org-e-man-timestamp) + (underline . org-e-man-underline) + (verbatim . org-e-man-verbatim) + (verse-block . org-e-man-verse-block)) + "Alist between element or object types and translators.") + +(defconst org-e-man-options-alist + '((:date "DATE" nil nil t) + (:man-class "MAN_CLASS" nil nil t) + (:man-class-options "MAN_CLASS_OPTIONS" nil nil t) + (:man-header-extra "MAN_HEADER" nil nil newline)) + "Alist between Man export properties and ways to set them. +See `org-export-options-alist' for more information on the +structure of the values.") + + + + +;;; User Configurable Variables + + +(defgroup org-export-e-man nil + "Options for exporting Org mode files to Man." + :tag "Org Export Man" + :group 'org-export) + + +;;;; Tables + + +(defcustom org-e-man-tables-centered t + "When non-nil, tables are exported in a center environment." + :group 'org-export-e-man + :type 'boolean) + +(defcustom org-e-man-tables-verbatim nil + "When non-nil, tables are exported verbatim." + :group 'org-export-e-man + :type 'boolean) + +(defcustom org-e-man-table-scientific-notation "%sE%s" + "Format string to display numbers in scientific notation. +The format should have \"%s\" twice, for mantissa and exponent +\(i.e. \"%s\\\\times10^{%s}\"). + +When nil, no transformation is made." + :group 'org-export-e-man + :type '(choice + (string :tag "Format string") + (const :tag "No formatting"))) + + +;;;; Inlinetasks + + +;; Src blocks + +(defcustom org-e-man-source-highlight nil + "Use GNU source highlight to embellish source blocks " + :group 'org-export-e-man + :type 'boolean) + +(defcustom org-e-man-source-highlight-langs + '((emacs-lisp "lisp") (lisp "lisp") (clojure "lisp") + (scheme "scheme") + (c "c") (cc "cpp") (csharp "csharp") (d "d") + (fortran "fortran") (cobol "cobol") (pascal "pascal") + (ada "ada") (asm "asm") + (perl "perl") (cperl "perl") + (python "python") (ruby "ruby") (tcl "tcl") (lua "lua") + (java "java") (javascript "javascript") + (tex "latex") + (shell-script "sh") (awk "awk") (diff "diff") (m4 "m4") + (ocaml "caml") (caml "caml") + (sql "sql") (sqlite "sql") + (html "html") (css "css") (xml "xml") + (bat "bat") (bison "bison") (clipper "clipper") + (ldap "ldap") (opa "opa") + (php "php") (postscript "postscript") (prolog "prolog") + (properties "properties") (makefile "makefile") + (tml "tml") (vala "vala") (vbscript "vbscript") (xorg "xorg")) + "Alist mapping languages to their listing language counterpart. +The key is a symbol, the major mode symbol without the \"-mode\". +The value is the string that should be inserted as the language +parameter for the listings package. If the mode name and the +listings name are the same, the language does not need an entry +in this list - but it does not hurt if it is present." + :group 'org-export-e-man + :type '(repeat + (list + (symbol :tag "Major mode ") + (string :tag "Listings language")))) + + +(defvar org-e-man-custom-lang-environments nil + "Alist mapping languages to language-specific Man environments. + +It is used during export of src blocks by the listings and +man packages. For example, + + \(setq org-e-man-custom-lang-environments + '\(\(python \"pythoncode\"\)\)\) + +would have the effect that if org encounters begin_src python +during man export." +) + + +;;;; Plain text + +(defcustom org-e-man-quotes + '(("fr" + ("\\(\\s-\\|[[(]\\|^\\)\"" . "«~") + ("\\(\\S-\\)\"" . "~»") + ("\\(\\s-\\|(\\|^\\)'" . "'")) + ("en" + ("\\(\\s-\\|[[(]\\|^\\)\"" . "``") + ("\\(\\S-\\)\"" . "''") + ("\\(\\s-\\|(\\|^\\)'" . "`"))) + + "Alist for quotes to use when converting english double-quotes. + +The CAR of each item in this alist is the language code. +The CDR of each item in this alist is a list of three CONS: +- the first CONS defines the opening quote; +- the second CONS defines the closing quote; +- the last CONS defines single quotes. + +For each item in a CONS, the first string is a regexp +for allowed characters before/after the quote, the second +string defines the replacement string for this quote." + :group 'org-export-e-man + :type '(list + (cons :tag "Opening quote" + (string :tag "Regexp for char before") + (string :tag "Replacement quote ")) + (cons :tag "Closing quote" + (string :tag "Regexp for char after ") + (string :tag "Replacement quote ")) + (cons :tag "Single quote" + (string :tag "Regexp for char before") + (string :tag "Replacement quote ")))) + + +;;;; Compilation + +(defcustom org-e-man-pdf-process + '("tbl %f | eqn | groff -man | ps2pdf - > %b.pdf" + "tbl %f | eqn | groff -man | ps2pdf - > %b.pdf" + "tbl %f | eqn | groff -man | ps2pdf - > %b.pdf") + + "Commands to process a Man file to a PDF file. +This is a list of strings, each of them will be given to the +shell as a command. %f in the command will be replaced by the +full file name, %b by the file base name \(i.e. without +extension) and %o by the base directory of the file. + + +By default, Org uses 3 runs of to do the processing. + +Alternatively, this may be a Lisp function that does the +processing. This function should accept the file name as +its single argument." + :group 'org-export-pdf + :type '(choice + (repeat :tag "Shell command sequence" + (string :tag "Shell command")) + (const :tag "2 runs of pdfgroff" + ("tbl %f | eqn | groff -mm | ps2pdf - > %b.pdf" + "tbl %f | eqn | groff -mm | ps2pdf - > %b.pdf")) + (const :tag "3 runs of pdfgroff" + ("tbl %f | eqn | groff -mm | ps2pdf - > %b.pdf" + "tbl %f | eqn | groff -mm | ps2pdf - > %b.pdf" + "tbl %f | eqn | groff -mm | ps2pdf - > %b.pdf")) + (function))) + +(defcustom org-e-man-logfiles-extensions + '("log" "out" "toc") + "The list of file extensions to consider as Man logfiles." + :group 'org-export-e-man + :type '(repeat (string :tag "Extension"))) + +(defcustom org-e-man-remove-logfiles t + "Non-nil means remove the logfiles produced by PDF production. +These are the .aux, .log, .out, and .toc files." + :group 'org-export-e-man + :type 'boolean) + + + +;; Preamble + + +;; Adding MAN as a block parser to make sure that its contents +;; does not execute + +(add-to-list 'org-element-block-name-alist + '("MAN" . org-element-export-block-parser)) + + + + + +;;; Internal Functions + +(defun org-e-man--caption/label-string (caption label info) + "Return caption and label Man string for floats. + +CAPTION is a cons cell of secondary strings, the car being the +standard caption and the cdr its short form. LABEL is a string +representing the label. INFO is a plist holding contextual +information. + +If there's no caption nor label, return the empty string. + +For non-floats, see `org-e-man--wrap-label'." + (let ((label-str "")) + (cond + ((and (not caption) (not label)) "") + ((not caption) (format "\\fI%s\\fP" label)) + ;; Option caption format with short name. + ((cdr caption) + (format "\\fR%s\\fP - \\fI%s\\P - %s\n" + (org-export-data (cdr caption) info) + label-str + (org-export-data (car caption) info))) + ;; Standard caption format. + (t (format "\\fR%s\\fP" + (org-export-data (car caption) info)))))) + +(defun org-e-man--quotation-marks (text info) + "Export quotation marks depending on language conventions. +TEXT is a string containing quotation marks to be replaced. INFO +is a plist used as a communication channel." + (mapc (lambda(l) + (let ((start 0)) + (while (setq start (string-match (car l) text start)) + (let ((new-quote (concat (match-string 1 text) (cdr l)))) + (setq text (replace-match new-quote t t text)))))) + (cdr (or (assoc (plist-get info :language) org-e-man-quotes) + ;; Falls back on English. + (assoc "en" org-e-man-quotes)))) + text) + +(defun org-e-man--wrap-label (element output) + "Wrap label associated to ELEMENT around OUTPUT, if appropriate. +This function shouldn't be used for floats. See +`org-e-man--caption/label-string'." + (let ((label (org-element-property :name element))) + (if (or (not output) (not label) (string= output "") (string= label "")) + output + (concat (format "%s\n.br\n" label) output)))) + + + + +;;; Template + +(defun org-e-man-template (contents info) + "Return complete document string after Man conversion. +CONTENTS is the transcoded contents string. INFO is a plist +holding export options." + (let* ((title (org-export-data (plist-get info :title) info)) + (attr + (read (format "(%s)" + (mapconcat + #'identity + (list (plist-get info :man-class-options)) + " ")))) + (section-item (plist-get attr :section-id))) + + (concat + (cond + ((and title (stringp section-item)) + (format ".TH \"%s\" \"%s\" \n" title section-item)) + ((and (string= "" title) (stringp section-item)) + (format ".TH \"%s\" \"%s\" \n" " " section-item)) + (title + (format ".TH \"%s\" \"1\" \n" title)) + (t + ".TH \" \" \"1\" ")) + contents))) + + + + +;;; Transcode Functions + +;;;; Babel Call + +;; Babel Calls are ignored. + + +;;;; Bold + +(defun org-e-man-bold (bold contents info) + "Transcode BOLD from Org to Man. +CONTENTS is the text with bold markup. INFO is a plist holding +contextual information." + (format "\\fB%s\\fP" contents)) + + +;;;; Center Block + +(defun org-e-man-center-block (center-block contents info) + "Transcode a CENTER-BLOCK element from Org to Man. +CONTENTS holds the contents of the center block. INFO is a plist +holding contextual information." + (org-e-man--wrap-label + center-block + (format ".ce %d\n.nf\n%s\n.fi" + (- (length (split-string contents "\n")) 1) + contents))) + + +;;;; Clock + +(defun org-e-man-clock (clock contents info) + "Transcode a CLOCK element from Org to Man. +CONTENTS is nil. INFO is a plist holding contextual +information." + "") + + +;;;; Code + +(defun org-e-man-code (code contents info) + "Transcode a CODE object from Org to Man. +CONTENTS is nil. INFO is a plist used as a communication +channel." + (format "\\fC%s\\fP" code)) + + +;;;; Comment +;; Comments are ignored. + + +;;;; Comment Block +;; Comment Blocks are ignored. + + +;;;; Drawer + +(defun org-e-man-drawer (drawer contents info) + "Transcode a DRAWER element from Org to Man. + DRAWER holds the drawer information + CONTENTS holds the contents of the block. + INFO is a plist holding contextual information. " + contents) + + +;;;; Dynamic Block + +(defun org-e-man-dynamic-block (dynamic-block contents info) + "Transcode a DYNAMIC-BLOCK element from Org to Man. +CONTENTS holds the contents of the block. INFO is a plist +holding contextual information. See `org-export-data'." + (org-e-man--wrap-label dynamic-block contents)) + + +;;;; Entity + +(defun org-e-man-entity (entity contents info) + "Transcode an ENTITY object from Org to Man. +CONTENTS are the definition itself. INFO is a plist holding +contextual information." + (let ((ent (org-element-property :utf8 entity))) ent)) + + +;;;; Example Block + +(defun org-e-man-example-block (example-block contents info) + "Transcode an EXAMPLE-BLOCK element from Org to Man. +CONTENTS is nil. INFO is a plist holding contextual +information." + (org-e-man--wrap-label + example-block + (format ".RS\n.nf\n%s\n.fi\n.RE" + (org-export-format-code-default example-block info)))) + +;;;; Export Block + +(defun org-e-man-export-block (export-block contents info) + "Transcode a EXPORT-BLOCK element from Org to Man. +CONTENTS is nil. INFO is a plist holding contextual information." + (when (string= (org-element-property :type export-block) "MAN") + (org-remove-indentation (org-element-property :value export-block)))) + + +;;;; Export Snippet + +(defun org-e-man-export-snippet (export-snippet contents info) + "Transcode a EXPORT-SNIPPET object from Org to Man. +CONTENTS is nil. INFO is a plist holding contextual information." + (when (eq (org-export-snippet-backend export-snippet) 'e-man) + (org-element-property :value export-snippet))) + + +;;;; Fixed Width + +(defun org-e-man-fixed-width (fixed-width contents info) + "Transcode a FIXED-WIDTH element from Org to Man. +CONTENTS is nil. INFO is a plist holding contextual information." + (org-e-man--wrap-label + fixed-width + (format "\\fC\n%s\\fP" + (org-remove-indentation + (org-element-property :value fixed-width))))) + + +;;;; Footnote Definition +;; Footnote Definitions are ignored. + +;;;; Footnote References +;; Footnote References are Ignored + + +;;;; Headline + +(defun org-e-man-headline (headline contents info) + "Transcode an HEADLINE element from Org to Man. +CONTENTS holds the contents of the headline. INFO is a plist +holding contextual information." + (let* ((level (org-export-get-relative-level headline info)) + (numberedp (org-export-numbered-headline-p headline info)) + ;; Section formatting will set two placeholders: one for the + ;; title and the other for the contents. + (section-fmt + (case level + (1 ".SH \"%s\"\n%s") + (2 ".SS \"%s\"\n%s") + (3 ".SS \"%s\"\n%s") + (t nil))) + (text (org-export-data (org-element-property :title headline) info))) + + (cond + ;; Case 1: This is a footnote section: ignore it. + ((org-element-property :footnote-section-p headline) nil) + + ;; Case 2. This is a deep sub-tree: export it as a list item. + ;; Also export as items headlines for which no section + ;; format has been found. + ((or (not section-fmt) (org-export-low-level-p headline info)) + ;; Build the real contents of the sub-tree. + (let ((low-level-body + (concat + ;; If the headline is the first sibling, start a list. + (when (org-export-first-sibling-p headline info) + (format "%s\n" ".RS")) + ;; Itemize headline + ".TP\n.ft I\n" text "\n.ft\n" + contents ".RE"))) + ;; If headline is not the last sibling simply return + ;; LOW-LEVEL-BODY. Otherwise, also close the list, before any + ;; blank line. + (if (not (org-export-last-sibling-p headline info)) low-level-body + (replace-regexp-in-string + "[ \t\n]*\\'" "" + low-level-body)))) + + ;; Case 3. Standard headline. Export it as a section. + (t (format section-fmt text contents))))) + + +;;;; Horizontal Rule +;; Not supported + + +;;;; Inline Babel Call +;; Inline Babel Calls are ignored. + + +;;;; Inline Src Block + +(defun org-e-man-inline-src-block (inline-src-block contents info) + "Transcode an INLINE-SRC-BLOCK element from Org to Man. +CONTENTS holds the contents of the item. INFO is a plist holding +contextual information." + (let* ((code (org-element-property :value inline-src-block))) + (cond + (org-e-man-source-highlight + (let* ((tmpdir (if (featurep 'xemacs) + temp-directory + temporary-file-directory)) + (in-file (make-temp-name + (expand-file-name "srchilite" tmpdir))) + (out-file (make-temp-name + (expand-file-name "reshilite" tmpdir))) + (org-lang (org-element-property :language inline-src-block)) + (lst-lang (cadr (assq (intern org-lang) + org-e-man-source-highlight-langs))) + + (cmd (concat (expand-file-name "source-highlight") + " -s " lst-lang + " -f groff_man" + " -i " in-file + " -o " out-file))) + + (if lst-lang + (let ((code-block "")) + (with-temp-file in-file (insert code)) + (shell-command cmd) + (setq code-block (org-file-contents out-file)) + (delete-file in-file) + (delete-file out-file) + code-block) + (format ".RS\n.nf\n\\fC\\m[black]%s\\m[]\\fP\n.fi\n.RE\n" + code)))) + + ;; Do not use a special package: transcode it verbatim. + (t + (concat ".RS\n.nf\n" "\\fC" "\n" code "\n" + "\\fP\n.fi\n.RE\n"))))) + + +;;;; Inlinetask +;;;; Italic + +(defun org-e-man-italic (italic contents info) + "Transcode ITALIC from Org to Man. +CONTENTS is the text with italic markup. INFO is a plist holding +contextual information." + (format "\\fI%s\\fP" contents)) + + +;;;; Item + +(defun org-e-man-item (item contents info) + + "Transcode an ITEM element from Org to Man. +CONTENTS holds the contents of the item. INFO is a plist holding +contextual information." + + (let* ((bullet (org-element-property :bullet item)) + (type (org-element-property :type (org-element-property :parent item))) + (checkbox (case (org-element-property :checkbox item) + (on "\\o'\\(sq\\(mu'") ;; + (off "\\(sq ") ;; + (trans "\\o'\\(sq\\(mi'"))) ;; + + (tag (let ((tag (org-element-property :tag item))) + ;; Check-boxes must belong to the tag. + (and tag (format "\\fB%s\\fP" + (concat checkbox + (org-export-data tag info))))))) + + (if (and (null tag) + (null checkbox)) + (let* ((bullet (org-trim bullet)) + (marker (cond ((string= "-" bullet) "\\(em") + ((string= "*" bullet) "\\(bu") + ((eq type 'ordered) + (format "%s " (org-trim bullet))) + (t "\\(dg")))) + (concat ".IP " marker " 4\n" + (org-trim (or contents " ")))) + ; else + (concat ".TP\n" (or tag (concat " " checkbox)) "\n" + (org-trim (or contents " ")))))) + + +;;;; Keyword + +(defun org-e-man-keyword (keyword contents info) + "Transcode a KEYWORD element from Org to Man. +CONTENTS is nil. INFO is a plist holding contextual information." + (let ((key (org-element-property :key keyword)) + (value (org-element-property :value keyword))) + (cond + ((string= key "MAN") value) + ((string= key "INDEX") nil) + ;; Invisible targets. + ((string= key "TARGET") nil) + ((string= key "TOC") nil)))) + + +;;;; Man Environment + +(defun org-e-man-man-environment (man-environment contents info) + "Transcode a MAN-ENVIRONMENT element from Org to Man. +CONTENTS is nil. INFO is a plist holding contextual information." + (let ((label (org-element-property :name man-environment)) + (value (org-remove-indentation + (org-element-property :value man-environment)))) + (if (not (org-string-nw-p label)) value + ;; Environment is labelled: label must be within the environment + ;; (otherwise, a reference pointing to that element will count + ;; the section instead). + (with-temp-buffer + (insert value) + (goto-char (point-min)) + (forward-line) + (insert (format "%s\n" label)) + (buffer-string))))) + + +;;;; Man Fragment + +(defun org-e-man-man-fragment (man-fragment contents info) + "Transcode a MAN-FRAGMENT object from Org to Man. +CONTENTS is nil. INFO is a plist holding contextual information." + (org-element-property :value man-fragment)) + + +;;;; Line Break + +(defun org-e-man-line-break (line-break contents info) + "Transcode a LINE-BREAK object from Org to Man. +CONTENTS is nil. INFO is a plist holding contextual information." + ".br\n") + + +;;;; Link + +(defun org-e-man-link (link desc info) + "Transcode a LINK object from Org to Man. + +DESC is the description part of the link, or the empty string. +INFO is a plist holding contextual information. See +`org-export-data'." + + (let* ((type (org-element-property :type link)) + (raw-path (org-element-property :path link)) + ;; Ensure DESC really exists, or set it to nil. + (desc (and (not (string= desc "")) desc)) + + (path (cond + ((member type '("http" "https" "ftp" "mailto")) + (concat type ":" raw-path)) + ((string= type "file") + (when (string-match "\\(.+\\)::.+" raw-path) + (setq raw-path (match-string 1 raw-path))) + (if (file-name-absolute-p raw-path) + (concat "file://" (expand-file-name raw-path)) + (concat "file://" raw-path))) + (t raw-path))) + protocol) + (cond + ;; External link with a description part. + ((and path desc) (format "%s \\fBat\\fP \\fI%s\\fP" path desc)) + ;; External link without a description part. + (path (format "\\fI%s\\fP" path)) + ;; No path, only description. Try to do something useful. + (t (format "\\fI%s\\fP" desc))))) + + +;;;; Macro + +(defun org-e-man-macro (macro contents info) + "Transcode a MACRO element from Org to Man. +CONTENTS is nil. INFO is a plist holding contextual information." + ;; Use available tools. + (org-export-expand-macro macro info)) + + +;;;; Paragraph + +(defun org-e-man-paragraph (paragraph contents info) + "Transcode a PARAGRAPH element from Org to Man. +CONTENTS is the contents of the paragraph, as a string. INFO is +the plist used as a communication channel." + (let ((parent (plist-get (nth 1 paragraph) :parent))) + (when parent + (let ((parent-type (car parent)) + (fixed-paragraph "")) + (cond ((and (eq parent-type 'item) + (plist-get (nth 1 parent) :bullet)) + (setq fixed-paragraph (concat "" contents))) + ((eq parent-type 'section) + (setq fixed-paragraph (concat ".PP\n" contents))) + ((eq parent-type 'footnote-definition) + (setq fixed-paragraph contents)) + (t (setq fixed-paragraph (concat "" contents)))) + fixed-paragraph)))) + + +;;;; Plain List + +(defun org-e-man-plain-list (plain-list contents info) + "Transcode a PLAIN-LIST element from Org to Man. +CONTENTS is the contents of the list. INFO is a plist holding +contextual information." + contents) + + +;;;; Plain Text + +(defun org-e-man-plain-text (text info) + "Transcode a TEXT string from Org to Man. +TEXT is the string to transcode. INFO is a plist holding +contextual information." + ;; Protect + (setq text (replace-regexp-in-string + "\\(?:[^\\]\\|^\\)\\(\\\\\\)\\(?:[^%$#&{}~^_\\]\\|$\\)" + "$\\" text nil t 1)) + + ;; Handle quotation marks + (setq text (org-e-man--quotation-marks text info)) + + ;; Handle break preservation if required. + + (when (plist-get info :preserve-breaks) + (setq text (replace-regexp-in-string "\\(\\\\\\\\\\)?[ \t]*\n" " \\\\\\\\\n" + text))) + ;; Return value. + text) + + +;;;; Planning + +;;;; Property Drawer + + +;;;; Quote Block + +(defun org-e-man-quote-block (quote-block contents info) + "Transcode a QUOTE-BLOCK element from Org to Man. +CONTENTS holds the contents of the block. INFO is a plist +holding contextual information." + (org-e-man--wrap-label + quote-block + (format ".RS\n%s\n.RE" contents))) + + +;;;; Quote Section + +(defun org-e-man-quote-section (quote-section contents info) + "Transcode a QUOTE-SECTION element from Org to Man. +CONTENTS is nil. INFO is a plist holding contextual information." + (let ((value (org-remove-indentation + (org-element-property :value quote-section)))) + (when value (format ".RS\\fI%s\\fP\n.RE\n" value)))) + + +;;;; Radio Target + +(defun org-e-man-radio-target (radio-target text info) + "Transcode a RADIO-TARGET object from Org to Man. +TEXT is the text of the target. INFO is a plist holding +contextual information." + text) + + +;;;; Section + +(defun org-e-man-section (section contents info) + "Transcode a SECTION element from Org to Man. +CONTENTS holds the contents of the section. INFO is a plist +holding contextual information." + contents) + + +;;;; Special Block + +(defun org-e-man-special-block (special-block contents info) + "Transcode a SPECIAL-BLOCK element from Org to Man. +CONTENTS holds the contents of the block. INFO is a plist +holding contextual information." + (let ((type (downcase (org-element-property :type special-block)))) + (org-e-man--wrap-label + special-block + (format "%s\n" contents)))) + + +;;;; Src Block + +(defun org-e-man-src-block (src-block contents info) + "Transcode a SRC-BLOCK element from Org to Man. +CONTENTS holds the contents of the item. INFO is a plist holding +contextual information." + + (let* ((lang (org-element-property :language src-block)) + (caption (org-element-property :caption src-block)) + (label (org-element-property :name src-block)) + (code (org-element-property :value src-block)) + (custom-env (and lang + (cadr (assq (intern lang) + org-e-man-custom-lang-environments)))) + (num-start (case (org-element-property :number-lines src-block) + (continued (org-export-get-loc src-block info)) + (new 0))) + (retain-labels (org-element-property :retain-labels src-block))) + (cond + ;; Case 1. No source fontification. + ((not org-e-man-source-highlight) + (let ((caption-str (org-e-man--caption/label-string caption label info))) + (concat + (format ".RS\n.nf\n\\fC%s\\fP\n.fi\n.RE\n\n" + (org-export-format-code-default src-block info))))) + ((and org-e-man-source-highlight) + (let* ((tmpdir (if (featurep 'xemacs) + temp-directory + temporary-file-directory)) + + (in-file (make-temp-name + (expand-file-name "srchilite" tmpdir))) + (out-file (make-temp-name + (expand-file-name "reshilite" tmpdir))) + + (org-lang (org-element-property :language src-block)) + (lst-lang (cadr (assq (intern org-lang) + org-e-man-source-highlight-langs))) + + (cmd (concat "source-highlight" + " -s " lst-lang + " -f groff_man " + " -i " in-file + " -o " out-file))) + + (if lst-lang + (let ((code-block "")) + (with-temp-file in-file (insert code)) + (shell-command cmd) + (setq code-block (org-file-contents out-file)) + (delete-file in-file) + (delete-file out-file) + code-block) + (format ".RS\n.nf\n\\fC\\m[black]%s\\m[]\\fP\n.fi\n.RE" + code))))))) + + +;;;; Statistics Cookie + +(defun org-e-man-statistics-cookie (statistics-cookie contents info) + "Transcode a STATISTICS-COOKIE object from Org to Man. +CONTENTS is nil. INFO is a plist holding contextual information." + (org-element-property :value statistics-cookie)) + + +;;;; Strike-Through + +(defun org-e-man-strike-through (strike-through contents info) + "Transcode STRIKE-THROUGH from Org to Man. +CONTENTS is the text with strike-through markup. INFO is a plist +holding contextual information." + (format "\\fI%s\\fP" contents)) + + +;;;; Subscript + +(defun org-e-man-subscript (subscript contents info) + "Transcode a SUBSCRIPT object from Org to Man. +CONTENTS is the contents of the object. INFO is a plist holding +contextual information." + (format "\\d\\s-2%s\\s+2\\u" contents)) + + +;;;; Superscript "^_%s$ + +(defun org-e-man-superscript (superscript contents info) + "Transcode a SUPERSCRIPT object from Org to Man. +CONTENTS is the contents of the object. INFO is a plist holding +contextual information." + (format "\\u\\s-2%s\\s+2\\d" contents)) + + +;;;; Table +;; +;; `org-e-man-table' is the entry point for table transcoding. It +;; takes care of tables with a "verbatim" attribute. Otherwise, it +;; delegates the job to either `org-e-man-table--table.el-table' or +;; `org-e-man-table--org-table' functions, depending of the type of +;; the table. +;; +;; `org-e-man-table--align-string' is a subroutine used to build +;; alignment string for Org tables. + +(defun org-e-man-table (table contents info) + "Transcode a TABLE element from Org to Man. +CONTENTS is the contents of the table. INFO is a plist holding +contextual information." + (cond + ;; Case 1: verbatim table. + ((or org-e-man-tables-verbatim + (let ((attr + (read + (format + "(%s)" + (mapconcat + #'identity + (org-element-property :attr_man table) + " "))))) + + (and attr (plist-get attr :verbatim)))) + + (format ".nf\n\\fC%s\\fP\n.fi" + ;; Re-create table, without affiliated keywords. + (org-trim + (org-element-interpret-data + `(table nil ,@(org-element-contents table)))))) + ;; Case 2: Standard table. + (t (org-e-man-table--org-table table contents info)))) + +(defun org-e-man-table--align-string (divider table info) + "Return an appropriate Man alignment string. +TABLE is the considered table. INFO is a plist used as +a communication channel." +(let (alignment) + ;; Extract column groups and alignment from first (non-rule) + ;; row. + (org-element-map + (org-element-map + table 'table-row + (lambda (row) + (and (eq (org-element-property :type row) 'standard) row)) + info 'first-match) + 'table-cell + (lambda (cell) + (let* ((borders (org-export-table-cell-borders cell info)) + (raw-width (org-export-table-cell-width cell info)) + (width-cm (when raw-width (/ raw-width 5))) + (width (if raw-width (format "w(%dc)" + (if (< width-cm 1) 1 width-cm)) ""))) + ;; Check left border for the first cell only. + (when (and (memq 'left borders) (not alignment)) + (push "|" alignment)) + (push + (case (org-export-table-cell-alignment cell info) + (left (concat "l" width divider)) + (right (concat "r" width divider)) + (center (concat "c" width divider))) + alignment) + (when (memq 'right borders) (push "|" alignment)))) + info) + (apply 'concat (reverse alignment)))) + +(defun org-e-man-table--org-table (table contents info) + "Return appropriate Man code for an Org table. + +TABLE is the table type element to transcode. CONTENTS is its +contents, as a string. INFO is a plist used as a communication +channel. + +This function assumes TABLE has `org' as its `:type' attribute." + (let* ((label (org-element-property :name table)) + (caption (org-e-man--caption/label-string + (org-element-property :caption table) label info)) + (attr + (read + (format + "(%s)" + (mapconcat + #'identity + (org-element-property :attr_man table) + " ")))) + + (divider (if (plist-get attr :divider) + "|" + " ")) + + ;; Determine alignment string. + (alignment (org-e-man-table--align-string divider table info)) + ;; Extract others display options. + (lines (org-split-string contents "\n")) + + (attr-list + (let ((result-list '())) + (dolist (attr-item + (list + (if (plist-get attr :expand) + "expand" + nil) + + (case (plist-get attr :placement) + ('center "center") + ('left nil) + (t + (if org-e-man-tables-centered + "center" ""))) + + (case (plist-get attr :boxtype) + ('box "box") + ('doublebox "doublebox") + ('allbox "allbox") + ('none nil) + (t "box")))) + + (if attr-item + (add-to-list 'result-list attr-item))) + result-list)) + + + (title-line (plist-get attr :title-line)) + + (table-format + (concat + (format "%s" + (or (car attr-list) "")) + (or + (let ((output-list '())) + (when (cdr attr-list) + (dolist (attr-item (cdr attr-list)) + (setq output-list (concat output-list (format ",%s" attr-item))))) + output-list) + ""))) + + (first-line + (when lines (org-split-string (car lines) "\t")))) + ;; Prepare the final format string for the table. + + (cond + ;; Others. + (lines (concat ".TS\n " table-format ";\n" + + (format "%s.\n" + (let ((final-line "")) + + (when title-line + (dotimes (i (length first-line)) + (setq final-line (concat final-line "cb" divider)))) + + (setq final-line (concat final-line "\n")) + (if alignment + (setq final-line (concat final-line alignment)) + (dotimes (i (length first-line)) + (setq final-line (concat final-line "c" divider)))) + final-line)) + + (format "%s.TE" + (let ((final-line "")) + (dolist (line-item lines) + (cond + (t + (setq lines (org-split-string contents "\n")) + + (setq final-line (concat final-line + (car (org-split-string line-item "\\\\")) "\n"))))) + final-line))))))) + + +;;;; Table Cell + +(defun org-e-man-table-cell (table-cell contents info) + "Transcode a TABLE-CELL element from Org to Man +CONTENTS is the cell contents. INFO is a plist used as +a communication channel." + (concat (if (and contents + org-e-man-table-scientific-notation + (string-match orgtbl-exp-regexp contents)) + ;; Use appropriate format string for scientific + ;; notation. + (format org-e-man-table-scientific-notation + (match-string 1 contents) + (match-string 2 contents)) + contents) + (when (org-export-get-next-element table-cell info) " \t "))) + + +;;;; Table Row + +(defun org-e-man-table-row (table-row contents info) + "Transcode a TABLE-ROW element from Org to Man +CONTENTS is the contents of the row. INFO is a plist used as +a communication channel." + ;; Rules are ignored since table separators are deduced from + ;; borders of the current row. + (when (eq (org-element-property :type table-row) 'standard) + (let* ((attr (mapconcat 'identity + (org-element-property + :attr_man (org-export-get-parent table-row)) + " ")) + ;; TABLE-ROW's borders are extracted from its first cell. + (borders + (org-export-table-cell-borders + (car (org-element-contents table-row)) info))) + (concat + ;; Mark "hline" for horizontal lines. + (cond ((and (memq 'top borders) (memq 'above borders)) "_\n")) + contents "\\\\\n" + (cond + ;; When BOOKTABS are activated enforce bottom rule even when + ;; no hline was specifically marked. + ((and (memq 'bottom borders) (memq 'below borders)) "_\n") + ((memq 'below borders) "_")))))) + + +;;;; Target + +(defun org-e-man-target (target contents info) + "Transcode a TARGET object from Org to Man. +CONTENTS is nil. INFO is a plist holding contextual +information." + (format "\\fI%s\\fP" + (org-export-solidify-link-text (org-element-property :value target)))) + + +;;;; Timestamp + +(defun org-e-man-timestamp (timestamp contents info) + "Transcode a TIMESTAMP object from Org to Man. + CONTENTS is nil. INFO is a plist holding contextual + information." + "") + + +;;;; Underline + +(defun org-e-man-underline (underline contents info) + "Transcode UNDERLINE from Org to Man. +CONTENTS is the text with underline markup. INFO is a plist +holding contextual information." + (format "\\fI%s\\fP" contents)) + + +;;;; Verbatim + +(defun org-e-man-verbatim (verbatim contents info) + "Transcode a VERBATIM object from Org to Man. +CONTENTS is nil. INFO is a plist used as a communication +channel." + (format ".nf\n%s\n.fi" contents)) + + +;;;; Verse Block + +(defun org-e-man-verse-block (verse-block contents info) + "Transcode a VERSE-BLOCK element from Org to Man. +CONTENTS is verse block contents. INFO is a plist holding +contextual information." + (format ".RS\n.ft I\n%s\n.ft\n.RE" contents)) + + + +;;; Interactive functions + +(defun org-e-man-export-to-man + (&optional subtreep visible-only body-only ext-plist pub-dir) + "Export current buffer to a Man file. + +If narrowing is active in the current buffer, only export its +narrowed part. + +If a region is active, export that region. + +When optional argument SUBTREEP is non-nil, export the sub-tree +at point, extracting information from the headline properties +first. + +When optional argument VISIBLE-ONLY is non-nil, don't export +contents of hidden elements. + +When optional argument BODY-ONLY is non-nil, only the body +without any markers. + +EXT-PLIST, when provided, is a property list with external +parameters overriding Org default settings, but still inferior to +file-local settings. + +When optional argument PUB-DIR is set, use it as the publishing +directory. + +Return output file's name." + (interactive) + (let ((outfile (org-export-output-file-name ".man" subtreep pub-dir))) + (org-export-to-file + 'e-man outfile subtreep visible-only body-only ext-plist))) + +(defun org-e-man-export-to-pdf + (&optional subtreep visible-only body-only ext-plist pub-dir) + "Export current buffer to Groff then process through to PDF. + +If narrowing is active in the current buffer, only export its +narrowed part. + +If a region is active, export that region. + +When optional argument SUBTREEP is non-nil, export the sub-tree +at point, extracting information from the headline properties +first. + +When optional argument VISIBLE-ONLY is non-nil, don't export +contents of hidden elements. + +When optional argument BODY-ONLY is non-nil, only write between +markers. + +EXT-PLIST, when provided, is a property list with external +parameters overriding Org default settings, but still inferior to +file-local settings. + +When optional argument PUB-DIR is set, use it as the publishing +directory. + +Return PDF file's name." + (interactive) + (org-e-man-compile + (org-e-man-export-to-man + subtreep visible-only body-only ext-plist pub-dir))) + +(defun org-e-man-compile (grofffile) + "Compile a Groff file. + +GROFFFILE is the name of the file being compiled. Processing is +done through the command specified in `org-e-man-pdf-process'. + +Return PDF file name or an error if it couldn't be produced." + (let* ((wconfig (current-window-configuration)) + (grofffile (file-truename grofffile)) + (base (file-name-sans-extension grofffile)) + errors) + (message (format "Processing Groff file %s ..." grofffile)) + (unwind-protect + (progn + (cond + ;; A function is provided: Apply it. + ((functionp org-e-man-pdf-process) + (funcall org-e-man-pdf-process (shell-quote-argument grofffile))) + ;; A list is provided: Replace %b, %f and %o with appropriate + ;; values in each command before applying it. Output is + ;; redirected to "*Org PDF Groff Output*" buffer. + ((consp org-e-man-pdf-process) + (let* ((out-dir (or (file-name-directory grofffile) "./")) + (outbuf (get-buffer-create "*Org PDF Groff Output*"))) + (mapc + (lambda (command) + (shell-command + (replace-regexp-in-string + "%b" (shell-quote-argument base) + (replace-regexp-in-string + "%f" (shell-quote-argument grofffile) + (replace-regexp-in-string + "%o" (shell-quote-argument out-dir) command t t) t t) t t) + outbuf)) + org-e-man-pdf-process) + ;; Collect standard errors from output buffer. + (setq errors (org-e-man-collect-errors outbuf)))) + (t (error "No valid command to process to PDF"))) + (let ((pdffile (concat base ".pdf"))) + ;; Check for process failure. Provide collected errors if + ;; possible. + (if (not (file-exists-p pdffile)) + (error (concat (format "PDF file %s wasn't produced" pdffile) + (when errors (concat ": " errors)))) + ;; Else remove log files, when specified, and signal end of + ;; process to user, along with any error encountered. + (when org-e-man-remove-logfiles + (dolist (ext org-e-man-logfiles-extensions) + (let ((file (concat base "." ext))) + (when (file-exists-p file) (delete-file file))))) + (message (concat "Process completed" + (if (not errors) "." + (concat " with errors: " errors))))) + ;; Return output file name. + pdffile)) + (set-window-configuration wconfig)))) + +(defun org-e-man-collect-errors (buffer) + "Collect some kind of errors from \"groff\" output +BUFFER is the buffer containing output. +Return collected error types as a string, or nil if there was +none." + (with-current-buffer buffer + (save-excursion + (goto-char (point-max)) + ;; Find final run + nil))) + + +(provide 'org-e-man) +;;; org-e-man.el ends here diff --git a/contrib/lisp/org-e-odt.el b/contrib/lisp/org-e-odt.el new file mode 100644 index 0000000..b2f7479 --- /dev/null +++ b/contrib/lisp/org-e-odt.el @@ -0,0 +1,3762 @@ +;;; org-e-odt.el --- OpenDocument Text exporter for Org-mode + +;; Copyright (C) 2010-2012 Free Software Foundation, Inc. + +;; Author: Jambunathan K +;; Keywords: outlines, hypermedia, calendar, wp +;; Homepage: http://orgmode.org + +;; This file is not part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;;; Code: + +(eval-when-compile + (require 'cl) + (require 'table)) +(require 'format-spec) +(require 'org-export) + +;;; Define Back-End + +(org-export-define-backend e-odt + ((bold . org-e-odt-bold) + (center-block . org-e-odt-center-block) + (clock . org-e-odt-clock) + (code . org-e-odt-code) + (drawer . org-e-odt-drawer) + (dynamic-block . org-e-odt-dynamic-block) + (entity . org-e-odt-entity) + (example-block . org-e-odt-example-block) + (export-block . org-e-odt-export-block) + (export-snippet . org-e-odt-export-snippet) + (fixed-width . org-e-odt-fixed-width) + (footnote-definition . org-e-odt-footnote-definition) + (footnote-reference . org-e-odt-footnote-reference) + (headline . org-e-odt-headline) + (horizontal-rule . org-e-odt-horizontal-rule) + (inline-src-block . org-e-odt-inline-src-block) + (inlinetask . org-e-odt-inlinetask) + (italic . org-e-odt-italic) + (item . org-e-odt-item) + (keyword . org-e-odt-keyword) + (latex-environment . org-e-odt-latex-environment) + (latex-fragment . org-e-odt-latex-fragment) + (line-break . org-e-odt-line-break) + (link . org-e-odt-link) + (macro . org-e-odt-macro) + (paragraph . org-e-odt-paragraph) + (plain-list . org-e-odt-plain-list) + (plain-text . org-e-odt-plain-text) + (planning . org-e-odt-planning) + (property-drawer . org-e-odt-property-drawer) + (quote-block . org-e-odt-quote-block) + (quote-section . org-e-odt-quote-section) + (radio-target . org-e-odt-radio-target) + (section . org-e-odt-section) + (special-block . org-e-odt-special-block) + (src-block . org-e-odt-src-block) + (statistics-cookie . org-e-odt-statistics-cookie) + (strike-through . org-e-odt-strike-through) + (subscript . org-e-odt-subscript) + (superscript . org-e-odt-superscript) + (table . org-e-odt-table) + (table-cell . org-e-odt-table-cell) + (table-row . org-e-odt-table-row) + (target . org-e-odt-target) + (template . org-e-odt-template) + (timestamp . org-e-odt-timestamp) + (underline . org-e-odt-underline) + (verbatim . org-e-odt-verbatim) + (verse-block . org-e-odt-verse-block)) + :export-block "ODT" + :options-alist + ((:odt-styles-file "ODT_STYLES_FILE" nil nil t) + (:LaTeX-fragments nil "LaTeX" org-export-with-LaTeX-fragments))) + + +;;; Dependencies + +;;; Hooks + +;;; Function Declarations + +(declare-function org-id-find-id-file "org-id" (id)) +(declare-function hfy-face-to-style "htmlfontify" (fn)) +(declare-function hfy-face-or-def-to-name "htmlfontify" (fn)) +(declare-function archive-zip-extract "arc-mode.el" (archive name)) +(declare-function org-create-math-formula "org" (latex-frag &optional mathml-file)) +(declare-function browse-url-file-url "browse-url" (file)) + + + + +;;; Internal Variables + +(defconst org-e-odt-lib-dir + (file-name-directory load-file-name) + "Location of ODT exporter. +Use this to infer values of `org-e-odt-styles-dir' and +`org-e-odt-schema-dir'.") + +(defvar org-e-odt-data-dir + (expand-file-name "../../etc/" org-e-odt-lib-dir) + "Data directory for ODT exporter. +Use this to infer values of `org-e-odt-styles-dir' and +`org-e-odt-schema-dir'.") + +(defconst org-e-odt-special-string-regexps + '(("\\\\-" . "­\\1") ; shy + ("---\\([^-]\\)" . "—\\1") ; mdash + ("--\\([^-]\\)" . "–\\1") ; ndash + ("\\.\\.\\." . "…")) ; hellip + "Regular expressions for special string conversion.") + +(defconst org-e-odt-schema-dir-list + (list + (and org-e-odt-data-dir + (expand-file-name "./schema/" org-e-odt-data-dir)) ; bail out + (eval-when-compile + (and (boundp 'org-e-odt-data-dir) org-e-odt-data-dir ; see make install + (expand-file-name "./schema/" org-e-odt-data-dir)))) + "List of directories to search for OpenDocument schema files. +Use this list to set the default value of +`org-e-odt-schema-dir'. The entries in this list are +populated heuristically based on the values of `org-e-odt-lib-dir' +and `org-e-odt-data-dir'.") + +(defconst org-e-odt-styles-dir-list + (list + (and org-e-odt-data-dir + (expand-file-name "./styles/" org-e-odt-data-dir)) ; bail out + (eval-when-compile + (and (boundp 'org-e-odt-data-dir) org-e-odt-data-dir ; see make install + (expand-file-name "./styles/" org-e-odt-data-dir))) + (expand-file-name "../../etc/styles/" org-e-odt-lib-dir) ; git + (expand-file-name "./etc/styles/" org-e-odt-lib-dir) ; elpa + (expand-file-name "./org/" data-directory) ; system + ) + "List of directories to search for OpenDocument styles files. +See `org-e-odt-styles-dir'. The entries in this list are populated +heuristically based on the values of `org-e-odt-lib-dir' and +`org-e-odt-data-dir'.") + +(defconst org-e-odt-styles-dir + (let* ((styles-dir + (catch 'styles-dir + (message "Debug (org-e-odt): Searching for OpenDocument styles files...") + (mapc (lambda (styles-dir) + (when styles-dir + (message "Debug (org-e-odt): Trying %s..." styles-dir) + (when (and (file-readable-p + (expand-file-name + "OrgOdtContentTemplate.xml" styles-dir)) + (file-readable-p + (expand-file-name + "OrgOdtStyles.xml" styles-dir))) + (message "Debug (org-e-odt): Using styles under %s" + styles-dir) + (throw 'styles-dir styles-dir)))) + org-e-odt-styles-dir-list) + nil))) + (unless styles-dir + (error "Error (org-e-odt): Cannot find factory styles files, aborting")) + styles-dir) + "Directory that holds auxiliary XML files used by the ODT exporter. + +This directory contains the following XML files - + \"OrgOdtStyles.xml\" and \"OrgOdtContentTemplate.xml\". These + XML files are used as the default values of + `org-e-odt-styles-file' and + `org-e-odt-content-template-file'. + +The default value of this variable varies depending on the +version of org in use and is initialized from +`org-e-odt-styles-dir-list'. Note that the user could be using org +from one of: org's own private git repository, GNU ELPA tar or +standard Emacs.") + +(defconst org-e-odt-bookmark-prefix "OrgXref.") + +(defconst org-e-odt-manifest-file-entry-tag + "\n") + +(defconst org-e-odt-file-extensions + '(("odt" . "OpenDocument Text") + ("ott" . "OpenDocument Text Template") + ("odm" . "OpenDocument Master Document") + ("ods" . "OpenDocument Spreadsheet") + ("ots" . "OpenDocument Spreadsheet Template") + ("odg" . "OpenDocument Drawing (Graphics)") + ("otg" . "OpenDocument Drawing Template") + ("odp" . "OpenDocument Presentation") + ("otp" . "OpenDocument Presentation Template") + ("odi" . "OpenDocument Image") + ("odf" . "OpenDocument Formula") + ("odc" . "OpenDocument Chart"))) + +(defvar org-e-odt-table-style-format + " + + + +" + "Template for auto-generated Table styles.") + +(defvar org-e-odt-automatic-styles '() + "Registry of automatic styles for various OBJECT-TYPEs. +The variable has the following form: +\(\(OBJECT-TYPE-A + \(\(OBJECT-NAME-A.1 OBJECT-PROPS-A.1\) + \(OBJECT-NAME-A.2 OBJECT-PROPS-A.2\) ...\)\) + \(OBJECT-TYPE-B + \(\(OBJECT-NAME-B.1 OBJECT-PROPS-B.1\) + \(OBJECT-NAME-B.2 OBJECT-PROPS-B.2\) ...\)\) + ...\). + +OBJECT-TYPEs could be \"Section\", \"Table\", \"Figure\" etc. +OBJECT-PROPS is (typically) a plist created by passing +\"#+ATTR_ODT: \" option to `org-e-odt-parse-block-attributes'. + +Use `org-e-odt-add-automatic-style' to add update this variable.'") + +(defvar org-e-odt-object-counters nil + "Running counters for various OBJECT-TYPEs. +Use this to generate automatic names and style-names. See +`org-e-odt-add-automatic-style'.") + +(defvar org-e-odt-src-block-paragraph-format + " + + + + + " + "Custom paragraph style for colorized source and example blocks. +This style is much the same as that of \"OrgFixedWidthBlock\" +except that the foreground and background colors are set +according to the default face identified by the `htmlfontify'.") + +(defvar hfy-optimisations) +(defvar org-e-odt-embedded-formulas-count 0) +(defvar org-e-odt-entity-frame-styles + '(("As-CharImage" "__Figure__" ("OrgInlineImage" nil "as-char")) + ("ParagraphImage" "__Figure__" ("OrgDisplayImage" nil "paragraph")) + ("PageImage" "__Figure__" ("OrgPageImage" nil "page")) + ("CaptionedAs-CharImage" "__Figure__" + ("OrgCaptionedImage" + " style:rel-width=\"100%\" style:rel-height=\"scale\"" "paragraph") + ("OrgInlineImage" nil "as-char")) + ("CaptionedParagraphImage" "__Figure__" + ("OrgCaptionedImage" + " style:rel-width=\"100%\" style:rel-height=\"scale\"" "paragraph") + ("OrgImageCaptionFrame" nil "paragraph")) + ("CaptionedPageImage" "__Figure__" + ("OrgCaptionedImage" + " style:rel-width=\"100%\" style:rel-height=\"scale\"" "paragraph") + ("OrgPageImageCaptionFrame" nil "page")) + ("InlineFormula" "__MathFormula__" ("OrgInlineFormula" nil "as-char")) + ("DisplayFormula" "__MathFormula__" ("OrgDisplayFormula" nil "as-char")) + ("CaptionedDisplayFormula" "__MathFormula__" + ("OrgCaptionedFormula" nil "paragraph") + ("OrgFormulaCaptionFrame" nil "as-char")))) + +(defvar org-e-odt-embedded-images-count 0) +(defvar org-e-odt-image-size-probe-method + (append (and (executable-find "identify") '(imagemagick)) ; See Bug#10675 + '(emacs fixed)) + "Ordered list of methods for determining image sizes.") + +(defvar org-e-odt-default-image-sizes-alist + '(("as-char" . (5 . 0.4)) + ("paragraph" . (5 . 5))) + "Hardcoded image dimensions one for each of the anchor + methods.") + +;; A4 page size is 21.0 by 29.7 cms +;; The default page settings has 2cm margin on each of the sides. So +;; the effective text area is 17.0 by 25.7 cm +(defvar org-e-odt-max-image-size '(17.0 . 20.0) + "Limiting dimensions for an embedded image.") + +(defvar org-e-odt-label-styles + '(("math-formula" "%c" "text" "(%n)") + ("math-label" "(%n)" "text" "(%n)") + ("category-and-value" "%e %n: %c" "category-and-value" "%e %n") + ("value" "%e %n: %c" "value" "%n")) + "Specify how labels are applied and referenced. +This is an alist where each element is of the +form (LABEL-STYLE-NAME LABEL-ATTACH-FMT LABEL-REF-MODE +LABEL-REF-FMT). + +LABEL-ATTACH-FMT controls how labels and captions are attached to +an entity. It may contain following specifiers - %e, %n and %c. +%e is replaced with the CATEGORY-NAME. %n is replaced with +\" SEQNO \". %c is replaced +with CAPTION. See `org-e-odt-format-label-definition'. + +LABEL-REF-MODE and LABEL-REF-FMT controls how label references +are generated. The following XML is generated for a label +reference - \" LABEL-REF-FMT +\". LABEL-REF-FMT may contain following +specifiers - %e and %n. %e is replaced with the CATEGORY-NAME. +%n is replaced with SEQNO. See +`org-e-odt-format-label-reference'.") + +(defvar org-e-odt-category-map-alist + '(("__Table__" "Table" "value" "Table") + ("__Figure__" "Illustration" "value" "Figure") + ("__MathFormula__" "Text" "math-formula" "Equation") + ("__DvipngImage__" "Equation" "value" "Equation") + ("__Listing__" "Listing" "value" "Listing") + ;; ("__Table__" "Table" "category-and-value") + ;; ("__Figure__" "Figure" "category-and-value") + ;; ("__DvipngImage__" "Equation" "category-and-value") + ) + "Map a CATEGORY-HANDLE to OD-VARIABLE and LABEL-STYLE. +This is a list where each entry is of the form \\(CATEGORY-HANDLE +OD-VARIABLE LABEL-STYLE CATEGORY-NAME\\). CATEGORY_HANDLE +identifies the captionable entity in question. OD-VARIABLE is +the OpenDocument sequence counter associated with the entity. +These counters are declared within +\"...\" block of +`org-e-odt-content-template-file'. LABEL-STYLE is a key into +`org-e-odt-label-styles' and specifies how a given entity should +be captioned and referenced. CATEGORY-NAME is used for +qualifying captions on export. You can modify the CATEGORY-NAME +used in the exported document by modifying +`org-export-dictionary'. For example, an embedded image in an +English document is captioned as \"Figure 1: Orgmode Logo\", by +default. If you want the image to be captioned as \"Illustration +1: Orgmode Logo\" instead, install an entry in +`org-export-dictionary' which translates \"Figure\" to +\"Illustration\" when the language is \"en\" and encoding is +`:utf-8'.") + +(defvar org-e-odt-manifest-file-entries nil) +(defvar hfy-user-sheet-assoc) + +(defvar org-e-odt-zip-dir nil + "Temporary work directory for OpenDocument exporter.") + + + +;;; User Configuration Variables + +(defgroup org-export-e-odt nil + "Options for exporting Org mode files to ODT." + :tag "Org Export ODT" + :group 'org-export) + + +;;;; Debugging + +(defcustom org-e-odt-prettify-xml nil + "Specify whether or not the xml output should be prettified. +When this option is turned on, `indent-region' is run on all +component xml buffers before they are saved. Turn this off for +regular use. Turn this on if you need to examine the xml +visually." + :group 'org-export-e-odt + :version "24.1" + :type 'boolean) + + +;;;; Document schema + +(defcustom org-e-odt-schema-dir + (let* ((schema-dir + (catch 'schema-dir + (message "Debug (org-e-odt): Searching for OpenDocument schema files...") + (mapc + (lambda (schema-dir) + (when schema-dir + (message "Debug (org-e-odt): Trying %s..." schema-dir) + (when (and (file-readable-p + (expand-file-name "od-manifest-schema-v1.2-cs01.rnc" + schema-dir)) + (file-readable-p + (expand-file-name "od-schema-v1.2-cs01.rnc" + schema-dir)) + (file-readable-p + (expand-file-name "schemas.xml" schema-dir))) + (message "Debug (org-e-odt): Using schema files under %s" + schema-dir) + (throw 'schema-dir schema-dir)))) + org-e-odt-schema-dir-list) + (message "Debug (org-e-odt): No OpenDocument schema files installed") + nil))) + schema-dir) + "Directory that contains OpenDocument schema files. + +This directory contains: +1. rnc files for OpenDocument schema +2. a \"schemas.xml\" file that specifies locating rules needed + for auto validation of OpenDocument XML files. + +Use the customize interface to set this variable. This ensures +that `rng-schema-locating-files' is updated and auto-validation +of OpenDocument XML takes place based on the value +`rng-nxml-auto-validate-flag'. + +The default value of this variable varies depending on the +version of org in use and is initialized from +`org-e-odt-schema-dir-list'. The OASIS schema files are available +only in the org's private git repository. It is *not* bundled +with GNU ELPA tar or standard Emacs distribution." + :type '(choice + (const :tag "Not set" nil) + (directory :tag "Schema directory")) + :group 'org-export-e-odt + :version "24.1" + :set + (lambda (var value) + "Set `org-e-odt-schema-dir'. +Also add it to `rng-schema-locating-files'." + (let ((schema-dir value)) + (set var + (if (and + (file-readable-p + (expand-file-name "od-manifest-schema-v1.2-cs01.rnc" schema-dir)) + (file-readable-p + (expand-file-name "od-schema-v1.2-cs01.rnc" schema-dir)) + (file-readable-p + (expand-file-name "schemas.xml" schema-dir))) + schema-dir + (when value + (message "Error (org-e-odt): %s has no OpenDocument schema files" + value)) + nil))) + (when org-e-odt-schema-dir + (eval-after-load 'rng-loc + '(add-to-list 'rng-schema-locating-files + (expand-file-name "schemas.xml" + org-e-odt-schema-dir)))))) + + +;;;; Document styles + +(defcustom org-e-odt-content-template-file nil + "Template file for \"content.xml\". +The exporter embeds the exported content just before +\"\" element. + +If unspecified, the file named \"OrgOdtContentTemplate.xml\" +under `org-e-odt-styles-dir' is used." + :type 'file + :group 'org-export-e-odt + :version "24.1") + +(defcustom org-e-odt-styles-file nil + "Default styles file for use with ODT export. +Valid values are one of: +1. nil +2. path to a styles.xml file +3. path to a *.odt or a *.ott file +4. list of the form (ODT-OR-OTT-FILE (FILE-MEMBER-1 FILE-MEMBER-2 +...)) + +In case of option 1, an in-built styles.xml is used. See +`org-e-odt-styles-dir' for more information. + +In case of option 3, the specified file is unzipped and the +styles.xml embedded therein is used. + +In case of option 4, the specified ODT-OR-OTT-FILE is unzipped +and FILE-MEMBER-1, FILE-MEMBER-2 etc are copied in to the +generated odt file. Use relative path for specifying the +FILE-MEMBERS. styles.xml must be specified as one of the +FILE-MEMBERS. + +Use options 1, 2 or 3 only if styles.xml alone suffices for +achieving the desired formatting. Use option 4, if the styles.xml +references additional files like header and footer images for +achieving the desired formatting. + +Use \"#+ODT_STYLES_FILE: ...\" directive to set this variable on +a per-file basis. For example, + +#+ODT_STYLES_FILE: \"/path/to/styles.xml\" or +#+ODT_STYLES_FILE: (\"/path/to/file.ott\" (\"styles.xml\" \"image/hdr.png\"))." + :group 'org-export-e-odt + :version "24.1" + :type + '(choice + (const :tag "Factory settings" nil) + (file :must-match t :tag "styles.xml") + (file :must-match t :tag "ODT or OTT file") + (list :tag "ODT or OTT file + Members" + (file :must-match t :tag "ODF Text or Text Template file") + (cons :tag "Members" + (file :tag " Member" "styles.xml") + (repeat (file :tag "Member")))))) + +(defcustom org-e-odt-display-outline-level 2 + "Outline levels considered for enumerating captioned entities." + :group 'org-export-e-odt + :version "24.2" + :type 'integer) + +;;;; Document conversion + +(defcustom org-e-odt-convert-processes + '(("LibreOffice" + "soffice --headless --convert-to %f%x --outdir %d %i") + ("unoconv" + "unoconv -f %f -o %d %i")) + "Specify a list of document converters and their usage. +The converters in this list are offered as choices while +customizing `org-e-odt-convert-process'. + +This variable is a list where each element is of the +form (CONVERTER-NAME CONVERTER-CMD). CONVERTER-NAME is the name +of the converter. CONVERTER-CMD is the shell command for the +converter and can contain format specifiers. These format +specifiers are interpreted as below: + +%i input file name in full +%I input file name as a URL +%f format of the output file +%o output file name in full +%O output file name as a URL +%d output dir in full +%D output dir as a URL. +%x extra options as set in `org-e-odt-convert-capabilities'." + :group 'org-export-e-odt + :version "24.1" + :type + '(choice + (const :tag "None" nil) + (alist :tag "Converters" + :key-type (string :tag "Converter Name") + :value-type (group (string :tag "Command line"))))) + +(defcustom org-e-odt-convert-process "LibreOffice" + "Use this converter to convert from \"odt\" format to other formats. +During customization, the list of converter names are populated +from `org-e-odt-convert-processes'." + :group 'org-export-e-odt + :version "24.1" + :type '(choice :convert-widget + (lambda (w) + (apply 'widget-convert (widget-type w) + (eval (car (widget-get w :args))))) + `((const :tag "None" nil) + ,@(mapcar (lambda (c) + `(const :tag ,(car c) ,(car c))) + org-e-odt-convert-processes)))) + +(defcustom org-e-odt-convert-capabilities + '(("Text" + ("odt" "ott" "doc" "rtf" "docx") + (("pdf" "pdf") ("odt" "odt") ("rtf" "rtf") ("ott" "ott") + ("doc" "doc" ":\"MS Word 97\"") ("docx" "docx") ("html" "html"))) + ("Web" + ("html") + (("pdf" "pdf") ("odt" "odt") ("html" "html"))) + ("Spreadsheet" + ("ods" "ots" "xls" "csv" "xlsx") + (("pdf" "pdf") ("ots" "ots") ("html" "html") ("csv" "csv") ("ods" "ods") + ("xls" "xls") ("xlsx" "xlsx"))) + ("Presentation" + ("odp" "otp" "ppt" "pptx") + (("pdf" "pdf") ("swf" "swf") ("odp" "odp") ("otp" "otp") ("ppt" "ppt") + ("pptx" "pptx") ("odg" "odg")))) + "Specify input and output formats of `org-e-odt-convert-process'. +More correctly, specify the set of input and output formats that +the user is actually interested in. + +This variable is an alist where each element is of the +form (DOCUMENT-CLASS INPUT-FMT-LIST OUTPUT-FMT-ALIST). +INPUT-FMT-LIST is a list of INPUT-FMTs. OUTPUT-FMT-ALIST is an +alist where each element is of the form (OUTPUT-FMT +OUTPUT-FILE-EXTENSION EXTRA-OPTIONS). + +The variable is interpreted as follows: +`org-e-odt-convert-process' can take any document that is in +INPUT-FMT-LIST and produce any document that is in the +OUTPUT-FMT-LIST. A document converted to OUTPUT-FMT will have +OUTPUT-FILE-EXTENSION as the file name extension. OUTPUT-FMT +serves dual purposes: +- It is used for populating completion candidates during + `org-e-odt-convert' commands. +- It is used as the value of \"%f\" specifier in + `org-e-odt-convert-process'. + +EXTRA-OPTIONS is used as the value of \"%x\" specifier in +`org-e-odt-convert-process'. + +DOCUMENT-CLASS is used to group a set of file formats in +INPUT-FMT-LIST in to a single class. + +Note that this variable inherently captures how LibreOffice based +converters work. LibreOffice maps documents of various formats +to classes like Text, Web, Spreadsheet, Presentation etc and +allow document of a given class (irrespective of it's source +format) to be converted to any of the export formats associated +with that class. + +See default setting of this variable for an typical +configuration." + :group 'org-export-e-odt + :version "24.1" + :type + '(choice + (const :tag "None" nil) + (alist :tag "Capabilities" + :key-type (string :tag "Document Class") + :value-type + (group (repeat :tag "Input formats" (string :tag "Input format")) + (alist :tag "Output formats" + :key-type (string :tag "Output format") + :value-type + (group (string :tag "Output file extension") + (choice + (const :tag "None" nil) + (string :tag "Extra options")))))))) + +(defcustom org-e-odt-preferred-output-format nil + "Automatically post-process to this format after exporting to \"odt\". +Interactive commands `org-export-as-e-odt' and +`org-export-as-e-odt-and-open' export first to \"odt\" format and +then use `org-e-odt-convert-process' to convert the +resulting document to this format. During customization of this +variable, the list of valid values are populated based on +`org-e-odt-convert-capabilities'." + :group 'org-export-e-odt + :version "24.1" + :type '(choice :convert-widget + (lambda (w) + (apply 'widget-convert (widget-type w) + (eval (car (widget-get w :args))))) + `((const :tag "None" nil) + ,@(mapcar (lambda (c) + `(const :tag ,c ,c)) + (org-e-odt-reachable-formats "odt"))))) + + +;;;; Drawers + +(defcustom org-e-odt-format-drawer-function nil + "Function called to format a drawer in HTML code. + +The function must accept two parameters: + NAME the drawer name, like \"LOGBOOK\" + CONTENTS the contents of the drawer. + +The function should return the string to be exported. + +For example, the variable could be set to the following function +in order to mimic default behaviour: + +\(defun org-e-odt-format-drawer-default \(name contents\) + \"Format a drawer element for HTML export.\" + contents\)" + :group 'org-export-e-odt + :type 'function) + + +;;;; Headline + +(defcustom org-e-odt-format-headline-function nil + "Function to format headline text. + +This function will be called with 5 arguments: +TODO the todo keyword \(string or nil\). +TODO-TYPE the type of todo \(symbol: `todo', `done', nil\) +PRIORITY the priority of the headline \(integer or nil\) +TEXT the main headline text \(string\). +TAGS the tags string, separated with colons \(string or nil\). + +The function result will be used in the section format string. + +As an example, one could set the variable to the following, in +order to reproduce the default set-up: + +\(defun org-e-odt-format-headline \(todo todo-type priority text tags\) + \"Default format function for an headline.\" + \(concat \(when todo + \(format \"\\\\textbf{\\\\textsc{\\\\textsf{%s}}} \" todo\)\) + \(when priority + \(format \"\\\\framebox{\\\\#%c} \" priority\)\) + text + \(when tags \(format \"\\\\hfill{}\\\\textsc{%s}\" tags\)\)\)\)" + :group 'org-export-e-odt + :type 'function) + + +;;;; Inlinetasks + +(defcustom org-e-odt-format-inlinetask-function nil + "Function called to format an inlinetask in HTML code. + +The function must accept six parameters: + TODO the todo keyword, as a string + TODO-TYPE the todo type, a symbol among `todo', `done' and nil. + PRIORITY the inlinetask priority, as a string + NAME the inlinetask name, as a string. + TAGS the inlinetask tags, as a string. + CONTENTS the contents of the inlinetask, as a string. + +The function should return the string to be exported. + +For example, the variable could be set to the following function +in order to mimic default behaviour: + +\(defun org-e-odt-format-inlinetask \(todo type priority name tags contents\) +\"Format an inline task element for HTML export.\" + \(let \(\(full-title + \(concat + \(when todo + \(format \"\\\\textbf{\\\\textsf{\\\\textsc{%s}}} \" todo\)\) + \(when priority \(format \"\\\\framebox{\\\\#%c} \" priority\)\) + title + \(when tags \(format \"\\\\hfill{}\\\\textsc{%s}\" tags\)\)\)\)\) + \(format \(concat \"\\\\begin{center}\\n\" + \"\\\\fbox{\\n\" + \"\\\\begin{minipage}[c]{.6\\\\textwidth}\\n\" + \"%s\\n\\n\" + \"\\\\rule[.8em]{\\\\textwidth}{2pt}\\n\\n\" + \"%s\" + \"\\\\end{minipage}}\" + \"\\\\end{center}\"\) + full-title contents\)\)" + :group 'org-export-e-odt + :type 'function) + + +;;;; Links + +(defcustom org-e-odt-inline-image-rules + '(("file" . "\\.\\(jpeg\\|jpg\\|png\\|gif\\)\\'")) + "Rules characterizing image files that can be inlined into HTML. + +A rule consists in an association whose key is the type of link +to consider, and value is a regexp that will be matched against +link's path. + +Note that, by default, the image extension *actually* allowed +depend on the way the HTML file is processed. When used with +pdflatex, pdf, jpg and png images are OK. When processing +through dvi to Postscript, only ps and eps are allowed. The +default we use here encompasses both." + :group 'org-export-e-odt + :type '(alist :key-type (string :tag "Type") + :value-type (regexp :tag "Path"))) + +(defcustom org-e-odt-pixels-per-inch display-pixels-per-inch + "Scaling factor for converting images pixels to inches. +Use this for sizing of embedded images. See Info node `(org) +Images in ODT export' for more information." + :type 'float + :group 'org-export-e-odt + :version "24.1") + + +;;;; Plain text + +(defcustom org-e-odt-quotes + '(("fr" + ("\\(\\s-\\|[[(]\\|^\\)\"" . "« ") + ("\\(\\S-\\)\"" . "» ") + ("\\(\\s-\\|(\\|^\\)'" . "'")) + ("en" + ("\\(\\s-\\|[[(]\\|^\\)\"" . "“") + ("\\(\\S-\\)\"" . "”") + ("\\(\\s-\\|(\\|^\\)'" . "‘") + ("\\(\\S-\\)'" . "’"))) + "Alist for quotes to use when converting english double-quotes. + +The CAR of each item in this alist is the language code. +The CDR of each item in this alist is a list of three CONS: +- the first CONS defines the opening quote; +- the second CONS defines the closing quote; +- the last CONS defines single quotes. + +For each item in a CONS, the first string is a regexp +for allowed characters before/after the quote, the second +string defines the replacement string for this quote." + :group 'org-export-e-odt + :type '(list + (cons :tag "Opening quote" + (string :tag "Regexp for char before") + (string :tag "Replacement quote ")) + (cons :tag "Closing quote" + (string :tag "Regexp for char after ") + (string :tag "Replacement quote ")) + (cons :tag "Single quote" + (string :tag "Regexp for char before") + (string :tag "Replacement quote ")))) + + +;;;; Src Block + +(defcustom org-e-odt-create-custom-styles-for-srcblocks t + "Whether custom styles for colorized source blocks be automatically created. +When this option is turned on, the exporter creates custom styles +for source blocks based on the advice of `htmlfontify'. Creation +of custom styles happen as part of `org-e-odt-hfy-face-to-css'. + +When this option is turned off exporter does not create such +styles. + +Use the latter option if you do not want the custom styles to be +based on your current display settings. It is necessary that the +styles.xml already contains needed styles for colorizing to work. + +This variable is effective only if +`org-e-odt-fontify-srcblocks' is turned on." + :group 'org-export-e-odt + :version "24.1" + :type 'boolean) + +(defcustom org-e-odt-fontify-srcblocks t + "Specify whether or not source blocks need to be fontified. +Turn this option on if you want to colorize the source code +blocks in the exported file. For colorization to work, you need +to make available an enhanced version of `htmlfontify' library." + :type 'boolean + :group 'org-export-e-odt + :version "24.1") + + +;;;; Table + +(defcustom org-e-odt-table-caption-above t + "When non-nil, place caption string at the beginning of the table. +Otherwise, place it near the end." + :group 'org-export-e-odt + :type 'boolean) + +(defcustom org-e-odt-table-styles + '(("OrgEquation" "OrgEquation" + ((use-first-column-styles . t) + (use-last-column-styles . t)))) + "Specify how Table Styles should be derived from a Table Template. +This is a list where each element is of the +form (TABLE-STYLE-NAME TABLE-TEMPLATE-NAME TABLE-CELL-OPTIONS). + +TABLE-STYLE-NAME is the style associated with the table through +\"#+ATTR_ODT: :style TABLE-STYLE-NAME\" line. + +TABLE-TEMPLATE-NAME is a set of - upto 9 - automatic +TABLE-CELL-STYLE-NAMEs and PARAGRAPH-STYLE-NAMEs (as defined +below) that is included in +`org-e-odt-content-template-file'. + +TABLE-CELL-STYLE-NAME := TABLE-TEMPLATE-NAME + TABLE-CELL-TYPE + + \"TableCell\" +PARAGRAPH-STYLE-NAME := TABLE-TEMPLATE-NAME + TABLE-CELL-TYPE + + \"TableParagraph\" +TABLE-CELL-TYPE := \"FirstRow\" | \"LastColumn\" | + \"FirstRow\" | \"LastRow\" | + \"EvenRow\" | \"OddRow\" | + \"EvenColumn\" | \"OddColumn\" | \"\" +where \"+\" above denotes string concatenation. + +TABLE-CELL-OPTIONS is an alist where each element is of the +form (TABLE-CELL-STYLE-SELECTOR . ON-OR-OFF). +TABLE-CELL-STYLE-SELECTOR := `use-first-row-styles' | + `use-last-row-styles' | + `use-first-column-styles' | + `use-last-column-styles' | + `use-banding-rows-styles' | + `use-banding-columns-styles' | + `use-first-row-styles' +ON-OR-OFF := `t' | `nil' + +For example, with the following configuration + +\(setq org-e-odt-table-styles + '\(\(\"TableWithHeaderRowsAndColumns\" \"Custom\" + \(\(use-first-row-styles . t\) + \(use-first-column-styles . t\)\)\) + \(\"TableWithHeaderColumns\" \"Custom\" + \(\(use-first-column-styles . t\)\)\)\)\) + +1. A table associated with \"TableWithHeaderRowsAndColumns\" + style will use the following table-cell styles - + \"CustomFirstRowTableCell\", \"CustomFirstColumnTableCell\", + \"CustomTableCell\" and the following paragraph styles + \"CustomFirstRowTableParagraph\", + \"CustomFirstColumnTableParagraph\", \"CustomTableParagraph\" + as appropriate. + +2. A table associated with \"TableWithHeaderColumns\" style will + use the following table-cell styles - + \"CustomFirstColumnTableCell\", \"CustomTableCell\" and the + following paragraph styles + \"CustomFirstColumnTableParagraph\", \"CustomTableParagraph\" + as appropriate.. + +Note that TABLE-TEMPLATE-NAME corresponds to the +\"\" elements contained within +\"\". The entries (TABLE-STYLE-NAME +TABLE-TEMPLATE-NAME TABLE-CELL-OPTIONS) correspond to +\"table:template-name\" and \"table:use-first-row-styles\" etc +attributes of \"\" element. Refer ODF-1.2 +specification for more information. Also consult the +implementation filed under `org-e-odt-get-table-cell-styles'. + +The TABLE-STYLE-NAME \"OrgEquation\" is used internally for +formatting of numbered display equations. Do not delete this +style from the list." + :group 'org-export-e-odt + :version "24.1" + :type '(choice + (const :tag "None" nil) + (repeat :tag "Table Styles" + (list :tag "Table Style Specification" + (string :tag "Table Style Name") + (string :tag "Table Template Name") + (alist :options (use-first-row-styles + use-last-row-styles + use-first-column-styles + use-last-column-styles + use-banding-rows-styles + use-banding-columns-styles) + :key-type symbol + :value-type (const :tag "True" t)))))) + + + +;;; Internal functions + +;;;; Date + +(defun org-e-odt--date (&optional org-ts fmt) + (save-match-data + (let* ((time + (and (stringp org-ts) + (string-match org-ts-regexp0 org-ts) + (apply 'encode-time + (org-fix-decoded-time + (org-parse-time-string (match-string 0 org-ts) t))))) + date) + (cond + (fmt (format-time-string fmt time)) + (t (setq date (format-time-string "%Y-%m-%dT%H:%M:%S%z" time)) + (format "%s:%s" (substring date 0 -2) (substring date -2))))))) + +;;;; Frame + +(defun org-e-odt--frame (text width height style &optional extra + anchor-type) + (let ((frame-attrs + (concat + (if width (format " svg:width=\"%0.2fcm\"" width) "") + (if height (format " svg:height=\"%0.2fcm\"" height) "") + extra + (format " text:anchor-type=\"%s\"" (or anchor-type "paragraph"))))) + (format + "\n\n%s\n" + style frame-attrs + (concat text + (let ((title (get-text-property 0 :title text)) + (desc (get-text-property 0 :description text))) + (concat (and title + (format "%s" + (org-e-odt-encode-plain-text title t))) + (and desc + (format "%s" + (org-e-odt-encode-plain-text desc t))))))))) + +;;;; Library wrappers + +(defun org-e-odt--adopt-elements (parent &rest children) + (prog1 parent + (mapc (lambda (child) + (let ((parent-1 (org-element-adopt-element parent child nil))) + (assert (eq parent-1 parent)))) + children))) + +(defun org-e-odt--zip-extract (archive members target) + (when (atom members) (setq members (list members))) + (mapc (lambda (archive member target) + (require 'arc-mode) + (let* ((--quote-file-name + ;; This is shamelessly stolen from `archive-zip-extract'. + (lambda (name) + (if (or (not (memq system-type '(windows-nt ms-dos))) + (and (boundp 'w32-quote-process-args) + (null w32-quote-process-args))) + (shell-quote-argument name) + name))) + (target (funcall --quote-file-name target)) + (archive (expand-file-name archive)) + (archive-zip-extract + (list "unzip" "-qq" "-o" "-d" target)) + exit-code command-output) + (setq command-output + (with-temp-buffer + (setq exit-code (archive-zip-extract archive member)) + (buffer-string))) + (unless (zerop exit-code) + (message command-output) + (error "Extraction failed")))) + members)) + +;;;; Textbox + +(defun org-e-odt--textbox (text width height style &optional + extra anchor-type) + (org-e-odt--frame + (format "\n%s\n" + (concat (format " fo:min-height=\"%0.2fcm\"" (or height .2)) + (and (not width) + (format " fo:min-width=\"%0.2fcm\"" (or width .2)))) + text) + width nil style extra anchor-type)) + + + +;;;; Table of Contents + +(defun org-e-odt-begin-toc (index-title depth) + (concat + (format " + + + %s +" depth index-title) + + (let ((levels (number-sequence 1 10))) + (mapconcat + (lambda (level) + (format + " + + + + + + +" level level)) levels "")) + + (format " + + + + + %s + + " index-title))) + +(defun org-e-odt-end-toc () + (format " + + +")) + + + +(defun* org-e-odt-format-toc-headline + (todo todo-type priority text tags + &key level section-number headline-label &allow-other-keys) + (setq text (concat + (and org-export-with-section-numbers + (concat section-number ". ")) + text + (and tags + (concat + "" + (format "%s" + "OrgTag" tags))))) + (when todo + (setq text (format "%s" + "OrgTodo" text))) + (org-e-odt-format-link text (concat "#" headline-label) t)) + +(defun org-e-odt-toc (depth info) + (assert (wholenump depth)) + (let* ((title (org-export-translate "Table of Contents" :utf-8 info)) + (headlines (org-export-collect-headlines info depth))) + + (when headlines + (concat + (org-e-odt-begin-toc title depth) + + (mapconcat + (lambda (headline) + (let* ((entry (org-e-odt-format-headline--wrap + headline info 'org-e-odt-format-toc-headline)) + (level (org-export-get-relative-level headline info)) + (style (format "Contents_20_%d" level))) + (format "\n%s" + style entry))) + headlines "\n") + + (org-e-odt-end-toc))))) + + +;;;; Document styles + +(defun org-e-odt-add-automatic-style (object-type &optional object-props) + "Create an automatic style of type OBJECT-TYPE with param OBJECT-PROPS. +OBJECT-PROPS is (typically) a plist created by passing +\"#+ATTR_ODT: \" option of the object in question to +`org-e-odt-parse-block-attributes'. + +Use `org-e-odt-object-counters' to generate an automatic +OBJECT-NAME and STYLE-NAME. If OBJECT-PROPS is non-nil, add a +new entry in `org-e-odt-automatic-styles'. Return (OBJECT-NAME +. STYLE-NAME)." + (assert (stringp object-type)) + (let* ((object (intern object-type)) + (seqvar object) + (seqno (1+ (or (plist-get org-e-odt-object-counters seqvar) 0))) + (object-name (format "%s%d" object-type seqno)) style-name) + (setq org-e-odt-object-counters + (plist-put org-e-odt-object-counters seqvar seqno)) + (when object-props + (setq style-name (format "Org%s" object-name)) + (setq org-e-odt-automatic-styles + (plist-put org-e-odt-automatic-styles object + (append (list (list style-name object-props)) + (plist-get org-e-odt-automatic-styles object))))) + (cons object-name style-name))) + + +;;;; Caption and Labels + + +(defun org-e-odt--wrap-label (element output) + "Wrap label associated to ELEMENT around OUTPUT, if appropriate. +This function shouldn't be used for floats. See +`org-e-odt--caption/label-string'." + ;; (let ((label (org-element-property :name element))) + ;; (if (or (not output) (not label) (string= output "") (string= label "")) + ;; output + ;; (concat (format "\\label{%s}\n" label) output))) + output) + + +(defun org-e-odt--caption/label-string (caption label info) + "Return caption and label HTML string for floats. + +CAPTION is a cons cell of secondary strings, the car being the +standard caption and the cdr its short form. LABEL is a string +representing the label. INFO is a plist holding contextual +information. + +If there's no caption nor label, return the empty string. + +For non-floats, see `org-e-odt--wrap-label'." + (setq label nil) ;; FIXME + + (let ((label-str (if label (format "\\label{%s}" label) ""))) + (cond + ((and (not caption) (not label)) "") + ((not caption) (format "\\label{%s}\n" label)) + ;; Option caption format with short name. + ((cdr caption) + (format "\\caption[%s]{%s%s}\n" + (org-export-data (cdr caption) info) + label-str + (org-export-data (car caption) info))) + ;; Standard caption format. + ;; (t (format "\\caption{%s%s}\n" + ;; label-str + ;; (org-export-data (car caption) info))) + (t (org-export-data (car caption) info))))) + +;;;; Checkbox + +(defun org-e-odt--checkbox (item) + "Return check-box string associated to ITEM." + (let ((checkbox (org-element-property :checkbox item))) + (if (not checkbox) "" + (format "%s" + "OrgCode" (case checkbox + (on "[✓] ") ; CHECK MARK + (off "[ ] ") + (trans "[-] ")))))) + + + +;;; Template + +(defun org-e-odt-template (contents info) + "Return complete document string after HTML conversion. +CONTENTS is the transcoded contents string. RAW-DATA is the +original parsed data. INFO is a plist holding export options." + ;; Write meta file. + (let ((title (org-export-data (plist-get info :title) info)) + (author (let ((author (plist-get info :author))) + (if (not author) "" (org-export-data author info)))) + (date (org-e-odt--date + (org-export-data (plist-get info :date) info))) + (email (plist-get info :email)) + (keywords (plist-get info :keywords)) + (description (plist-get info :description))) + (write-region + (concat + " + + \n" + (format "%s\n" author) + (format "%s\n" author) + (format "%s\n" date) + (format "%s\n" date) + (format "%s\n" + (let ((creator-info (plist-get info :with-creator))) + (if (or (not creator-info) (eq creator-info 'comment)) "" + (plist-get info :creator)))) + (format "%s\n" keywords) + (format "%s\n" description) + (format "%s\n" title) + "\n" + " \n" "") + nil (concat org-e-odt-zip-dir "meta.xml")) + ;; Add meta.xml in to manifest. + (org-e-odt-create-manifest-file-entry "text/xml" "meta.xml")) + + ;; Update styles file. + ;; Copy styles.xml. Also dump htmlfontify styles, if there is any. + ;; Write styles file. + (let* ((styles-file (plist-get info :odt-styles-file)) + (styles-file (and styles-file (read (org-trim styles-file)))) + ;; Non-availability of styles.xml is not a critical + ;; error. For now throw an error purely for aesthetic + ;; reasons. + (styles-file (or styles-file + org-e-odt-styles-file + (expand-file-name "OrgOdtStyles.xml" + org-e-odt-styles-dir) + (error "org-e-odt: Missing styles file?")))) + (cond + ((listp styles-file) + (let ((archive (nth 0 styles-file)) + (members (nth 1 styles-file))) + (org-e-odt--zip-extract archive members org-e-odt-zip-dir) + (mapc + (lambda (member) + (when (org-file-image-p member) + (let* ((image-type (file-name-extension member)) + (media-type (format "image/%s" image-type))) + (org-e-odt-create-manifest-file-entry media-type member)))) + members))) + ((and (stringp styles-file) (file-exists-p styles-file)) + (let ((styles-file-type (file-name-extension styles-file))) + (cond + ((string= styles-file-type "xml") + (copy-file styles-file (concat org-e-odt-zip-dir "styles.xml") t)) + ((member styles-file-type '("odt" "ott")) + (org-e-odt--zip-extract styles-file "styles.xml" org-e-odt-zip-dir))))) + (t + (error (format "Invalid specification of styles.xml file: %S" + org-e-odt-styles-file)))) + + ;; create a manifest entry for styles.xml + (org-e-odt-create-manifest-file-entry "text/xml" "styles.xml") + + ;; FIXME: Who is opening an empty styles.xml before this point? + (with-current-buffer + (find-file-noselect (concat org-e-odt-zip-dir "styles.xml") t) + (revert-buffer t t) + + ;; Write custom styles for source blocks + ;; Save STYLES used for colorizing of source blocks. + ;; Update styles.xml with styles that were collected as part of + ;; `org-e-odt-hfy-face-to-css' callbacks. + (let ((styles (mapconcat (lambda (style) (format " %s\n" (cddr style))) + hfy-user-sheet-assoc ""))) + (when styles + (goto-char (point-min)) + (when (re-search-forward "" nil t) + (goto-char (match-beginning 0)) + (insert "\n\n" styles "\n")))) + + ;; Update styles.xml - take care of outline numbering + + ;; Don't make automatic backup of styles.xml file. This setting + ;; prevents the backed-up styles.xml file from being zipped in to + ;; odt file. This is more of a hackish fix. Better alternative + ;; would be to fix the zip command so that the output odt file + ;; includes only the needed files and excludes any auto-generated + ;; extra files like backups and auto-saves etc etc. Note that + ;; currently the zip command zips up the entire temp directory so + ;; that any auto-generated files created under the hood ends up in + ;; the resulting odt file. + (set (make-local-variable 'backup-inhibited) t) + + ;; Outline numbering is retained only upto LEVEL. + ;; To disable outline numbering pass a LEVEL of 0. + + (goto-char (point-min)) + (let ((regex + "]*\\)text:level=\"\\([^\"]*\\)\"\\([^>]*\\)>") + (replacement + "")) + (while (re-search-forward regex nil t) + (unless (let ((sec-num (plist-get info :section-numbers)) + (level (string-to-number (match-string 2)))) + (if (wholenump sec-num) (<= level sec-num) sec-num)) + (replace-match replacement t nil)))) + (save-buffer 0))) + ;; Update content.xml. + (with-temp-buffer + (insert-file-contents + (or org-e-odt-content-template-file + (expand-file-name "OrgOdtContentTemplate.xml" + org-e-odt-styles-dir))) + ;; Write automatic styles. + ;; - Position the cursor. + (goto-char (point-min)) + (re-search-forward " " nil t) + (goto-char (match-beginning 0)) + ;; - Dump automatic table styles + (loop for (style-name props) in + (plist-get org-e-odt-automatic-styles 'Table) do + (when (setq props (or (plist-get props :rel-width) 96)) + (insert (format org-e-odt-table-style-format style-name props)))) + ;; Update display level. + ;; - Remove existing sequence decls. Also position the cursor. + (goto-char (point-min)) + (when (re-search-forward "" nil nil))) + ;; Update sequence decls according to user preference. + (insert + (format + "\n\n%s\n" + (mapconcat + (lambda (x) + (format + "" + org-e-odt-display-outline-level (nth 1 x))) + org-e-odt-category-map-alist "\n"))) + ;; Position the cursor to document body. + (goto-char (point-min)) + (re-search-forward "" nil nil) + (goto-char (match-beginning 0)) + + ;; Preamble - Title, Author, Date etc. + (insert + (let* ((title (org-export-data (plist-get info :title) info)) + (author (and (plist-get info :with-author) + (let ((auth (plist-get info :author))) + (and auth (org-export-data auth info))))) + (date (org-export-data (plist-get info :date) info)) + (iso-date (org-e-odt--date date)) + (date (org-e-odt--date date "%d %b %Y")) + (email (plist-get info :email)) + ;; switch on or off above vars based on user settings + (author (and (plist-get info :with-author) (or author email))) + ;; (date (and (plist-get info :time-stamp-file) date)) + (email (and (plist-get info :with-email) email))) + (concat + ;; title + (when title + (concat + (format "\n%s" + "OrgTitle" (format "\n%s" title)) + ;; separator + "\n")) + (cond + ((and author (not email)) + ;; author only + (concat + (format "\n%s" + "OrgSubtitle" + (format "%s" author)) + ;; separator + "\n")) + ((and author email) + ;; author and email + (concat + (format "\n%s" + "OrgSubtitle" + (org-e-odt-format-link + (format "%s" author) + (concat "mailto:" email))) + ;; separator + "\n"))) + ;; date + (when date + (concat + (format + "\n%s" + "OrgSubtitle" + (format + "\n%s" + + "N75" iso-date date)) + ;; separator + ""))))) + + ;; Table of Contents + (let ((depth (plist-get info :with-toc))) + (when (wholenump depth) (insert (org-e-odt-toc depth info)))) + ;; Contents. + (insert contents) + ;; Return contents. + (buffer-substring-no-properties (point-min) (point-max)))) + + + +;;; Transcode Functions + +;;;; Bold + +(defun org-e-odt-bold (bold contents info) + "Transcode BOLD from Org to ODT. +CONTENTS is the text with bold markup. INFO is a plist holding +contextual information." + (format "%s" + "Bold" contents)) + + +;;;; Center Block + +(defun org-e-odt-center-block (center-block contents info) + "Transcode a CENTER-BLOCK element from Org to ODT. +CONTENTS holds the contents of the center block. INFO is a plist +holding contextual information." + (org-e-odt--wrap-label center-block contents)) + + +;;;; Clock + +(defun org-e-odt-clock (clock contents info) + "Transcode a CLOCK element from Org to ODT. +CONTENTS is nil. INFO is a plist used as a communication +channel." + (format "%s" + "OrgTimestampWrapper" + (concat + (format "%s" + "OrgTimestampKeyword" org-clock-string) + (format "%s" + "OrgTimestamp" + (concat (org-translate-time + (org-element-property :value clock)) + (let ((time (org-element-property :time clock))) + (and time (format " (%s)" time)))))))) + + +;;;; Code + +(defun org-e-odt-code (code contents info) + "Transcode a CODE object from Org to ODT. +CONTENTS is nil. INFO is a plist used as a communication +channel." + (format "%s" + "OrgCode" (org-element-property :value code))) + + +;;;; Comment + +;; Comments are ignored. + + +;;;; Comment Block + +;; Comment Blocks are ignored. + + +;;;; Drawer + +(defun org-e-odt-drawer (drawer contents info) + "Transcode a DRAWER element from Org to ODT. +CONTENTS holds the contents of the block. INFO is a plist +holding contextual information." + (let* ((name (org-element-property :drawer-name drawer)) + (output (if (functionp org-e-odt-format-drawer-function) + (funcall org-e-odt-format-drawer-function + name contents) + ;; If there's no user defined function: simply + ;; display contents of the drawer. + contents))) + (org-e-odt--wrap-label drawer output))) + + +;;;; Dynamic Block + +(defun org-e-odt-dynamic-block (dynamic-block contents info) + "Transcode a DYNAMIC-BLOCK element from Org to ODT. +CONTENTS holds the contents of the block. INFO is a plist +holding contextual information. See `org-export-data'." + (org-e-odt--wrap-label dynamic-block contents)) + + +;;;; Entity + +(defun org-e-odt-entity (entity contents info) + "Transcode an ENTITY object from Org to ODT. +CONTENTS are the definition itself. INFO is a plist holding +contextual information." + ;; (let ((ent (org-element-property :latex entity))) + ;; (if (org-element-property :latex-math-p entity) + ;; (format "$%s$" ent) + ;; ent)) + (org-element-property :utf-8 entity)) + + +;;;; Example Block + +(defun org-e-odt-example-block (example-block contents info) + "Transcode a EXAMPLE-BLOCK element from Org to ODT. +CONTENTS is nil. INFO is a plist holding contextual information." + (org-e-odt--wrap-label + example-block (org-e-odt-format-code example-block info))) + + +;;;; Export Snippet + +(defun org-e-odt-export-snippet (export-snippet contents info) + "Transcode a EXPORT-SNIPPET object from Org to ODT. +CONTENTS is nil. INFO is a plist holding contextual information." + (when (eq (org-export-snippet-backend export-snippet) 'e-odt) + (org-element-property :value export-snippet))) + + +;;;; Export Block + +(defun org-e-odt-export-block (export-block contents info) + "Transcode a EXPORT-BLOCK element from Org to ODT. +CONTENTS is nil. INFO is a plist holding contextual information." + (when (string= (org-element-property :type export-block) "ODT") + (org-remove-indentation (org-element-property :value export-block)))) + + +;;;; Fixed Width + +(defun org-e-odt-fixed-width (fixed-width contents info) + "Transcode a FIXED-WIDTH element from Org to ODT. +CONTENTS is nil. INFO is a plist holding contextual information." + (org-e-odt--wrap-label + fixed-width (org-e-odt-do-format-code + (org-element-property :value fixed-width)))) + + +;;;; Footnote Definition + +;; Footnote Definitions are ignored. + + +;;;; Footnote Reference + +(defun org-e-odt-footnote-reference (footnote-reference contents info) + "Transcode a FOOTNOTE-REFERENCE element from Org to ODT. +CONTENTS is nil. INFO is a plist holding contextual information." + (let ((--format-footnote-definition + (function + (lambda (n def) + (setq n (format "%d" n)) + (let ((id (concat "fn" n)) + (note-class "footnote") + (par-style "Footnote")) + (format + "%s" + id note-class + (concat + (format "%s" n) + (format "%s" def))))))) + (--format-footnote-reference + (function + (lambda (n) + (setq n (format "%d" n)) + (let ((note-class "footnote") + (ref-format "text") + (ref-name (concat "fn" n))) + (format + "%s" + "OrgSuperscript" + (format "%s" + note-class ref-format ref-name n))))))) + (concat + ;; Insert separator between two footnotes in a row. + (let ((prev (org-export-get-previous-element footnote-reference info))) + (and (eq (org-element-type prev) 'footnote-reference) + (format "%s" + "OrgSuperscript" ","))) + ;; Trancode footnote reference. + (let ((n (org-export-get-footnote-number footnote-reference info))) + (cond + ((not (org-export-footnote-first-reference-p footnote-reference info)) + (funcall --format-footnote-reference n)) + ;; Inline definitions are secondary strings. + ;; Non-inline footnotes definitions are full Org data. + (t + (let* ((raw (org-export-get-footnote-definition footnote-reference + info)) + (def (let ((def (org-trim (org-export-data raw info)))) + (if (eq (org-element-type raw) 'org-data) def + (format "\n%s" + "Footnote" def))))) + (funcall --format-footnote-definition n def)))))))) + + +;;;; Headline + +(defun* org-e-odt-format-headline + (todo todo-type priority text tags + &key level section-number headline-label &allow-other-keys) + (concat + ;; Todo. + (and todo + (concat + (let ((style (if (member todo org-done-keywords) "OrgDone" "OrgTodo"))) + (format "%s" + style todo)) " ")) + ;; Title. + text + ;; Tags. + (and tags + (concat "" + (format "%s" + "OrgTag" (mapconcat 'org-trim tags " : ")))))) + +(defun org-e-odt-format-headline--wrap (headline info + &optional format-function + &rest extra-keys) + "Transcode an HEADLINE element from Org to ODT. +CONTENTS holds the contents of the headline. INFO is a plist +holding contextual information." + (let* ((level (+ (org-export-get-relative-level headline info))) + (headline-number (org-export-get-headline-number headline info)) + (section-number (and (org-export-numbered-headline-p headline info) + (mapconcat 'number-to-string + headline-number "."))) + (todo (and (plist-get info :with-todo-keywords) + (let ((todo (org-element-property :todo-keyword headline))) + (and todo (org-export-data todo info))))) + (todo-type (and todo (org-element-property :todo-type headline))) + (priority (and (plist-get info :with-priority) + (org-element-property :priority headline))) + (text (org-export-data (org-element-property :title headline) info)) + (tags (and (plist-get info :with-tags) + (org-export-get-tags headline info))) + (headline-label (concat "sec-" (mapconcat 'number-to-string + headline-number "-"))) + (format-function (cond + ((functionp format-function) format-function) + ((functionp org-e-odt-format-headline-function) + (function* + (lambda (todo todo-type priority text tags + &allow-other-keys) + (funcall org-e-odt-format-headline-function + todo todo-type priority text tags)))) + (t 'org-e-odt-format-headline)))) + (apply format-function + todo todo-type priority text tags + :headline-label headline-label :level level + :section-number section-number extra-keys))) + + +(defun org-e-odt-begin-plain-list (ltype &optional continue-numbering) + (unless (member ltype '(ordered unordered descriptive)) + (error "Unknown list type: %s" ltype)) + (let ((style-name (assoc-default ltype + '((ordered . "OrgNumberedList") + (unordered . "OrgBulletedList") + (descriptive . "OrgDescriptionList"))))) + (format "" + style-name (if continue-numbering "true" "false")))) + +(defun org-e-odt-headline (headline contents info) + "Transcode an HEADLINE element from Org to ODT. +CONTENTS holds the contents of the headline. INFO is a plist +holding contextual information." + (let* ((numberedp (org-export-numbered-headline-p headline info)) + ;; Get level relative to current parsed data. + (level (org-export-get-relative-level headline info)) + (text (org-export-data (org-element-property :title headline) info)) + ;; Create the headline text. + (full-text (org-e-odt-format-headline--wrap headline info))) + (cond + ;; Case 1: This is a footnote section: ignore it. + ((org-element-property :footnote-section-p headline) nil) + ;; Case 2. This is a deep sub-tree: export it as a list item. + ;; Also export as items headlines for which no section + ;; format has been found. + ;; FIXME + ;; ((org-export-low-level-p headline info) + ;; ;; Build the real contents of the sub-tree. + ;; (let* ((type (if numberedp 'unordered 'unordered)) ; FIXME + ;; (itemized-body (org-e-odt-format-list-item + ;; contents type nil nil full-text))) + ;; (concat + ;; (and (org-export-first-sibling-p headline info) + ;; (org-e-odt-begin-plain-list type)) + ;; itemized-body + ;; (and (org-export-last-sibling-p headline info) + ;; "")))) + ;; Case 3. Standard headline. Export it as a section. + (t + (let* ((extra-ids (list (org-element-property :custom-id headline) + (org-element-property :id headline))) + (extra-ids nil) ; FIXME + (id (concat "sec-" (mapconcat 'number-to-string + (org-export-get-headline-number + headline info) "-")))) + (concat + (format + "\n%s%s" + (format "Heading_20_%s" level) + level + ;; Extra targets. + (mapconcat (lambda (x) + (when x + (let ((x (if (org-uuidgen-p x) (concat "ID-" x) x))) + (org-e-odt-format-target + "" (org-export-solidify-link-text x))))) + extra-ids "") + ;; Title. + (org-e-odt-format-target full-text id)) + contents)))))) + + +;;;; Horizontal Rule + +(defun org-e-odt-horizontal-rule (horizontal-rule contents info) + "Transcode an HORIZONTAL-RULE object from Org to ODT. +CONTENTS is nil. INFO is a plist holding contextual information." + (org-e-odt--wrap-label + horizontal-rule + (format "\n%s" + "Horizontal_20_Line" ""))) + + +;;;; Inline Babel Call + +;; Inline Babel Calls are ignored. + + +;;;; Inline Src Block + +(defun org-e-odt--find-verb-separator (s) + "Return a character not used in string S. +This is used to choose a separator for constructs like \\verb." + (let ((ll "~,./?;':\"|!@#%^&-_=+abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ<>()[]{}")) + (loop for c across ll + when (not (string-match (regexp-quote (char-to-string c)) s)) + return (char-to-string c)))) + +(defun org-e-odt-inline-src-block (inline-src-block contents info) + "Transcode an INLINE-SRC-BLOCK element from Org to ODT. +CONTENTS holds the contents of the item. INFO is a plist holding +contextual information." + (let* ((org-lang (org-element-property :language inline-src-block)) + (code (org-element-property :value inline-src-block)) + (separator (org-e-odt--find-verb-separator code))) + (error "FIXME"))) + + +;;;; Inlinetask + +(defun org-e-odt-inlinetask (inlinetask contents info) + "Transcode an INLINETASK element from Org to ODT. +CONTENTS holds the contents of the block. INFO is a plist +holding contextual information." + (cond + ;; If `org-e-odt-format-inlinetask-function' is provided, call it + ;; with appropriate arguments. + ((functionp org-e-odt-format-inlinetask-function) + (let ((format-function + (function* + (lambda (todo todo-type priority text tags + &key contents &allow-other-keys) + (funcall org-e-odt-format-inlinetask-function + todo todo-type priority text tags contents))))) + (org-e-odt-format-headline--wrap + inlinetask info format-function :contents contents))) + ;; Otherwise, use a default template. + (t (org-e-odt--wrap-label + inlinetask + (format "\n%s" + "Text_20_body" + (org-e-odt--textbox + (concat + (format "\n%s" + "OrgInlineTaskHeading" + (org-e-odt-format-headline--wrap + inlinetask info)) + contents) + nil nil "OrgInlineTaskFrame" " style:rel-width=\"100%\"")))))) + +;;;; Italic + +(defun org-e-odt-italic (italic contents info) + "Transcode ITALIC from Org to ODT. +CONTENTS is the text with italic markup. INFO is a plist holding +contextual information." + (format "%s" + "Emphasis" contents)) + + +;;;; Item + +(defun org-e-odt-item (item contents info) + "Transcode an ITEM element from Org to ODT. +CONTENTS holds the contents of the item. INFO is a plist holding +contextual information." + (let* ((plain-list (org-export-get-parent item)) + (type (org-element-property :type plain-list)) + (counter (org-element-property :counter item)) + (tag (let ((tag (org-element-property :tag item))) + (and tag + (concat (org-e-odt--checkbox item) + (org-export-data tag info)))))) + (case type + ((ordered unordered) + (format "\n\n%s\n%s" + contents + (let* ((--element-has-a-table-p + (function + (lambda (element info) + (loop for el in (org-element-contents element) + thereis (eq (org-element-type el) 'table)))))) + (cond + ((funcall --element-has-a-table-p item info) + "") + (t ""))))) + (descriptive + (concat + (let ((term (or tag "(no term)"))) + (concat + (format "\n\n%s\n" + (format "\n%s" + "Text_20_body_20_bold" term)) + (format + "\n\n%s\n" + (format "\n\n%s\n" + "OrgDescriptionList" + "text:continue-numbering=\"false\"" + (format "\n\n%s\n" + contents))))))) + (t (error "Unknown list type: %S" type))))) + + +;;;; Keyword + +(defun org-e-odt-keyword (keyword contents info) + "Transcode a KEYWORD element from Org to ODT. +CONTENTS is nil. INFO is a plist holding contextual information." + (let ((key (org-element-property :key keyword)) + (value (org-element-property :value keyword))) + (cond + ((string= key "LATEX") value) + ((string= key "INDEX") (format "\\index{%s}" value)) + ((string= key "TARGET") nil ; FIXME + ;; (format "\\label{%s}" (org-export-solidify-link-text value)) + ) + ((string= key "toc") + (let ((value (downcase value))) + (cond + ((string-match "\\" value) + (let ((depth (or (and (string-match "[0-9]+" value) + (string-to-number (match-string 0 value))) + (plist-get info :with-toc)))) + (when (wholenump depth) (org-e-odt-toc depth info)))) + ((string= "tables" value) "FIXME") + ((string= "figures" value) "FIXME") + ((string= "listings" value) + (cond + ;; At the moment, src blocks with a caption are wrapped + ;; into a figure environment. + (t "FIXME"))))))))) + + +;;;; Latex Environment + + +(eval-after-load 'org-odt + '(ad-deactivate 'org-format-latex-as-mathml)) + +;; (defadvice org-format-latex-as-mathml ; FIXME +;; (after org-e-odt-protect-latex-fragment activate) +;; "Encode LaTeX fragment as XML. +;; Do this when translation to MathML fails." +;; (when (or (not (> (length ad-return-value) 0)) +;; (get-text-property 0 'org-protected ad-return-value)) +;; (setq ad-return-value +;; (org-propertize (org-e-odt-encode-plain-text (ad-get-arg 0)) +;; 'org-protected t)))) + +(defun org-e-odt-format-latex (latex-frag processing-type info) + (let* ((prefix (case processing-type + (dvipng "ltxpng/") + (mathml "ltxmathml/"))) + (input-file (plist-get info :input-file)) + (cache-subdir + (concat prefix (file-name-sans-extension + (file-name-nondirectory input-file)))) + (cache-dir (file-name-directory input-file)) + (display-msg (case processing-type + (dvipng "Creating LaTeX Image...") + (mathml "Creating MathML snippet...")))) + (with-temp-buffer + (insert latex-frag) + (org-format-latex cache-subdir cache-dir nil display-msg + nil nil processing-type) + (buffer-string)))) + +(defun org-e-odt-latex-environment (latex-environment contents info) + "Transcode a LATEX-ENVIRONMENT element from Org to ODT. +CONTENTS is nil. INFO is a plist holding contextual information." + (org-e-odt--wrap-label + latex-environment + (let* ((latex-frag + (org-remove-indentation + (org-element-property :value latex-environment))) + (processing-type (plist-get info :LaTeX-fragments)) + (caption (org-element-property :caption latex-environment)) + (short-caption (and (cdr caption) + (org-export-data (cdr caption) info))) + (caption (and (car caption) (org-export-data (car caption) info))) + (label (org-element-property :name latex-environment)) + (attr nil) ; FIXME + (label (org-element-property :name latex-environment))) + + (when (memq processing-type '(t mathjax)) + (unless (and (fboundp 'org-format-latex-mathml-available-p) + (org-format-latex-mathml-available-p)) + (message "LaTeX to MathML converter not available. Trying dvinpng...") + (setq processing-type 'dvipng))) + + (when (eq processing-type 'dvipng) + (unless (and (org-check-external-command "latex" "" t) + (org-check-external-command "dvipng" "" t)) + (message "LaTeX to PNG converter not available. Using verbatim.") + (setq processing-type 'verbatim))) + + (case processing-type + ((t mathjax) + (org-e-odt-format-formula latex-environment info)) + (dvipng + (format "\n%s" + "Text_20_body" + (org-e-odt-link--inline-image latex-environment info))) + (t (org-e-odt-do-format-code latex-frag)))))) + + +;;;; Latex Fragment + + +;; (when latex-frag ; FIXME +;; (setq href (org-propertize href :title "LaTeX Fragment" +;; :description latex-frag))) +;; handle verbatim +;; provide descriptions + +(defun org-e-odt-latex-fragment (latex-fragment contents info) + "Transcode a LATEX-FRAGMENT object from Org to ODT. +CONTENTS is nil. INFO is a plist holding contextual information." + (let* ((latex-frag (org-element-property :value latex-fragment)) + (processing-type (plist-get info :LaTeX-fragments))) + (cond + ((member processing-type '(t mathjax)) + (org-e-odt-format-formula latex-fragment info)) + ((eq processing-type 'dvipng) + (org-e-odt-link--inline-image latex-fragment info)) + (t (org-e-odt-encode-plain-text latex-frag t))))) + + +;;;; Line Break + +(defun org-e-odt-line-break (line-break contents info) + "Transcode a LINE-BREAK object from Org to ODT. +CONTENTS is nil. INFO is a plist holding contextual information." + "\n") + + +;;;; Link + + + +;;;; Links :: Generic + +(defun org-e-odt-format-link (desc href &optional suppress-xref) + (cond + ((and (= (string-to-char href) ?#) (not suppress-xref)) + (setq href (substring href 1)) + (let ((xref-format "text")) + (when (numberp desc) + (setq desc (format "%d" desc) xref-format "number")) + (when (listp desc) + (setq desc (mapconcat 'number-to-string desc ".") xref-format "chapter")) + (setq href (concat org-e-odt-bookmark-prefix href)) + (format + "%s" + xref-format href desc))) + ;; (org-lparse-link-description-is-image + ;; (format "\n\n%s\n" + ;; href desc)) + (t (format "%s" + href desc)))) + +(defun org-e-odt-format-internal-link (text href) + (org-e-odt-format-link text (concat "#" href))) + +;;;; Links :: Label references + +(defun org-e-odt-enumerate-element (element info &optional predicate n) + (let* ((--numbered-parent-headline-at-<=-n + (function + (lambda (element n info) + (loop for x in (org-export-get-genealogy element) + thereis (and (eq (org-element-type x) 'headline) + (<= (org-export-get-relative-level x info) n) + (org-export-numbered-headline-p x info) + x))))) + (--enumerate + (function + (lambda (element scope info &optional predicate) + (let ((counter 0)) + (org-element-map + (or scope (plist-get info :parse-tree)) + (org-element-type element) + (lambda (el) + (and (or (not predicate) (funcall predicate el info)) + (incf counter) + (eq element el) + counter)) + info 'first-match))))) + (scope (funcall --numbered-parent-headline-at-<=-n + element (or n org-e-odt-display-outline-level) info)) + (ordinal (funcall --enumerate element scope info predicate)) + (tag + (concat + ;; Section number. + (and scope + (mapconcat 'number-to-string + (org-export-get-headline-number scope info) ".")) + ;; Separator. + (and scope ".") + ;; Ordinal. + (number-to-string ordinal)))) + tag)) + +(defun org-e-odt-format-label (element info op) + (let* ((caption-from + (case (org-element-type element) + (link (org-export-get-parent-element element)) + (t element))) + ;; get label and caption. + (label (org-element-property :name caption-from)) + (caption (org-element-property :caption caption-from)) + (short-caption (cdr caption)) + ;; transcode captions. + (caption (and (car caption) (org-export-data (car caption) info))) + (short-caption (and short-caption + (org-export-data short-caption info)))) + (when (or label caption) + (let* ((default-category + (cond + ((eq (org-element-type element) 'table) + "__Table__") + ((org-e-odt-standalone-image-p element info) + "__Figure__") + ((member (org-element-type element) + '(latex-environment latex-fragment)) + (let ((processing-type (plist-get info :LaTeX-fragments))) + (cond + ((eq processing-type 'dvipng) "__DvipngImage__") + ((eq processing-type 'mathjax) "__MathFormula__") + ((eq processing-type 't) "__MathFormula__") + (t (error "Handle LaTeX:verbatim"))))) + ((eq (org-element-type element) 'src-block) + "__Listing__") + (t (error "Handle enumeration of %S" element)))) + (predicate + (cond + ((member (org-element-type element) + '(table latex-environment src-block)) + nil) + ((org-e-odt-standalone-image-p element info) + 'org-e-odt-standalone-image-p) + (t (error "Handle enumeration of %S" element)))) + (seqno (org-e-odt-enumerate-element + element info predicate)) ; FIXME + ;; handle label props. + (label-props (assoc default-category org-e-odt-category-map-alist)) + ;; identify opendocument counter + (counter (nth 1 label-props)) + ;; identify label style + (label-style (nth 2 label-props)) + ;; retrieve localized category sting + (category (org-export-translate (nth 3 label-props) :utf-8 info))) + (case op + (definition + ;; assign an internal label, if user has not provided one + (setq label (or label (format "%s-%s" default-category seqno))) + (setq label (org-export-solidify-link-text label)) + + (cons + (format-spec + (cadr (assoc-string label-style org-e-odt-label-styles t)) + `((?e . ,category) + (?n . ,(format + "%s" + label counter counter seqno)) + (?c . ,(or caption "")))) + short-caption)) + (reference + (assert label) + (setq label (org-export-solidify-link-text label)) + (let* ((fmt (cddr (assoc-string label-style org-e-odt-label-styles t))) + (fmt1 (car fmt)) + (fmt2 (cadr fmt))) + (format "%s" + fmt1 label (format-spec fmt2 `((?e . ,category) + (?n . ,seqno)))))) + (t (error "Unknow %S on label" op))))))) + +;;;; Links :: Embedded images + +(defun org-e-odt-copy-image-file (path) + "Returns the internal name of the file" + (let* ((image-type (file-name-extension path)) + (media-type (format "image/%s" image-type)) + (target-dir "Images/") + (target-file + (format "%s%04d.%s" target-dir + (incf org-e-odt-embedded-images-count) image-type))) + (message "Embedding %s as %s ..." + (substring-no-properties path) target-file) + + (when (= 1 org-e-odt-embedded-images-count) + (make-directory (concat org-e-odt-zip-dir target-dir)) + (org-e-odt-create-manifest-file-entry "" target-dir)) + + (copy-file path (concat org-e-odt-zip-dir target-file) 'overwrite) + (org-e-odt-create-manifest-file-entry media-type target-file) + target-file)) + +(defun org-e-odt-image-size-from-file (file &optional user-width + user-height scale dpi embed-as) + (let* ((--pixels-to-cms + (function (lambda (pixels dpi) + (let ((cms-per-inch 2.54) + (inches (/ pixels dpi))) + (* cms-per-inch inches))))) + (--size-in-cms + (function + (lambda (size-in-pixels dpi) + (and size-in-pixels + (cons (funcall --pixels-to-cms (car size-in-pixels) dpi) + (funcall --pixels-to-cms (cdr size-in-pixels) dpi)))))) + (dpi (or dpi org-e-odt-pixels-per-inch)) + (anchor-type (or embed-as "paragraph")) + (user-width (and (not scale) user-width)) + (user-height (and (not scale) user-height)) + (size + (and + (not (and user-height user-width)) + (or + ;; Use Imagemagick. + (and (executable-find "identify") + (let ((size-in-pixels + (let ((dim (shell-command-to-string + (format "identify -format \"%%w:%%h\" \"%s\"" + file)))) + (when (string-match "\\([0-9]+\\):\\([0-9]+\\)" dim) + (cons (string-to-number (match-string 1 dim)) + (string-to-number (match-string 2 dim))))))) + (funcall --size-in-cms size-in-pixels dpi))) + ;; Use Emacs. + (let ((size-in-pixels + (ignore-errors ; Emacs could be in batch mode + (clear-image-cache) + (image-size (create-image file) 'pixels)))) + (funcall --size-in-cms size-in-pixels dpi)) + ;; Use hard-coded values. + (cdr (assoc-string anchor-type + org-e-odt-default-image-sizes-alist)) + ;; Error out. + (error "Cannot determine image size, aborting")))) + (width (car size)) (height (cdr size))) + (cond + (scale + (setq width (* width scale) height (* height scale))) + ((and user-height user-width) + (setq width user-width height user-height)) + (user-height + (setq width (* user-height (/ width height)) height user-height)) + (user-width + (setq height (* user-width (/ height width)) width user-width)) + (t (ignore))) + ;; ensure that an embedded image fits comfortably within a page + (let ((max-width (car org-e-odt-max-image-size)) + (max-height (cdr org-e-odt-max-image-size))) + (when (or (> width max-width) (> height max-height)) + (let* ((scale1 (/ max-width width)) + (scale2 (/ max-height height)) + (scale (min scale1 scale2))) + (setq width (* scale width) height (* scale height))))) + (cons width height))) + +;;;; Links :: Math formula + +(defun org-e-odt-format-formula (element info) + (let* ((src (cond + ((eq (org-element-type element) 'link) ; FIXME + (let* ((type (org-element-property :type element)) + (raw-path (org-element-property :path element))) + (cond + ((file-name-absolute-p raw-path) + (expand-file-name raw-path)) + (t raw-path)))) + ((member (org-element-type element) + '(latex-fragment latex-environment)) + (let* ((latex-frag (org-remove-indentation + (org-element-property :value element))) + (formula-link (org-e-odt-format-latex + latex-frag 'mathml info))) + (and formula-link + (string-match "file:\\([^]]*\\)" formula-link) + (match-string 1 formula-link)))) + (t (error "what is this?")))) + (full-src (if (file-name-absolute-p src) src + (expand-file-name src (file-name-directory + (plist-get info :input-file))))) + (caption-from + (case (org-element-type element) + (link (org-export-get-parent-element element)) + (t element))) + (captions (org-e-odt-format-label caption-from info 'definition)) + (caption (car captions)) + (href + (format "\n" + " xlink:show=\"embed\" xlink:actuate=\"onLoad\"" + (file-name-directory (org-e-odt-copy-formula-file full-src)))) + (embed-as (if caption 'paragraph 'character)) + width height) + (cond + ((eq embed-as 'character) + (org-e-odt-format-entity "InlineFormula" href width height)) + (t + (let* ((equation (org-e-odt-format-entity + "CaptionedDisplayFormula" href width height captions)) + (label + (let* ((org-e-odt-category-map-alist + '(("__Table__" "Table" "value") + ("__Figure__" "Illustration" "value") + ("__MathFormula__" "Text" "math-label") + ("__DvipngImage__" "Equation" "value") + ("__Listing__" "Listing" "value")))) + (car (org-e-odt-format-label caption-from info 'definition)))) + (formula-tree + (org-e-odt--adopt-elements + `(table (:type org :attr_odt (":style \"OrgEquation\""))) + (org-e-odt--adopt-elements + `(table-row (:type standard)) + `(table-cell nil "") `(table-cell nil "")) + (org-e-odt--adopt-elements + `(table-row (:type standard)) + (org-e-odt--adopt-elements + `(table-cell nil) `(export-block + (:type "ODT" :value ,equation))) + (org-e-odt--adopt-elements + `(table-cell nil) `(export-block + (:type "ODT" :value ,label)))))) + (formula-info + (org-export-collect-tree-properties + formula-tree (org-export-get-environment 'e-odt)))) + (org-export-data formula-tree formula-info)))))) + +(defun org-e-odt-copy-formula-file (src-file) + "Returns the internal name of the file" + (let* ((target-dir (format "Formula-%04d/" + (incf org-e-odt-embedded-formulas-count))) + (target-file (concat target-dir "content.xml"))) + ;; Create a directory for holding formula file. Also enter it in + ;; to manifest. + (make-directory (concat org-e-odt-zip-dir target-dir)) + (org-e-odt-create-manifest-file-entry + "application/vnd.oasis.opendocument.formula" target-dir "1.2") + ;; Copy over the formula file from user directory to zip + ;; directory. + (message "Embedding %s as %s ..." src-file target-file) + (let ((case-fold-search nil)) + (cond + ;; Case 1: Mathml. + ((string-match "\\.\\(mathml\\|mml\\)\\'" src-file) + (copy-file src-file (concat org-e-odt-zip-dir target-file) 'overwrite)) + ;; Case 2: OpenDocument formula. + ((string-match "\\.odf\\'" src-file) + (org-e-odt--zip-extract src-file "content.xml" + (concat org-e-odt-zip-dir target-dir))) + (t (error "%s is not a formula file" src-file)))) + ;; Enter the formula file in to manifest. + (org-e-odt-create-manifest-file-entry "text/xml" target-file) + target-file)) + +;;;; Targets + +(defun org-e-odt-format-target (text id) + (let ((name (concat org-e-odt-bookmark-prefix id))) + (concat + (and id (format "\n" name)) + (concat (and id (format "\n" id)) text) + (and id (format "\n" name))))) + +(defun org-e-odt-link--inline-image (element info) + "Return HTML code for an inline image. +LINK is the link pointing to the inline image. INFO is a plist +used as a communication channel." + (let* ((src (cond + ((eq (org-element-type element) 'link) + (let* ((type (org-element-property :type element)) + (raw-path (org-element-property :path element))) + (cond ((member type '("http" "https")) + (concat type ":" raw-path)) + ((file-name-absolute-p raw-path) + (expand-file-name raw-path)) + (t raw-path)))) + ((member (org-element-type element) + '(latex-fragment latex-environment)) + (let* ((latex-frag (org-remove-indentation + (org-element-property :value element))) + (formula-link (org-e-odt-format-latex + latex-frag 'dvipng info))) + (and formula-link + (string-match "file:\\([^]]*\\)" formula-link) + (match-string 1 formula-link)))) + (t (error "what is this?")))) + (src-expanded (if (file-name-absolute-p src) src + (expand-file-name src (file-name-directory + (plist-get info :input-file))))) + (href (format + "\n" + (org-e-odt-copy-image-file src-expanded))) + ;; extract attributes from #+ATTR_ODT line. + (attr-from (case (org-element-type element) + (link (org-export-get-parent-element element)) + (t element))) + ;; convert attributes to a plist. + (attr-plist (org-export-read-attribute :attr_odt attr-from)) + ;; handle `:anchor', `:style' and `:attributes' properties. + (user-frame-anchor + (car (assoc-string (plist-get attr-plist :anchor) + '(("as-char") ("paragraph") ("page")) t))) + (user-frame-style + (and user-frame-anchor (plist-get attr-plist :style))) + (user-frame-attrs + (and user-frame-anchor (plist-get attr-plist :attributes))) + (user-frame-params + (list user-frame-style user-frame-attrs user-frame-anchor)) + ;; (embed-as (or embed-as user-frame-anchor "paragraph")) + ;; extrac + ;; handle `:width', `:height' and `:scale' properties. + (size (org-e-odt-image-size-from-file + src-expanded (plist-get attr-plist :width) + (plist-get attr-plist :height) + (plist-get attr-plist :scale) nil ;; embed-as + "paragraph" ; FIXME + )) + (width (car size)) (height (cdr size)) + (embed-as + (case (org-element-type element) + ((org-e-odt-standalone-image-p element info) "paragraph") + (latex-fragment "as-char") + (latex-environment "paragraph") + (t "paragraph"))) + (captions (org-e-odt-format-label element info 'definition)) + (caption (car captions)) (short-caption (cdr captions)) + (entity (concat (and caption "Captioned") embed-as "Image"))) + (org-e-odt-format-entity entity href width height + captions user-frame-params ))) + +(defun org-e-odt-format-entity (entity href width height &optional + captions user-frame-params) + (let* ((caption (car captions)) (short-caption (cdr captions)) + (entity-style (assoc-string entity org-e-odt-entity-frame-styles t)) + default-frame-params frame-params + (--merge-frame-params + (function + (lambda (default-frame-params user-frame-params) + (if (not user-frame-params) default-frame-params + (assert (= (length default-frame-params) 3)) + (assert (= (length user-frame-params) 3)) + (loop for user-frame-param in user-frame-params + for default-frame-param in default-frame-params + collect (or user-frame-param default-frame-param))))))) + (cond + ((not caption) + (setq default-frame-params (nth 2 entity-style)) + (setq frame-params (funcall --merge-frame-params + default-frame-params user-frame-params)) + (apply 'org-e-odt--frame href width height frame-params)) + (t + (setq default-frame-params (nth 3 entity-style)) + (setq frame-params (funcall --merge-frame-params + default-frame-params user-frame-params)) + (apply 'org-e-odt--textbox + (format "\n%s" + "Illustration" + (concat + (apply 'org-e-odt--frame href width height + (let ((entity-style-1 (copy-sequence + (nth 2 entity-style)))) + (setcar (cdr entity-style-1) + (concat + (cadr entity-style-1) + (and short-caption + (format " draw:name=\"%s\" " + short-caption)))) + entity-style-1)) + caption)) + width height frame-params))))) + +(defun org-e-odt-standalone-image-p (element info) + "Test if ELEMENT is a standalone image for the purpose ODT export. +INFO is a plist holding contextual information. + +Return non-nil, if ELEMENT is of type paragraph and it's sole +content, save for whitespaces, is a link that qualifies as an +inline image. + +Return non-nil, if ELEMENT is of type link and it's containing +paragraph has no other content save for leading and trailing +whitespaces. + +Return nil, otherwise. + +Bind `org-e-odt-standalone-image-predicate' to constrain +paragraph further. For example, to check for only captioned +standalone images, do the following. + + \(setq org-e-odt-standalone-image-predicate + \(lambda \(paragraph\) + \(org-element-property :caption paragraph\)\)\) +" + (let ((--standalone-image-predicate + (function (lambda (paragraph) + (or (org-element-property :caption paragraph) + (org-element-property :name paragraph))))) + (paragraph (case (org-element-type element) + (paragraph element) + (link (and (org-export-inline-image-p + element org-e-odt-inline-image-rules) + (org-export-get-parent element))) + (t nil)))) + (when paragraph + (assert (eq (org-element-type paragraph) 'paragraph)) + (when (funcall --standalone-image-predicate paragraph) + (let ((contents (org-element-contents paragraph))) + (loop for x in contents + with inline-image-count = 0 + always (cond + ((eq (org-element-type x) 'plain-text) + (not (org-string-nw-p x))) + ((eq (org-element-type x) 'link) + (when (org-export-inline-image-p + x org-e-odt-inline-image-rules) + (= (incf inline-image-count) 1))) + (t nil)))))))) + +(defun org-e-odt-link (link desc info) + "Transcode a LINK object from Org to ODT. + +DESC is the description part of the link, or the empty string. +INFO is a plist holding contextual information. See +`org-export-data'." + (let* ((type (org-element-property :type link)) + (raw-path (org-element-property :path link)) + ;; Ensure DESC really exists, or set it to nil. + (desc (and (not (string= desc "")) desc)) + (imagep (org-export-inline-image-p + link org-e-odt-inline-image-rules)) + (path (cond + ((member type '("http" "https" "ftp" "mailto")) + (concat type ":" raw-path)) + ((string= type "file") + (when (string-match "\\(.+\\)::.+" raw-path) + (setq raw-path (match-string 1 raw-path))) + (if (file-name-absolute-p raw-path) + (concat "file://" (expand-file-name raw-path)) + (concat "file://" raw-path))) + (t raw-path))) + protocol) + (cond + ;; Image file. + ((and (not desc) (org-export-inline-image-p + link org-e-odt-inline-image-rules)) + (org-e-odt-link--inline-image link info)) + ;; Radio target: Transcode target's contents and use them as + ;; link's description. + ((string= type "radio") + (let ((destination (org-export-resolve-radio-link link info))) + (when destination + (org-e-odt-format-internal-link + (org-export-data (org-element-contents destination) info) + (org-export-solidify-link-text path))))) + ;; Links pointing to an headline: Find destination and build + ;; appropriate referencing command. + ((member type '("custom-id" "fuzzy" "id")) + (let ((destination (if (string= type "fuzzy") + (org-export-resolve-fuzzy-link link info) + (org-export-resolve-id-link link info)))) + (case (org-element-type destination) + ;; Fuzzy link points nowhere. + ('nil + (format "%s" + "Emphasis" (or desc (org-export-data + (org-element-property + :raw-link link) info)))) + ;; Fuzzy link points to an invisible target. + (keyword nil) + ;; LINK points to an headline. Check if LINK should display + ;; section numbers. + (headline + (let* ((headline-no (org-export-get-headline-number destination info)) + (label (format "sec-%s" (mapconcat 'number-to-string + headline-no "-"))) + (desc + ;; Case 1: Headline is numbered and LINK has no + ;; description or LINK's description matches + ;; headline's title. Display section number. + (if (and (org-export-numbered-headline-p destination info) + (or (not desc) + (string= desc (org-element-property + :raw-value destination)))) + headline-no + ;; Case 2: Either the headline is un-numbered or + ;; LINK has a custom description. Display LINK's + ;; description or headline's title. + (or desc (org-export-data (org-element-property + :title destination) info))))) + (org-e-odt-format-internal-link desc label))) + ;; Fuzzy link points to a target. Do as above. + (otherwise + ;; (unless desc + ;; (setq number (cond + ;; ((org-e-odt-standalone-image-p destination info) + ;; (org-export-get-ordinal + ;; (assoc 'link (org-element-contents destination)) + ;; info 'link 'org-e-odt-standalone-image-p)) + ;; (t (org-export-get-ordinal destination info)))) + ;; (setq desc (when number + ;; (if (atom number) (number-to-string number) + ;; (mapconcat 'number-to-string number "."))))) + + (let ((label-reference + (org-e-odt-format-label destination info 'reference))) + (assert label-reference) + label-reference))))) + ;; Coderef: replace link with the reference name or the + ;; equivalent line number. + ((string= type "coderef") + (let* ((fmt (org-export-get-coderef-format path desc)) + (res (org-export-resolve-coderef path info)) + (href (concat "#coderef-" path))) + (format fmt (org-e-odt-format-link res href)))) + ;; Link type is handled by a special function. + ((functionp (setq protocol (nth 2 (assoc type org-link-protocols)))) + (funcall protocol (org-link-unescape path) desc 'odt)) + ;; External link with a description part. + ((and path desc) (org-e-odt-format-link desc path)) + ;; External link without a description part. + (path (org-e-odt-format-link path path)) + ;; No path, only description. Try to do something useful. + (t (format "%s" + "Emphasis" desc))))) + + +;;;; Babel Call + +;; Babel Calls are ignored. + + +;;;; Macro + +(defun org-e-odt-macro (macro contents info) + "Transcode a MACRO element from Org to ODT. +CONTENTS is nil. INFO is a plist holding contextual information." + ;; Use available tools. + (org-export-expand-macro macro info)) + + +;;;; Paragraph + +(defun org-e-odt-paragraph (paragraph contents info) + "Transcode a PARAGRAPH element from Org to ODT. +CONTENTS is the contents of the paragraph, as a string. INFO is +the plist used as a communication channel." + (let* ((parent (org-export-get-parent paragraph)) + (parent-type (org-element-type parent)) + (style (case parent-type + (quote-block "Quotations") + (center-block "OrgCenter") + (footnote-definition "Footnote") + (t "Text_20_body")))) + ;; If this paragraph is a leading paragraph in a non-descriptive + ;; item and the item has a checkbox, splice the checkbox and + ;; paragraph contents together. + (when (and (eq (org-element-type parent) 'item) + (not (eq (org-element-property :type + (org-export-get-parent parent)) + 'descriptive)) + (eq paragraph (car (org-element-contents parent)))) + (setq contents (concat (org-e-odt--checkbox parent) contents))) + (assert style) + (format "\n%s" style contents))) + + +;;;; Plain List + +(defun org-e-odt-plain-list (plain-list contents info) + "Transcode a PLAIN-LIST element from Org to ODT. +CONTENTS is the contents of the list. INFO is a plist holding +contextual information." + (let* ((type (org-element-property :type plain-list)) + (continue-numbering nil)) + (assert (member type '(ordered unordered descriptive))) + (org-e-odt--wrap-label + plain-list + (format "\n\n%s" + (assoc-default type '((ordered . "OrgNumberedList") + (unordered . "OrgBulletedList") + (descriptive . "OrgDescriptionList"))) + ;; If top-level list, re-start numbering. Otherwise, + ;; continue numbering. + (format "text:continue-numbering=\"%s\"" + (let* ((parent (org-export-get-parent plain-list))) + (if (and parent (eq (org-element-type parent) 'item)) + "true" "false"))) + contents)))) + +;;;; Plain Text + +(defun org-e-odt-fill-tabs-and-spaces (line) + (replace-regexp-in-string + "\\([\t]\\|\\([ ]+\\)\\)" + (lambda (s) + (cond + ((string= s "\t") "") + (t (let ((n (length s))) + (cond + ((= n 1) " ") + ((> n 1) (concat " " (format "" (1- n)))) + (t "")))))) + line)) + +(defun org-e-odt-encode-plain-text (text &optional no-whitespace-filling) + (mapc + (lambda (pair) + (setq text (replace-regexp-in-string (car pair) (cdr pair) text t t))) + '(("&" . "&") ("<" . "<") (">" . ">"))) + (if no-whitespace-filling text + (org-e-odt-fill-tabs-and-spaces text))) + +(defun org-e-odt--quotation-marks (text info) + "Export quotation marks depending on language conventions. +TEXT is a string containing quotation marks to be replaced. INFO +is a plist used as a communication channel." + (mapc (lambda(l) + (let ((start 0)) + (while (setq start (string-match (car l) text start)) + (let ((new-quote (concat (match-string 1 text) (cdr l)))) + (setq text (replace-match new-quote t t text)))))) + (cdr (or (assoc (plist-get info :language) org-e-odt-quotes) + ;; Falls back on English. + (assoc "en" org-e-odt-quotes)))) + text) + +(defun org-e-odt-plain-text (text info) + "Transcode a TEXT string from Org to ODT. +TEXT is the string to transcode. INFO is a plist holding +contextual information." + ;; Protect &, < and >. + (setq text (org-e-odt-encode-plain-text text t)) + ;; Handle quotation marks + (setq text (org-e-odt--quotation-marks text info)) + ;; Convert special strings. + (when (plist-get info :with-special-strings) + (mapc + (lambda (pair) + (setq text (replace-regexp-in-string (car pair) (cdr pair) text t nil))) + org-e-odt-special-string-regexps)) + ;; Handle break preservation if required. + (when (plist-get info :preserve-breaks) + (setq text (replace-regexp-in-string + "\\(\\\\\\\\\\)?[ \t]*\n" "\n" text t))) + ;; Return value. + text) + + +;;;; Planning + +(defun org-e-odt-planning (planning contents info) + "Transcode a PLANNING element from Org to ODT. +CONTENTS is nil. INFO is a plist used as a communication +channel." + (format "%s" + "OrgTimestampWrapper" + (concat + (let ((closed (org-element-property :closed planning))) + (when closed + (concat + (format "%s" + "OrgTimestampKeyword" org-closed-string) + (format "%s" + "OrgTimestamp" (org-translate-time closed))))) + (let ((deadline (org-element-property :deadline planning))) + (when deadline + (concat + (format "%s" + "OrgTimestampKeyword" org-deadline-string) + (format "%s" + "OrgTimestamp" (org-translate-time deadline))))) + (let ((scheduled (org-element-property :scheduled planning))) + (when scheduled + (concat + (format "%s" + "OrgTimestampKeyword" org-scheduled-string) + (format "%s" + "OrgTimestamp" (org-translate-time scheduled)))))))) + + +;;;; Property Drawer + +(defun org-e-odt-property-drawer (property-drawer contents info) + "Transcode a PROPERTY-DRAWER element from Org to ODT. +CONTENTS is nil. INFO is a plist holding contextual +information." + ;; The property drawer isn't exported but we want separating blank + ;; lines nonetheless. + "") + + +;;;; Quote Block + +(defun org-e-odt-quote-block (quote-block contents info) + "Transcode a QUOTE-BLOCK element from Org to ODT. +CONTENTS holds the contents of the block. INFO is a plist +holding contextual information." + (org-e-odt--wrap-label quote-block contents)) + + +;;;; Quote Section + +(defun org-e-odt-quote-section (quote-section contents info) + "Transcode a QUOTE-SECTION element from Org to ODT. +CONTENTS is nil. INFO is a plist holding contextual information." + (let ((value (org-remove-indentation + (org-element-property :value quote-section)))) + (when value (org-e-odt-do-format-code value)))) + + +;;;; Section + + +(defun org-e-odt-format-section (text style &optional name) + (let ((default-name (car (org-e-odt-add-automatic-style "Section")))) + (format "\n\n%s" + style + (format "text:name=\"%s\"" (or name default-name)) + text))) + + +(defun org-e-odt-section (section contents info) ; FIXME + "Transcode a SECTION element from Org to ODT. +CONTENTS holds the contents of the section. INFO is a plist +holding contextual information." + contents) + +;;;; Radio Target + +(defun org-e-odt-radio-target (radio-target text info) + "Transcode a RADIO-TARGET object from Org to ODT. +TEXT is the text of the target. INFO is a plist holding +contextual information." + (org-e-odt-format-target + text (org-export-solidify-link-text + (org-element-property :value radio-target)))) + + +;;;; Special Block + +(defun org-e-odt-special-block (special-block contents info) + "Transcode a SPECIAL-BLOCK element from Org to ODT. +CONTENTS holds the contents of the block. INFO is a plist +holding contextual information." + (let ((type (downcase (org-element-property :type special-block))) + (attributes (org-export-read-attribute :attr_odt special-block))) + (org-e-odt--wrap-label + special-block + (cond + ;; Annotation. + ((string= type "annotation") + (let ((author (or (plist-get attributes :author) + (let ((author (plist-get info :author))) + (and author (org-export-data author info))))) + (date (or (plist-get attributes :date) + (plist-get info :date)))) + + (format "\n%s" + "Text_20_body" + (format "\n%s\n" + (concat + (and author + (format "%s" author)) + (and date + (format "%s" + (org-e-odt--date date))) + contents))))) + ;; Textbox. + ((string= type "textbox") + (let ((width (plist-get attributes :width)) + (height (plist-get attributes :height)) + (style (plist-get attributes :style)) + (extra (plist-get attributes :extra)) + (anchor (plist-get attributes :anchor))) + (format "\n%s" + "Text_20_body" (org-e-odt--textbox contents width height + style extra anchor)))) + (t contents))))) + + +;;;; Src Block + + +(defun org-e-odt-hfy-face-to-css (fn) + "Create custom style for face FN. +When FN is the default face, use it's foreground and background +properties to create \"OrgSrcBlock\" paragraph style. Otherwise +use it's color attribute to create a character style whose name +is obtained from FN. Currently all attributes of FN other than +color are ignored. + +The style name for a face FN is derived using the following +operations on the face name in that order - de-dash, CamelCase +and prefix with \"OrgSrc\". For example, +`font-lock-function-name-face' is associated with +\"OrgSrcFontLockFunctionNameFace\"." + (let* ((css-list (hfy-face-to-style fn)) + (style-name ((lambda (fn) + (concat "OrgSrc" + (mapconcat + 'capitalize (split-string + (hfy-face-or-def-to-name fn) "-") + ""))) fn)) + (color-val (cdr (assoc "color" css-list))) + (background-color-val (cdr (assoc "background" css-list))) + (style (and org-e-odt-create-custom-styles-for-srcblocks + (cond + ((eq fn 'default) + (format org-e-odt-src-block-paragraph-format + background-color-val color-val)) + (t + (format + " + + + " style-name color-val)))))) + (cons style-name style))) + +(defun org-e-odt-htmlfontify-string (line) + (let* ((hfy-html-quote-regex "\\([<\"&> ]\\)") + (hfy-html-quote-map '(("\"" """) + ("<" "<") + ("&" "&") + (">" ">") + (" " "") + (" " ""))) + (hfy-face-to-css 'org-e-odt-hfy-face-to-css) + (hfy-optimisations-1 (copy-seq hfy-optimisations)) + (hfy-optimisations (add-to-list 'hfy-optimisations-1 + 'body-text-only)) + (hfy-begin-span-handler + (lambda (style text-block text-id text-begins-block-p) + (insert (format "" style)))) + (hfy-end-span-handler (lambda nil (insert "")))) + (with-no-warnings (htmlfontify-string line)))) + +(defun org-e-odt-do-format-code + (code &optional lang refs retain-labels num-start) + (let* ((lang (or (assoc-default lang org-src-lang-modes) lang)) + (lang-mode (and lang (intern (format "%s-mode" lang)))) + (code-lines (org-split-string code "\n")) + (code-length (length code-lines)) + (use-htmlfontify-p (and (functionp lang-mode) + org-e-odt-fontify-srcblocks + (require 'htmlfontify nil t) + (fboundp 'htmlfontify-string))) + (code (if (not use-htmlfontify-p) code + (with-temp-buffer + (insert code) + (funcall lang-mode) + (font-lock-fontify-buffer) + (buffer-string)))) + (fontifier (if use-htmlfontify-p 'org-e-odt-htmlfontify-string + 'org-e-odt-encode-plain-text)) + (par-style (if use-htmlfontify-p "OrgSrcBlock" + "OrgFixedWidthBlock")) + (i 0)) + (assert (= code-length (length (org-split-string code "\n")))) + (setq code + (org-export-format-code + code + (lambda (loc line-num ref) + (setq par-style + (concat par-style (and (= (incf i) code-length) "LastLine"))) + + (setq loc (concat loc (and ref retain-labels (format " (%s)" ref)))) + (setq loc (funcall fontifier loc)) + (when ref + (setq loc (org-e-odt-format-target loc (concat "coderef-" ref)))) + (assert par-style) + (setq loc (format "\n%s" + par-style loc)) + (if (not line-num) loc + (format "\n%s\n" loc))) + num-start refs)) + (cond + ((not num-start) code) + ((= num-start 0) + (format + "\n%s" + " text:continue-numbering=\"false\"" code)) + (t + (format + "\n%s" + " text:continue-numbering=\"true\"" code))))) + +(defun org-e-odt-format-code (element info) + (let* ((lang (org-element-property :language element)) + ;; Extract code and references. + (code-info (org-export-unravel-code element)) + (code (car code-info)) + (refs (cdr code-info)) + ;; Does the src block contain labels? + (retain-labels (org-element-property :retain-labels element)) + ;; Does it have line numbers? + (num-start (case (org-element-property :number-lines element) + (continued (org-export-get-loc element info)) + (new 0)))) + (org-e-odt-do-format-code code lang refs retain-labels num-start))) + +(defun org-e-odt-src-block (src-block contents info) + "Transcode a SRC-BLOCK element from Org to ODT. +CONTENTS holds the contents of the item. INFO is a plist holding +contextual information." + (let* ((lang (org-element-property :language src-block)) + (caption (org-element-property :caption src-block)) + (short-caption (and (cdr caption) + (org-export-data (cdr caption) info))) + (caption (and (car caption) (org-export-data (car caption) info))) + (label (org-element-property :name src-block)) + (attributes (org-export-read-attribute :attr_odt src-block))) + ;; FIXME: Handle caption + ;; caption-str (when caption) + ;; (main (org-export-data (car caption) info)) + ;; (secondary (org-export-data (cdr caption) info)) + ;; (caption-str (org-e-odt--caption/label-string caption label info)) + (let* ((captions (org-e-odt-format-label src-block info 'definition)) + (caption (car captions)) (short-caption (cdr captions))) + (concat + (and caption + (format "\n%s" + "Listing" caption)) + (let ((--src-block (org-e-odt-format-code src-block info))) + (if (not (plist-get attributes :textbox)) --src-block + (format "\n%s" + "Text_20_body" + (org-e-odt--textbox --src-block nil nil nil)))))))) + + +;;;; Statistics Cookie + +(defun org-e-odt-statistics-cookie (statistics-cookie contents info) + "Transcode a STATISTICS-COOKIE object from Org to ODT. +CONTENTS is nil. INFO is a plist holding contextual information." + (let ((cookie-value (org-element-property :value statistics-cookie))) + (format "%s" + "OrgCode" cookie-value))) + + +;;;; Strike-Through + +(defun org-e-odt-strike-through (strike-through contents info) + "Transcode STRIKE-THROUGH from Org to ODT. +CONTENTS is the text with strike-through markup. INFO is a plist +holding contextual information." + (format "%s" + "Strikethrough" contents)) + + +;;;; Subscript + +(defun org-e-odt-subscript (subscript contents info) + "Transcode a SUBSCRIPT object from Org to ODT. +CONTENTS is the contents of the object. INFO is a plist holding +contextual information." + (format "%s" + "OrgSubscript" contents)) + + +;;;; Superscript + +(defun org-e-odt-superscript (superscript contents info) + "Transcode a SUPERSCRIPT object from Org to ODT. +CONTENTS is the contents of the object. INFO is a plist holding +contextual information." + (format "%s" + "OrgSuperscript" contents)) + + +;;;; Table Cell + +(defun org-e-odt-table-style-spec (element info) + (let* ((table (org-export-get-parent-table element)) + (table-attributes (org-export-read-attribute :attr_odt table)) + (table-style (plist-get table-attributes :style))) + (assoc table-style org-e-odt-table-styles))) + +(defun org-e-odt-get-table-cell-styles (table-cell info) + "Retrieve styles applicable to a table cell. +R and C are (zero-based) row and column numbers of the table +cell. STYLE-SPEC is an entry in `org-e-odt-table-styles' +applicable to the current table. It is `nil' if the table is not +associated with any style attributes. + +Return a cons of (TABLE-CELL-STYLE-NAME . PARAGRAPH-STYLE-NAME). + +When STYLE-SPEC is nil, style the table cell the conventional way +- choose cell borders based on row and column groupings and +choose paragraph alignment based on `org-col-cookies' text +property. See also +`org-e-odt-get-paragraph-style-cookie-for-table-cell'. + +When STYLE-SPEC is non-nil, ignore the above cookie and return +styles congruent with the ODF-1.2 specification." + (let* ((table-cell-address (org-export-table-cell-address table-cell info)) + (r (car table-cell-address)) (c (cdr table-cell-address)) + (style-spec (org-e-odt-table-style-spec table-cell info)) + (table-dimensions (org-export-table-dimensions + (org-export-get-parent-table table-cell) + info))) + (when style-spec + ;; LibreOffice - particularly the Writer - honors neither table + ;; templates nor custom table-cell styles. Inorder to retain + ;; inter-operability with LibreOffice, only automatic styles are + ;; used for styling of table-cells. The current implementation is + ;; congruent with ODF-1.2 specification and hence is + ;; future-compatible. + + ;; Additional Note: LibreOffice's AutoFormat facility for tables - + ;; which recognizes as many as 16 different cell types - is much + ;; richer. Unfortunately it is NOT amenable to easy configuration + ;; by hand. + (let* ((template-name (nth 1 style-spec)) + (cell-style-selectors (nth 2 style-spec)) + (cell-type + (cond + ((and (cdr (assoc 'use-first-column-styles cell-style-selectors)) + (= c 0)) "FirstColumn") + ((and (cdr (assoc 'use-last-column-styles cell-style-selectors)) + (= (1+ c) (cdr table-dimensions))) + "LastColumn") + ((and (cdr (assoc 'use-first-row-styles cell-style-selectors)) + (= r 0)) "FirstRow") + ((and (cdr (assoc 'use-last-row-styles cell-style-selectors)) + (= (1+ r) (car table-dimensions))) + "LastRow") + ((and (cdr (assoc 'use-banding-rows-styles cell-style-selectors)) + (= (% r 2) 1)) "EvenRow") + ((and (cdr (assoc 'use-banding-rows-styles cell-style-selectors)) + (= (% r 2) 0)) "OddRow") + ((and (cdr (assoc 'use-banding-columns-styles cell-style-selectors)) + (= (% c 2) 1)) "EvenColumn") + ((and (cdr (assoc 'use-banding-columns-styles cell-style-selectors)) + (= (% c 2) 0)) "OddColumn") + (t "")))) + (concat template-name cell-type))))) + +(defun org-e-odt-table-cell (table-cell contents info) + "Transcode a TABLE-CELL element from Org to ODT. +CONTENTS is nil. INFO is a plist used as a communication +channel." + (let* ((table-cell-address (org-export-table-cell-address table-cell info)) + (r (car table-cell-address)) + (c (cdr table-cell-address)) + (horiz-span (or (org-export-table-cell-width table-cell info) 0)) + (table-row (org-export-get-parent table-cell)) + (custom-style-prefix (org-e-odt-get-table-cell-styles + table-cell info)) + (paragraph-style + (or + (and custom-style-prefix + (format "%sTableParagraph" custom-style-prefix)) + (concat + (cond + ((and (= 1 (org-export-table-row-group table-row info)) + (org-export-table-has-header-p + (org-export-get-parent-table table-row) info)) + "OrgTableHeading") + ((let* ((table (org-export-get-parent-table table-cell)) + (table-attrs (org-export-read-attribute :attr_odt table)) + (table-header-columns (plist-get table-attrs + :header-columns))) + (<= c (cond ((wholenump table-header-columns) + (- table-header-columns 1)) + (table-header-columns 0) + (t -1)))) + "OrgTableHeading") + (t "OrgTableContents")) + (capitalize (symbol-name (org-export-table-cell-alignment + table-cell info)))))) + (cell-style-name + (or + (and custom-style-prefix (format "%sTableCell" + custom-style-prefix)) + (concat + "OrgTblCell" + (when (or (org-export-table-row-starts-rowgroup-p table-row info) + (zerop r)) "T") + (when (org-export-table-row-ends-rowgroup-p table-row info) "B") + (when (and (org-export-table-cell-starts-colgroup-p table-cell info) + (not (zerop c)) ) "L")))) + (cell-attributes + (concat + (format " table:style-name=\"%s\"" cell-style-name) + (and (> horiz-span 0) + (format " table:number-columns-spanned=\"%d\"" + (1+ horiz-span)))))) + (unless contents (setq contents "")) + (concat + (assert paragraph-style) + (format "\n\n%s\n" + cell-attributes + (format "\n%s" + paragraph-style contents)) + (let (s) + (dotimes (i horiz-span s) + (setq s (concat s "\n")))) + "\n"))) + + +;;;; Table Row + +(defun org-e-odt-table-row (table-row contents info) + "Transcode a TABLE-ROW element from Org to ODT. +CONTENTS is the contents of the row. INFO is a plist used as a +communication channel." + ;; Rules are ignored since table separators are deduced from + ;; borders of the current row. + (when (eq (org-element-property :type table-row) 'standard) + (let* ((rowgroup-tags + (if (and (= 1 (org-export-table-row-group table-row info)) + (org-export-table-has-header-p + (org-export-get-parent-table table-row) info)) + ;; If the row belongs to the first rowgroup and the + ;; table has more than one row groups, then this row + ;; belongs to the header row group. + '("\n" . "\n") + ;; Otherwise, it belongs to non-header row group. + '("\n" . "\n")))) + (concat + ;; Does this row begin a rowgroup? + (when (org-export-table-row-starts-rowgroup-p table-row info) + (car rowgroup-tags)) + ;; Actual table row + (format "\n\n%s\n" contents) + ;; Does this row end a rowgroup? + (when (org-export-table-row-ends-rowgroup-p table-row info) + (cdr rowgroup-tags)))))) + + +;;;; Table + +(defun org-e-odt-table-first-row-data-cells (table info) + (let ((table-row + (org-element-map + table 'table-row + (lambda (row) + (unless (eq (org-element-property :type row) 'rule) row)) + info 'first-match)) + (special-column-p (org-export-table-has-special-column-p table))) + (if (not special-column-p) (org-element-contents table-row) + (cdr (org-element-contents table-row))))) + +(defun org-e-odt--table (table contents info) + "Transcode a TABLE element from Org to ODT. +CONTENTS is the contents of the table. INFO is a plist holding +contextual information." + (case (org-element-property :type table) + ;; Case 1: table.el doesn't support export to OD format. Strip + ;; such tables from export. + (table.el + (prog1 nil + (message + (concat + "(org-e-odt): Found table.el-type table in the source Org file." + " table.el doesn't support export to ODT format." + " Stripping the table from export.")))) + ;; Case 2: Native Org tables. + (otherwise + (let* ((captions (org-e-odt-format-label table info 'definition)) + (caption (car captions)) (short-caption (cdr captions)) + (attributes (org-export-read-attribute :attr_odt table)) + (custom-table-style (nth 1 (org-e-odt-table-style-spec table info))) + (table-column-specs + (function + (lambda (table info) + (let* ((table-style (or custom-table-style "OrgTable")) + (column-style (format "%sColumn" table-style))) + (mapconcat + (lambda (table-cell) + (let ((width (1+ (or (org-export-table-cell-width + table-cell info) 0))) + (s (format + "\n" + column-style)) + out) + (dotimes (i width out) (setq out (concat s out))))) + (org-e-odt-table-first-row-data-cells table info) "\n")))))) + (concat + ;; caption. + (when caption + (format "\n%s" + "Table" caption)) + ;; begin table. + (let* ((automatic-name + (org-e-odt-add-automatic-style "Table" attributes))) + (format + "\n" + (or short-caption (car automatic-name)) + (or custom-table-style (cdr automatic-name) "OrgTable"))) + ;; column specification. + (funcall table-column-specs table info) + ;; actual contents. + "\n" contents + ;; end table. + ""))))) + +(defun org-e-odt-table (table contents info) + "Transcode a TABLE element from Org to ODT. +CONTENTS is the contents of the table. INFO is a plist holding +contextual information." + (let* ((--get-previous-elements + (function + (lambda (blob info) + (let ((parent (org-export-get-parent blob))) + (cdr (member blob (reverse (org-element-contents parent)))))))) + (--element-preceded-by-table-p + (function + (lambda (element info) + (loop for el in (funcall --get-previous-elements element info) + thereis (eq (org-element-type el) 'table))))) + (--walk-list-genealogy-and-collect-tags + (function + (lambda (table info) + (let* ((genealogy (org-export-get-genealogy table)) + (list-genealogy + (when (eq (org-element-type (car genealogy)) 'item) + (loop for el in genealogy + when (member (org-element-type el) + '(item plain-list)) + collect el)))) + (loop for el in list-genealogy + with parent-list collect + (case (org-element-type el) + (plain-list + (setq parent-list el) + `("" + . ,(let ((type (org-element-property :type el))) + (format + "" + (assoc-default + type '((ordered . "OrgNumberedList") + (unordered . "OrgBulletedList") + (descriptive . "OrgDescriptionList"))) + "text:continue-numbering=\"true\"")))) + (item + (cond + ((not parent-list) + (if (funcall --element-preceded-by-table-p table info) + '("" . "") + '("" . ""))) + ((funcall --element-preceded-by-table-p + parent-list info) + '("" . "")) + (t '("" . "")))))))))) + (close-open-tags (funcall --walk-list-genealogy-and-collect-tags + table info))) + ;; OpenDocument schema does not permit table to occur within a + ;; list item. So, to typeset an indented table, we make use of + ;; list continuations. + (concat "\n" + ;; Discontinue the list. + (mapconcat 'car close-open-tags "\n") + ;; Put the table in an indented section. + (let* ((table (org-e-odt--table table contents info)) + (level (/ (length (mapcar 'car close-open-tags)) 2)) + (style (format "OrgIndentedSection-Level-%d" level))) + (when table (org-e-odt-format-section table style))) + ;; Continue the list. + (mapconcat 'cdr (nreverse close-open-tags) "\n")))) + + +;;;; Target + +(defun org-e-odt-target (target contents info) + "Transcode a TARGET object from Org to ODT. +CONTENTS is nil. INFO is a plist holding contextual +information." + (org-e-odt-format-target + "" (org-export-solidify-link-text (org-element-property :value target)))) + + +;;;; Timestamp + +(defun org-e-odt-timestamp (timestamp contents info) + "Transcode a TIMESTAMP object from Org to ODT. +CONTENTS is nil. INFO is a plist used as a communication +channel." + (let ((timestamp-1 (org-element-property :value timestamp)) + (timestamp-2 (org-element-property :range-end timestamp))) + (format "%s" + "OrgTimestampWrapper" + (concat + (format "%s" + "OrgTimestamp" (org-translate-time timestamp-1)) + (and timestamp-2 + "–" + (format "%s" + "OrgTimestamp" (org-translate-time timestamp-2))))))) + + +;;;; Underline + +(defun org-e-odt-underline (underline contents info) + "Transcode UNDERLINE from Org to ODT. +CONTENTS is the text with underline markup. INFO is a plist +holding contextual information." + (format "%s" + "Underline" contents)) + + +;;;; Verbatim + +(defun org-e-odt-verbatim (verbatim contents info) + "Transcode a VERBATIM object from Org to ODT. +CONTENTS is nil. INFO is a plist used as a communication +channel." + (format "%s" + "OrgCode" (org-element-property :value verbatim))) + + +;;;; Verse Block + +(defun org-e-odt-verse-block (verse-block contents info) + "Transcode a VERSE-BLOCK element from Org to ODT. +CONTENTS is verse block contents. INFO is a plist holding +contextual information." + ;; Add line breaks to each line of verse. + (setq contents (replace-regexp-in-string + "\\(\\)?[ \t]*\n" + "" contents)) + ;; Replace tabs and spaces. + (setq contents (org-e-odt-fill-tabs-and-spaces contents)) + ;; Surround it in a verse environment. + (org-e-odt--wrap-label + verse-block + (format "\n%s" + "OrgVerse" contents))) + + + + + +;;; Interactive functions + +(defun org-e-odt-create-manifest-file-entry (&rest args) + (push args org-e-odt-manifest-file-entries)) + +(defun org-e-odt-write-manifest-file () + (make-directory (concat org-e-odt-zip-dir "META-INF")) + (let ((manifest-file (concat org-e-odt-zip-dir "META-INF/manifest.xml"))) + (with-current-buffer + (let ((nxml-auto-insert-xml-declaration-flag nil)) + (find-file-noselect manifest-file t)) + (insert + " + \n") + (mapc + (lambda (file-entry) + (let* ((version (nth 2 file-entry)) + (extra (if (not version) "" + (format " manifest:version=\"%s\"" version)))) + (insert + (format org-e-odt-manifest-file-entry-tag + (nth 0 file-entry) (nth 1 file-entry) extra)))) + org-e-odt-manifest-file-entries) + (insert "\n")))) + +(defmacro org-e-odt--export-wrap (out-file &rest body) + `(let* ((--out-file ,out-file) + (out-file-type (file-name-extension --out-file)) + (org-e-odt-xml-files '("META-INF/manifest.xml" "content.xml" + "meta.xml" "styles.xml")) + ;; Initialize workarea. All files that end up in the + ;; exported get created here. + (org-e-odt-zip-dir (file-name-as-directory + (make-temp-file (format "%s-" out-file-type) t))) + (org-e-odt-manifest-file-entries nil) + (--cleanup-xml-buffers + (function + (lambda nil + ;; Kill all XML buffers. + (mapc (lambda (file) + (let ((buf (get-file-buffer + (concat org-e-odt-zip-dir file)))) + (when buf + (set-buffer-modified-p nil) + (kill-buffer buf)))) + org-e-odt-xml-files) + ;; Delete temporary directory and also other embedded + ;; files that get copied there. + (delete-directory org-e-odt-zip-dir t))))) + (org-condition-case-unless-debug + err + (progn + (unless (executable-find "zip") + ;; Not at all OSes ship with zip by default + (error "Executable \"zip\" needed for creating OpenDocument files")) + ;; Do export. This creates a bunch of xml files ready to be + ;; saved and zipped. + (progn ,@body) + ;; Create a manifest entry for content.xml. + (org-e-odt-create-manifest-file-entry "text/xml" "content.xml") + + ;; Write mimetype file + (let* ((mimetypes + '(("odt" . "application/vnd.oasis.opendocument.text") + ("odf" . "application/vnd.oasis.opendocument.formula"))) + (mimetype (cdr (assoc-string out-file-type mimetypes t)))) + (unless mimetype + (error "Unknown OpenDocument backend %S" out-file-type)) + (write-region mimetype nil (concat org-e-odt-zip-dir "mimetype")) + (org-e-odt-create-manifest-file-entry mimetype "/" "1.2")) + ;; Write out the manifest entries before zipping + (org-e-odt-write-manifest-file) + ;; Save all XML files. + (mapc (lambda (file) + (let ((buf (get-file-buffer (concat org-e-odt-zip-dir file)))) + (when buf + (with-current-buffer buf + ;; Prettify output if needed. + (when org-e-odt-prettify-xml + (indent-region (point-min) (point-max))) + (save-buffer 0))))) + org-e-odt-xml-files) + ;; Run zip. + (let* ((target --out-file) + (target-name (file-name-nondirectory target)) + (target-dir (file-name-directory target)) + (cmds `(("zip" "-mX0" ,target-name "mimetype") + ("zip" "-rmTq" ,target-name ".")))) + ;; If a file with same name as the desired output file + ;; exists, remove it. + (when (file-exists-p target) + (delete-file target)) + ;; Zip up the xml files. + (let ((coding-system-for-write 'no-conversion) exitcode err-string) + (message "Creating ODT file...") + ;; Switch temporarily to content.xml. This way Zip + ;; process will inherit `org-e-odt-zip-dir' as the current + ;; directory. + (with-current-buffer + (find-file-noselect (concat org-e-odt-zip-dir "content.xml") t) + (mapc + (lambda (cmd) + (message "Running %s" (mapconcat 'identity cmd " ")) + (setq err-string + (with-output-to-string + (setq exitcode + (apply 'call-process (car cmd) + nil standard-output nil (cdr cmd))))) + (or (zerop exitcode) + (error (concat "Unable to create OpenDocument file." + (format " Zip failed with error (%s)" + err-string))))) + cmds) + ;; Zip file is now in the rightful place. + (rename-file target-name target))) + (message "Created %s" target) + ;; Cleanup work directory and work files. + (funcall --cleanup-xml-buffers) + ;; Open the OpenDocument file in archive-mode for + ;; examination. + (find-file-noselect target t) + ;; Return exported file. + (cond + ;; Case 1: Conversion desired on exported file. Run the + ;; converter on the OpenDocument file. Return the + ;; converted file. + (org-e-odt-preferred-output-format + (or (org-e-odt-convert target org-e-odt-preferred-output-format) + target)) + ;; Case 2: No further conversion. Return exported + ;; OpenDocument file. + (t target)))) + ((quit error) + ;; Cleanup work directory and work files. + (funcall --cleanup-xml-buffers) + (message "OpenDocument export failed: %s" + (error-message-string err)))))) + + + +;;;###autoload +(defun org-e-odt-export-as-odf (latex-frag &optional odf-file) + "Export LATEX-FRAG as OpenDocument formula file ODF-FILE. +Use `org-create-math-formula' to convert LATEX-FRAG first to +MathML. When invoked as an interactive command, use +`org-latex-regexps' to infer LATEX-FRAG from currently active +region. If no LaTeX fragments are found, prompt for it. Push +MathML source to kill ring, if `org-export-copy-to-kill-ring' is +non-nil." + (interactive + `(,(let (frag) + (setq frag (and (setq frag (and (region-active-p) + (buffer-substring (region-beginning) + (region-end)))) + (loop for e in org-latex-regexps + thereis (when (string-match (nth 1 e) frag) + (match-string (nth 2 e) frag))))) + (read-string "LaTeX Fragment: " frag nil frag)) + ,(let ((odf-filename (expand-file-name + (concat + (file-name-sans-extension + (or (file-name-nondirectory buffer-file-name))) + "." "odf") + (file-name-directory buffer-file-name)))) + (read-file-name "ODF filename: " nil odf-filename nil + (file-name-nondirectory odf-filename))))) + (let ((filename (or odf-file + (expand-file-name + (concat + (file-name-sans-extension + (or (file-name-nondirectory buffer-file-name))) + "." "odf") + (file-name-directory buffer-file-name))))) + (org-e-odt--export-wrap + filename + (let* ((buffer (progn + (require 'nxml-mode) + (let ((nxml-auto-insert-xml-declaration-flag nil)) + (find-file-noselect (concat org-e-odt-zip-dir + "content.xml") t)))) + (coding-system-for-write 'utf-8) + (save-buffer-coding-system 'utf-8)) + (set-buffer buffer) + (set-buffer-file-coding-system coding-system-for-write) + (let ((mathml (org-create-math-formula latex-frag))) + (unless mathml (error "No Math formula created")) + (insert mathml) + ;; Add MathML to kill ring, if needed. + (when org-export-copy-to-kill-ring + (org-kill-new (buffer-string)))))))) + +;;;###autoload +(defun org-e-odt-export-as-odf-and-open () + "Export LaTeX fragment as OpenDocument formula and immediately open it. +Use `org-e-odt-export-as-odf' to read LaTeX fragment and OpenDocument +formula file." + (interactive) + (org-open-file (call-interactively 'org-e-odt-export-as-odf))) + +;;;###autoload +(defun org-e-odt-export-to-odt + (&optional subtreep visible-only body-only ext-plist pub-dir) + "Export current buffer to a HTML file. + +If narrowing is active in the current buffer, only export its +narrowed part. + +If a region is active, export that region. + +When optional argument SUBTREEP is non-nil, export the sub-tree +at point, extracting information from the headline properties +first. + +When optional argument VISIBLE-ONLY is non-nil, don't export +contents of hidden elements. + +When optional argument BODY-ONLY is non-nil, only write code +between \"\\begin{document}\" and \"\\end{document}\". + +EXT-PLIST, when provided, is a property list with external +parameters overriding Org default settings, but still inferior to +file-local settings. + +When optional argument PUB-DIR is set, use it as the publishing +directory. + +Return output file's name." + (interactive) + (org-e-odt--export-wrap + (org-export-output-file-name ".odt" subtreep pub-dir) + (let* ((org-e-odt-embedded-images-count 0) + (org-e-odt-embedded-formulas-count 0) + (org-e-odt-automatic-styles nil) + (org-e-odt-object-counters nil) + ;; Let `htmlfontify' know that we are interested in collecting + ;; styles. + (hfy-user-sheet-assoc nil)) + ;; Initialize content.xml and kick-off the export process. + (let ((out-buf (progn + (require 'nxml-mode) + (let ((nxml-auto-insert-xml-declaration-flag nil)) + (find-file-noselect + (concat org-e-odt-zip-dir "content.xml") t))))) + (org-export-to-buffer 'e-odt out-buf subtreep visible-only body-only))))) + + + + +(defun org-e-odt-reachable-p (in-fmt out-fmt) + "Return non-nil if IN-FMT can be converted to OUT-FMT." + (catch 'done + (let ((reachable-formats (org-e-odt-do-reachable-formats in-fmt))) + (dolist (e reachable-formats) + (let ((out-fmt-spec (assoc out-fmt (cdr e)))) + (when out-fmt-spec + (throw 'done (cons (car e) out-fmt-spec)))))))) + +(defun org-e-odt-do-convert (in-file out-fmt &optional prefix-arg) + "Workhorse routine for `org-e-odt-convert'." + (require 'browse-url) + (let* ((in-file (expand-file-name (or in-file buffer-file-name))) + (dummy (or (file-readable-p in-file) + (error "Cannot read %s" in-file))) + (in-fmt (file-name-extension in-file)) + (out-fmt (or out-fmt (error "Output format unspecified"))) + (how (or (org-e-odt-reachable-p in-fmt out-fmt) + (error "Cannot convert from %s format to %s format?" + in-fmt out-fmt))) + (convert-process (car how)) + (out-file (concat (file-name-sans-extension in-file) "." + (nth 1 (or (cdr how) out-fmt)))) + (extra-options (or (nth 2 (cdr how)) "")) + (out-dir (file-name-directory in-file)) + (cmd (format-spec convert-process + `((?i . ,(shell-quote-argument in-file)) + (?I . ,(browse-url-file-url in-file)) + (?f . ,out-fmt) + (?o . ,out-file) + (?O . ,(browse-url-file-url out-file)) + (?d . , (shell-quote-argument out-dir)) + (?D . ,(browse-url-file-url out-dir)) + (?x . ,extra-options))))) + (when (file-exists-p out-file) + (delete-file out-file)) + + (message "Executing %s" cmd) + (let ((cmd-output (shell-command-to-string cmd))) + (message "%s" cmd-output)) + + (cond + ((file-exists-p out-file) + (message "Exported to %s" out-file) + (when prefix-arg + (message "Opening %s..." out-file) + (org-open-file out-file)) + out-file) + (t + (message "Export to %s failed" out-file) + nil)))) + +(defun org-e-odt-do-reachable-formats (in-fmt) + "Return verbose info about formats to which IN-FMT can be converted. +Return a list where each element is of the +form (CONVERTER-PROCESS . OUTPUT-FMT-ALIST). See +`org-e-odt-convert-processes' for CONVERTER-PROCESS and see +`org-e-odt-convert-capabilities' for OUTPUT-FMT-ALIST." + (let* ((converter + (and org-e-odt-convert-process + (cadr (assoc-string org-e-odt-convert-process + org-e-odt-convert-processes t)))) + (capabilities + (and org-e-odt-convert-process + (cadr (assoc-string org-e-odt-convert-process + org-e-odt-convert-processes t)) + org-e-odt-convert-capabilities)) + reachable-formats) + (when converter + (dolist (c capabilities) + (when (member in-fmt (nth 1 c)) + (push (cons converter (nth 2 c)) reachable-formats)))) + reachable-formats)) + +(defun org-e-odt-reachable-formats (in-fmt) + "Return list of formats to which IN-FMT can be converted. +The list of the form (OUTPUT-FMT-1 OUTPUT-FMT-2 ...)." + (let (l) + (mapc (lambda (e) (add-to-list 'l e)) + (apply 'append (mapcar + (lambda (e) (mapcar 'car (cdr e))) + (org-e-odt-do-reachable-formats in-fmt)))) + l)) + +(defun org-e-odt-convert-read-params () + "Return IN-FILE and OUT-FMT params for `org-e-odt-do-convert'. +This is a helper routine for interactive use." + (let* ((input (if (featurep 'ido) 'ido-completing-read 'completing-read)) + (in-file (read-file-name "File to be converted: " + nil buffer-file-name t)) + (in-fmt (file-name-extension in-file)) + (out-fmt-choices (org-e-odt-reachable-formats in-fmt)) + (out-fmt + (or (and out-fmt-choices + (funcall input "Output format: " + out-fmt-choices nil nil nil)) + (error + "No known converter or no known output formats for %s files" + in-fmt)))) + (list in-file out-fmt))) + +;;;###autoload +(defun org-e-odt-convert (&optional in-file out-fmt prefix-arg) + "Convert IN-FILE to format OUT-FMT using a command line converter. +IN-FILE is the file to be converted. If unspecified, it defaults +to variable `buffer-file-name'. OUT-FMT is the desired output +format. Use `org-e-odt-convert-process' as the converter. +If PREFIX-ARG is non-nil then the newly converted file is opened +using `org-open-file'." + (interactive + (append (org-e-odt-convert-read-params) current-prefix-arg)) + (org-e-odt-do-convert in-file out-fmt prefix-arg)) + +;;; Library Initializations + +(mapc + (lambda (desc) + ;; Let Org open all OpenDocument files using system-registered app + (add-to-list 'org-file-apps + (cons (concat "\\." (car desc) "\\'") 'system)) + ;; Let Emacs open all OpenDocument files in archive mode + (add-to-list 'auto-mode-alist + (cons (concat "\\." (car desc) "\\'") 'archive-mode))) + org-e-odt-file-extensions) + +(provide 'org-e-odt) + +;;; org-e-odt.el ends here diff --git a/contrib/lisp/org-e-publish.el b/contrib/lisp/org-e-publish.el new file mode 100644 index 0000000..894ee07 --- /dev/null +++ b/contrib/lisp/org-e-publish.el @@ -0,0 +1,1200 @@ +;;; org-e-publish.el --- publish related org-mode files as a website +;; Copyright (C) 2006-2012 Free Software Foundation, Inc. + +;; Author: David O'Toole +;; Maintainer: Carsten Dominik +;; Keywords: hypermedia, outlines, wp + +;; This file is not part of GNU Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; This program allow configurable publishing of related sets of +;; Org mode files as a complete website. +;; +;; org-e-publish.el can do the following: +;; +;; + Publish all one's Org files to HTML or PDF +;; + Upload HTML, images, attachments and other files to a web server +;; + Exclude selected private pages from publishing +;; + Publish a clickable sitemap of pages +;; + Manage local timestamps for publishing only changed files +;; + Accept plugin functions to extend range of publishable content +;; +;; Documentation for publishing is in the manual. + +;;; Code: + +(eval-when-compile (require 'cl)) +(require 'format-spec) +(require 'org-export) + +(declare-function org-e-latex-compile "org-e-latex" (texfile)) + + + +;;; Variables +(defvar org-e-publish-initial-buffer nil + "The buffer `org-e-publish' has been called from.") + +(defvar org-e-publish-temp-files nil + "Temporary list of files to be published.") + +;; Here, so you find the variable right before it's used the first time: +(defvar org-e-publish-cache nil + "This will cache timestamps and titles for files in publishing projects. +Blocks could hash sha1 values here.") + +(defgroup org-e-publish nil + "Options for publishing a set of Org-mode and related files." + :tag "Org Publishing" + :group 'org) + +(defcustom org-e-publish-project-alist nil + "Association list to control publishing behavior. +Each element of the alist is a publishing 'project.' The CAR of +each element is a string, uniquely identifying the project. The +CDR of each element is in one of the following forms: + +1. A well-formed property list with an even number of elements, + alternating keys and values, specifying parameters for the + publishing process. + + \(:property value :property value ... ) + +2. A meta-project definition, specifying of a list of + sub-projects: + + \(:components \(\"project-1\" \"project-2\" ...)) + +When the CDR of an element of org-e-publish-project-alist is in +this second form, the elements of the list after `:components' +are taken to be components of the project, which group together +files requiring different publishing options. When you publish +such a project with \\[org-e-publish], the components all +publish. + +When a property is given a value in +`org-e-publish-project-alist', its setting overrides the value of +the corresponding user variable \(if any) during publishing. +However, options set within a file override everything. + +Most properties are optional, but some should always be set: + + `:base-directory' + + Directory containing publishing source files. + + `:base-extension' + + Extension \(without the dot!) of source files. This can be + a regular expression. If not given, \"org\" will be used as + default extension. + + `:publishing-directory' + + Directory \(possibly remote) where output files will be + published. + +The `:exclude' property may be used to prevent certain files from +being published. Its value may be a string or regexp matching +file names you don't want to be published. + +The `:include' property may be used to include extra files. Its +value may be a list of filenames to include. The filenames are +considered relative to the base directory. + +When both `:include' and `:exclude' properties are given values, +the exclusion step happens first. + +One special property controls which back-end function to use for +publishing files in the project. This can be used to extend the +set of file types publishable by `org-e-publish', as well as the +set of output formats. + + `:publishing-function' + + Function to publish file. The default is + `org-e-publish-org-to-ascii', but other values are possible. + May also be a list of functions, in which case each function + in the list is invoked in turn. + +Another property allows you to insert code that prepares +a project for publishing. For example, you could call GNU Make +on a certain makefile, to ensure published files are built up to +date. + + `:preparation-function' + + Function to be called before publishing this project. This + may also be a list of functions. + + `:completion-function' + + Function to be called after publishing this project. This + may also be a list of functions. + +Some properties control details of the Org publishing process, +and are equivalent to the corresponding user variables listed in +the right column. Back-end specific properties may also be +included. See the back-end documentation for more information. + + :author `user-full-name' + :creator `org-export-creator-string' + :email `user-mail-address' + :exclude-tags `org-export-exclude-tags' + :headline-levels `org-export-headline-levels' + :language `org-export-default-language' + :preserve-breaks `org-export-preserve-breaks' + :section-numbers `org-export-with-section-numbers' + :select-tags `org-export-select-tags' + :time-stamp-file `org-export-time-stamp-file' + :with-archived-trees `org-export-with-archived-trees' + :with-author `org-export-with-author' + :with-creator `org-export-with-creator' + :with-drawers `org-export-with-drawers' + :with-email `org-export-with-email' + :with-emphasize `org-export-with-emphasize' + :with-entities `org-export-with-entities' + :with-fixed-width `org-export-with-fixed-width' + :with-footnotes `org-export-with-footnotes' + :with-priority `org-export-with-priority' + :with-special-strings `org-export-with-special-strings' + :with-sub-superscript `org-export-with-sub-superscripts' + :with-toc `org-export-with-toc' + :with-tables `org-export-with-tables' + :with-tags `org-export-with-tags' + :with-tasks `org-export-with-tasks' + :with-timestamps `org-export-with-timestamps' + :with-todo-keywords `org-export-with-todo-keywords' + +The following properties may be used to control publishing of +a site-map of files or summary page for a given project. + + `:auto-sitemap' + + Whether to publish a site-map during + `org-e-publish-current-project' or `org-e-publish-all'. + + `:sitemap-filename' + + Filename for output of sitemap. Defaults to \"sitemap.org\". + + `:sitemap-title' + + Title of site-map page. Defaults to name of file. + + `:sitemap-function' + + Plugin function to use for generation of site-map. Defaults to + `org-e-publish-org-sitemap', which generates a plain list of + links to all files in the project. + + `:sitemap-style' + + Can be `list' \(site-map is just an itemized list of the + titles of the files involved) or `tree' \(the directory + structure of the source files is reflected in the site-map). + Defaults to `tree'. + + `:sitemap-sans-extension' + + Remove extension from site-map's file-names. Useful to have + cool URIs \(see http://www.w3.org/Provider/Style/URI). + Defaults to nil. + +If you create a site-map file, adjust the sorting like this: + + `:sitemap-sort-folders' + + Where folders should appear in the site-map. Set this to + `first' \(default) or `last' to display folders first or + last, respectively. Any other value will mix files and + folders. + + `:sitemap-sort-files' + + The site map is normally sorted alphabetically. You can + change this behaviour setting this to `anti-chronologically', + `chronologically', or nil. + + `:sitemap-ignore-case' + + Should sorting be case-sensitive? Default nil. + +The following properties control the creation of a concept index. + + `:makeindex' + + Create a concept index. + +Other properties affecting publication. + + `:body-only' + + Set this to t to publish only the body of the documents." + :group 'org-e-publish + :type 'alist) + +(defcustom org-e-publish-use-timestamps-flag t + "Non-nil means use timestamp checking to publish only changed files. +When nil, do no timestamp checking and always publish all files." + :group 'org-e-publish + :type 'boolean) + +(defcustom org-e-publish-timestamp-directory + (convert-standard-filename "~/.org-timestamps/") + "Name of directory in which to store publishing timestamps." + :group 'org-e-publish + :type 'directory) + +(defcustom org-e-publish-list-skipped-files t + "Non-nil means show message about files *not* published." + :group 'org-e-publish + :type 'boolean) + +(defcustom org-e-publish-sitemap-sort-files 'alphabetically + "Method to sort files in site-maps. +Possible values are `alphabetically', `chronologically', +`anti-chronologically' and nil. + +If `alphabetically', files will be sorted alphabetically. If +`chronologically', files will be sorted with older modification +time first. If `anti-chronologically', files will be sorted with +newer modification time first. nil won't sort files. + +You can overwrite this default per project in your +`org-e-publish-project-alist', using `:sitemap-sort-files'." + :group 'org-e-publish + :type 'symbol) + +(defcustom org-e-publish-sitemap-sort-folders 'first + "A symbol, denoting if folders are sorted first in sitemaps. +Possible values are `first', `last', and nil. +If `first', folders will be sorted before files. +If `last', folders are sorted to the end after the files. +Any other value will not mix files and folders. + +You can overwrite this default per project in your +`org-e-publish-project-alist', using `:sitemap-sort-folders'." + :group 'org-e-publish + :type 'symbol) + +(defcustom org-e-publish-sitemap-sort-ignore-case nil + "Non-nil when site-map sorting should ignore case. + +You can overwrite this default per project in your +`org-e-publish-project-alist', using `:sitemap-ignore-case'." + :group 'org-e-publish + :type 'boolean) + +(defcustom org-e-publish-sitemap-date-format "%Y-%m-%d" + "Format for `format-time-string' which is used to print a date +in the sitemap." + :group 'org-e-publish + :type 'string) + +(defcustom org-e-publish-sitemap-file-entry-format "%t" + "Format string for site-map file entry. +You could use brackets to delimit on what part the link will be. + +%t is the title. +%a is the author. +%d is the date formatted using `org-e-publish-sitemap-date-format'." + :group 'org-e-publish + :type 'string) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Timestamp-related functions + +(defun org-e-publish-timestamp-filename (filename &optional pub-dir pub-func) + "Return path to timestamp file for filename FILENAME." + (setq filename (concat filename "::" (or pub-dir "") "::" + (format "%s" (or pub-func "")))) + (concat "X" (if (fboundp 'sha1) (sha1 filename) (md5 filename)))) + +(defun org-e-publish-needed-p + (filename &optional pub-dir pub-func true-pub-dir base-dir) + "Non-nil if FILENAME should be published in PUB-DIR using PUB-FUNC. +TRUE-PUB-DIR is where the file will truly end up. Currently we +are not using this - maybe it can eventually be used to check if +the file is present at the target location, and how old it is. +Right now we cannot do this, because we do not know under what +file name the file will be stored - the publishing function can +still decide about that independently." + (let ((rtn (if (not org-e-publish-use-timestamps-flag) t + (org-e-publish-cache-file-needs-publishing + filename pub-dir pub-func base-dir)))) + (if rtn (message "Publishing file %s using `%s'" filename pub-func) + (when org-e-publish-list-skipped-files + (message "Skipping unmodified file %s" filename))) + rtn)) + +(defun org-e-publish-update-timestamp + (filename &optional pub-dir pub-func base-dir) + "Update publishing timestamp for file FILENAME. +If there is no timestamp, create one." + (let ((key (org-e-publish-timestamp-filename filename pub-dir pub-func)) + (stamp (org-e-publish-cache-ctime-of-src filename base-dir))) + (org-e-publish-cache-set key stamp))) + +(defun org-e-publish-remove-all-timestamps () + "Remove all files in the timestamp directory." + (let ((dir org-e-publish-timestamp-directory) + files) + (when (and (file-exists-p dir) (file-directory-p dir)) + (mapc 'delete-file (directory-files dir 'full "[^.]\\'")) + (org-e-publish-reset-cache)))) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Getting project information out of `org-e-publish-project-alist' + +(defun org-e-publish-expand-projects (projects-alist) + "Expand projects in PROJECTS-ALIST. +This splices all the components into the list." + (let ((rest projects-alist) rtn p components) + (while (setq p (pop rest)) + (if (setq components (plist-get (cdr p) :components)) + (setq rest (append + (mapcar (lambda (x) (assoc x org-e-publish-project-alist)) + components) + rest)) + (push p rtn))) + (nreverse (delete-dups (delq nil rtn))))) + +(defvar org-sitemap-sort-files) +(defvar org-sitemap-sort-folders) +(defvar org-sitemap-ignore-case) +(defvar org-sitemap-requested) +(defvar org-sitemap-date-format) +(defvar org-sitemap-file-entry-format) +(defun org-e-publish-compare-directory-files (a b) + "Predicate for `sort', that sorts folders and files for sitemap." + (let ((retval t)) + (when (or org-sitemap-sort-files org-sitemap-sort-folders) + ;; First we sort files: + (when org-sitemap-sort-files + (case org-sitemap-sort-files + (alphabetically + (let* ((adir (file-directory-p a)) + (aorg (and (string-match "\\.org$" a) (not adir))) + (bdir (file-directory-p b)) + (borg (and (string-match "\\.org$" b) (not bdir))) + (A (if aorg (concat (file-name-directory a) + (org-e-publish-find-title a)) a)) + (B (if borg (concat (file-name-directory b) + (org-e-publish-find-title b)) b))) + (setq retval (if org-sitemap-ignore-case + (not (string-lessp (upcase B) (upcase A))) + (not (string-lessp B A)))))) + ((anti-chronologically chronologically) + (let* ((adate (org-e-publish-find-date a)) + (bdate (org-e-publish-find-date b)) + (A (+ (lsh (car adate) 16) (cadr adate))) + (B (+ (lsh (car bdate) 16) (cadr bdate)))) + (setq retval + (if (eq org-sitemap-sort-files 'chronologically) (<= A B) + (>= A B))))))) + ;; Directory-wise wins: + (when org-sitemap-sort-folders + ;; a is directory, b not: + (cond + ((and (file-directory-p a) (not (file-directory-p b))) + (setq retval (equal org-sitemap-sort-folders 'first))) + ;; a is not a directory, but b is: + ((and (not (file-directory-p a)) (file-directory-p b)) + (setq retval (equal org-sitemap-sort-folders 'last)))))) + retval)) + +(defun org-e-publish-get-base-files-1 + (base-dir &optional recurse match skip-file skip-dir) + "Set `org-e-publish-temp-files' with files from BASE-DIR directory. +If RECURSE is non-nil, check BASE-DIR recursively. If MATCH is +non-nil, restrict this list to the files matching the regexp +MATCH. If SKIP-FILE is non-nil, skip file matching the regexp +SKIP-FILE. If SKIP-DIR is non-nil, don't check directories +matching the regexp SKIP-DIR when recursing through BASE-DIR." + (mapc (lambda (f) + (let ((fd-p (file-directory-p f)) + (fnd (file-name-nondirectory f))) + (if (and fd-p recurse + (not (string-match "^\\.+$" fnd)) + (if skip-dir (not (string-match skip-dir fnd)) t)) + (org-e-publish-get-base-files-1 + f recurse match skip-file skip-dir) + (unless (or fd-p ;; this is a directory + (and skip-file (string-match skip-file fnd)) + (not (file-exists-p (file-truename f))) + (not (string-match match fnd))) + + (pushnew f org-e-publish-temp-files))))) + (if org-sitemap-requested + (sort (directory-files base-dir t (unless recurse match)) + 'org-e-publish-compare-directory-files) + (directory-files base-dir t (unless recurse match))))) + +(defun org-e-publish-get-base-files (project &optional exclude-regexp) + "Return a list of all files in PROJECT. +If EXCLUDE-REGEXP is set, this will be used to filter out +matching filenames." + (let* ((project-plist (cdr project)) + (base-dir (file-name-as-directory + (plist-get project-plist :base-directory))) + (include-list (plist-get project-plist :include)) + (recurse (plist-get project-plist :recursive)) + (extension (or (plist-get project-plist :base-extension) "org")) + ;; sitemap-... variables are dynamically scoped for + ;; org-e-publish-compare-directory-files: + (org-sitemap-requested + (plist-get project-plist :auto-sitemap)) + (sitemap-filename + (or (plist-get project-plist :sitemap-filename) "sitemap.org")) + (org-sitemap-sort-folders + (if (plist-member project-plist :sitemap-sort-folders) + (plist-get project-plist :sitemap-sort-folders) + org-e-publish-sitemap-sort-folders)) + (org-sitemap-sort-files + (cond ((plist-member project-plist :sitemap-sort-files) + (plist-get project-plist :sitemap-sort-files)) + ;; For backward compatibility: + ((plist-member project-plist :sitemap-alphabetically) + (if (plist-get project-plist :sitemap-alphabetically) + 'alphabetically nil)) + (t org-e-publish-sitemap-sort-files))) + (org-sitemap-ignore-case + (if (plist-member project-plist :sitemap-ignore-case) + (plist-get project-plist :sitemap-ignore-case) + org-e-publish-sitemap-sort-ignore-case)) + (match (if (eq extension 'any) "^[^\\.]" + (concat "^[^\\.].*\\.\\(" extension "\\)$")))) + ;; Make sure `org-sitemap-sort-folders' has an accepted value + (unless (memq org-sitemap-sort-folders '(first last)) + (setq org-sitemap-sort-folders nil)) + + (setq org-e-publish-temp-files nil) + (if org-sitemap-requested + (pushnew (expand-file-name (concat base-dir sitemap-filename)) + org-e-publish-temp-files)) + (org-e-publish-get-base-files-1 base-dir recurse match + ;; FIXME distinguish exclude regexp + ;; for skip-file and skip-dir? + exclude-regexp exclude-regexp) + (mapc (lambda (f) + (pushnew + (expand-file-name (concat base-dir f)) + org-e-publish-temp-files)) + include-list) + org-e-publish-temp-files)) + +(defun org-e-publish-get-project-from-filename (filename &optional up) + "Return the project that FILENAME belongs to." + (let* ((filename (expand-file-name filename)) + project-name) + + (catch 'p-found + (dolist (prj org-e-publish-project-alist) + (unless (plist-get (cdr prj) :components) + ;; [[info:org:Selecting%20files]] shows how this is supposed to work: + (let* ((r (plist-get (cdr prj) :recursive)) + (b (expand-file-name (file-name-as-directory + (plist-get (cdr prj) :base-directory)))) + (x (or (plist-get (cdr prj) :base-extension) "org")) + (e (plist-get (cdr prj) :exclude)) + (i (plist-get (cdr prj) :include)) + (xm (concat "^" b (if r ".+" "[^/]+") "\\.\\(" x "\\)$"))) + (when + (or (and i + (member filename + (mapcar (lambda (file) + (expand-file-name file b)) + i))) + (and (not (and e (string-match e filename))) + (string-match xm filename))) + (setq project-name (car prj)) + (throw 'p-found project-name)))))) + (when up + (dolist (prj org-e-publish-project-alist) + (if (member project-name (plist-get (cdr prj) :components)) + (setq project-name (car prj))))) + (assoc project-name org-e-publish-project-alist))) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Pluggable publishing back-end functions + +(defun org-e-publish-org-to (backend filename extension plist pub-dir) + "Publish an Org file to a specified back-end. + +BACKEND is a symbol representing the back-end used for +transcoding. FILENAME is the filename of the Org file to be +published. EXTENSION is the extension used for the output +string, with the leading dot. PLIST is the property list for the +given project. PUB-DIR is the publishing directory. + +Return output file name." + (unless (file-exists-p pub-dir) (make-directory pub-dir t)) + ;; Check if a buffer visiting FILENAME is already open. + (let* ((visitingp (find-buffer-visiting filename)) + (work-buffer (or visitingp (find-file-noselect filename)))) + (prog1 (with-current-buffer work-buffer + (let ((output-file + (org-export-output-file-name extension nil pub-dir)) + (body-p (plist-get plist :body-only))) + (org-export-to-file + backend output-file nil nil body-p + ;; Install `org-e-publish-collect-index' in parse tree + ;; filters. It isn't dependent on `:makeindex', since + ;; we want to keep it up-to-date in cache anyway. + (org-combine-plists + plist `(:filter-parse-tree + (org-e-publish-collect-index + ,@(plist-get plist :filter-parse-tree))))))) + ;; Remove opened buffer in the process. + (unless visitingp (kill-buffer work-buffer))))) + +(defvar project-plist) +(defun org-e-publish-org-to-latex (plist filename pub-dir) + "Publish an Org file to LaTeX. + +FILENAME is the filename of the Org file to be published. PLIST +is the property list for the given project. PUB-DIR is the +publishing directory. + +Return output file name." + (org-e-publish-org-to 'e-latex filename ".tex" plist pub-dir)) + +(defun org-e-publish-org-to-pdf (plist filename pub-dir) + "Publish an Org file to PDF \(via LaTeX). + +FILENAME is the filename of the Org file to be published. PLIST +is the property list for the given project. PUB-DIR is the +publishing directory. + +Return output file name." + (org-e-latex-compile + (org-e-publish-org-to 'e-latex filename ".tex" plist pub-dir))) + +(defun org-e-publish-org-to-html (plist filename pub-dir) + "Publish an org file to HTML. + +FILENAME is the filename of the Org file to be published. PLIST +is the property list for the given project. PUB-DIR is the +publishing directory. + +Return output file name." + (org-e-publish-org-to 'e-html filename ".html" plist pub-dir)) + +;; TODO: Not implemented yet. +;; (defun org-e-publish-org-to-org (plist filename pub-dir) +;; "Publish an org file to HTML. +;; +;; FILENAME is the filename of the Org file to be published. PLIST +;; is the property list for the given project. PUB-DIR is the +;; publishing directory. +;; +;; Return output file name." +;; (org-e-publish-org-to "org" plist filename pub-dir)) + +(defun org-e-publish-org-to-ascii (plist filename pub-dir) + "Publish an Org file to ASCII. + +FILENAME is the filename of the Org file to be published. PLIST +is the property list for the given project. PUB-DIR is the +publishing directory. + +Return output file name." + (org-e-publish-org-to + 'e-ascii filename ".txt" `(:ascii-charset ascii ,@plist) pub-dir)) + +(defun org-e-publish-org-to-latin1 (plist filename pub-dir) + "Publish an Org file to Latin-1. + +FILENAME is the filename of the Org file to be published. PLIST +is the property list for the given project. PUB-DIR is the +publishing directory. + +Return output file name." + (org-e-publish-org-to + 'e-ascii filename ".txt" `(:ascii-charset latin1 ,@plist) pub-dir)) + +(defun org-e-publish-org-to-utf8 (plist filename pub-dir) + "Publish an org file to UTF-8. + +FILENAME is the filename of the Org file to be published. PLIST +is the property list for the given project. PUB-DIR is the +publishing directory. + +Return output file name." + (org-e-publish-org-to + 'e-ascii filename ".txt" `(:ascii-charset utf-8 ,@plist) pub-dir)) + +(defun org-e-publish-attachment (plist filename pub-dir) + "Publish a file with no transformation of any kind. + +FILENAME is the filename of the Org file to be published. PLIST +is the property list for the given project. PUB-DIR is the +publishing directory. + +Return output file name." + (unless (file-directory-p pub-dir) + (make-directory pub-dir t)) + (or (equal (expand-file-name (file-name-directory filename)) + (file-name-as-directory (expand-file-name pub-dir))) + (copy-file filename + (expand-file-name (file-name-nondirectory filename) pub-dir) + t))) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Publishing files, sets of files, and indices + +(defun org-e-publish-file (filename &optional project no-cache) + "Publish file FILENAME from PROJECT. +If NO-CACHE is not nil, do not initialize org-e-publish-cache and +write it to disk. This is needed, since this function is used to +publish single files, when entire projects are published. +See `org-e-publish-projects'." + (let* ((project + (or project + (or (org-e-publish-get-project-from-filename filename) + (error "File %s not part of any known project" + (abbreviate-file-name filename))))) + (project-plist (cdr project)) + (ftname (expand-file-name filename)) + (publishing-function + (or (plist-get project-plist :publishing-function) + 'org-e-publish-org-to-ascii)) + (base-dir + (file-name-as-directory + (expand-file-name + (or (plist-get project-plist :base-directory) + (error "Project %s does not have :base-directory defined" + (car project)))))) + (pub-dir + (file-name-as-directory + (file-truename + (or (eval (plist-get project-plist :publishing-directory)) + (error "Project %s does not have :publishing-directory defined" + (car project)))))) + tmp-pub-dir) + + (unless no-cache (org-e-publish-initialize-cache (car project))) + + (setq tmp-pub-dir + (file-name-directory + (concat pub-dir + (and (string-match (regexp-quote base-dir) ftname) + (substring ftname (match-end 0)))))) + (if (listp publishing-function) + ;; allow chain of publishing functions + (mapc (lambda (f) + (when (org-e-publish-needed-p + filename pub-dir f tmp-pub-dir base-dir) + (funcall f project-plist filename tmp-pub-dir) + (org-e-publish-update-timestamp filename pub-dir f base-dir))) + publishing-function) + (when (org-e-publish-needed-p + filename pub-dir publishing-function tmp-pub-dir base-dir) + (funcall publishing-function project-plist filename tmp-pub-dir) + (org-e-publish-update-timestamp + filename pub-dir publishing-function base-dir))) + (unless no-cache (org-e-publish-write-cache-file)))) + +(defun org-e-publish-projects (projects) + "Publish all files belonging to the PROJECTS alist. +If `:auto-sitemap' is set, publish the sitemap too. If +`:makeindex' is set, also produce a file theindex.org." + (mapc + (lambda (project) + ;; Each project uses its own cache file: + (org-e-publish-initialize-cache (car project)) + (let* ((project-plist (cdr project)) + (exclude-regexp (plist-get project-plist :exclude)) + (sitemap-p (plist-get project-plist :auto-sitemap)) + (sitemap-filename (or (plist-get project-plist :sitemap-filename) + "sitemap.org")) + (sitemap-function (or (plist-get project-plist :sitemap-function) + 'org-e-publish-org-sitemap)) + (org-sitemap-date-format + (or (plist-get project-plist :sitemap-date-format) + org-e-publish-sitemap-date-format)) + (org-sitemap-file-entry-format + (or (plist-get project-plist :sitemap-file-entry-format) + org-e-publish-sitemap-file-entry-format)) + (preparation-function + (plist-get project-plist :preparation-function)) + (completion-function (plist-get project-plist :completion-function)) + (files (org-e-publish-get-base-files project exclude-regexp)) file) + (when preparation-function (run-hooks 'preparation-function)) + (if sitemap-p (funcall sitemap-function project sitemap-filename)) + (dolist (file files) (org-e-publish-file file project t)) + (when (plist-get project-plist :makeindex) + (org-e-publish-index-generate-theindex + project (plist-get project-plist :base-directory)) + (org-e-publish-file + (expand-file-name + "theindex.org" (plist-get project-plist :base-directory)) + project t)) + (when completion-function (run-hooks 'completion-function)) + (org-e-publish-write-cache-file))) + (org-e-publish-expand-projects projects))) + +(defun org-e-publish-org-sitemap (project &optional sitemap-filename) + "Create a sitemap of pages in set defined by PROJECT. +Optionally set the filename of the sitemap with SITEMAP-FILENAME. +Default for SITEMAP-FILENAME is 'sitemap.org'." + (let* ((project-plist (cdr project)) + (dir (file-name-as-directory + (plist-get project-plist :base-directory))) + (localdir (file-name-directory dir)) + (indent-str (make-string 2 ?\ )) + (exclude-regexp (plist-get project-plist :exclude)) + (files (nreverse + (org-e-publish-get-base-files project exclude-regexp))) + (sitemap-filename (concat dir (or sitemap-filename "sitemap.org"))) + (sitemap-title (or (plist-get project-plist :sitemap-title) + (concat "Sitemap for project " (car project)))) + (sitemap-style (or (plist-get project-plist :sitemap-style) + 'tree)) + (sitemap-sans-extension + (plist-get project-plist :sitemap-sans-extension)) + (visiting (find-buffer-visiting sitemap-filename)) + (ifn (file-name-nondirectory sitemap-filename)) + file sitemap-buffer) + (with-current-buffer (setq sitemap-buffer + (or visiting (find-file sitemap-filename))) + (erase-buffer) + (insert (concat "#+TITLE: " sitemap-title "\n\n")) + (while (setq file (pop files)) + (let ((fn (file-name-nondirectory file)) + (link (file-relative-name file dir)) + (oldlocal localdir)) + (when sitemap-sans-extension + (setq link (file-name-sans-extension link))) + ;; sitemap shouldn't list itself + (unless (equal (file-truename sitemap-filename) + (file-truename file)) + (if (eq sitemap-style 'list) + (message "Generating list-style sitemap for %s" sitemap-title) + (message "Generating tree-style sitemap for %s" sitemap-title) + (setq localdir (concat (file-name-as-directory dir) + (file-name-directory link))) + (unless (string= localdir oldlocal) + (if (string= localdir dir) + (setq indent-str (make-string 2 ?\ )) + (let ((subdirs + (split-string + (directory-file-name + (file-name-directory + (file-relative-name localdir dir))) "/")) + (subdir "") + (old-subdirs (split-string + (file-relative-name oldlocal dir) "/"))) + (setq indent-str (make-string 2 ?\ )) + (while (string= (car old-subdirs) (car subdirs)) + (setq indent-str (concat indent-str (make-string 2 ?\ ))) + (pop old-subdirs) + (pop subdirs)) + (dolist (d subdirs) + (setq subdir (concat subdir d "/")) + (insert (concat indent-str " + " d "\n")) + (setq indent-str (make-string + (+ (length indent-str) 2) ?\ ))))))) + ;; This is common to 'flat and 'tree + (let ((entry + (org-e-publish-format-file-entry + org-sitemap-file-entry-format file project-plist)) + (regexp "\\(.*\\)\\[\\([^][]+\\)\\]\\(.*\\)")) + (cond ((string-match-p regexp entry) + (string-match regexp entry) + (insert (concat indent-str " + " (match-string 1 entry) + "[[file:" link "][" + (match-string 2 entry) + "]]" (match-string 3 entry) "\n"))) + (t + (insert (concat indent-str " + [[file:" link "][" + entry + "]]\n")))))))) + (save-buffer)) + (or visiting (kill-buffer sitemap-buffer)))) + +(defun org-e-publish-format-file-entry (fmt file project-plist) + (format-spec fmt + `((?t . ,(org-e-publish-find-title file t)) + (?d . ,(format-time-string org-sitemap-date-format + (org-e-publish-find-date file))) + (?a . ,(or (plist-get project-plist :author) user-full-name))))) + +(defun org-e-publish-find-title (file &optional reset) + "Find the title of FILE in project." + (or + (and (not reset) (org-e-publish-cache-get-file-property file :title nil t)) + (let* ((visiting (find-buffer-visiting file)) + (buffer (or visiting (find-file-noselect file))) + title) + (with-current-buffer buffer + (org-mode) + (setq title + (or (plist-get (org-export-get-environment) :title) + (file-name-nondirectory (file-name-sans-extension file))))) + (unless visiting (kill-buffer buffer)) + (org-e-publish-cache-set-file-property file :title title) + title))) + +(defun org-e-publish-find-date (file) + "Find the date of FILE in project. +If FILE provides a #+date keyword use it else use the file +system's modification time. + +It returns time in `current-time' format." + (let* ((visiting (find-buffer-visiting file)) + (file-buf (or visiting (find-file-noselect file nil))) + (date (plist-get + (with-current-buffer file-buf + (org-mode) + (org-export--get-inbuffer-options)) + :date))) + (unless visiting (kill-buffer file-buf)) + (if date (org-time-string-to-time date) + (when (file-exists-p file) + (nth 5 (file-attributes file)))))) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Interactive publishing functions + +;;;###autoload +(defalias 'org-e-publish-project 'org-e-publish) + +;;;###autoload +(defun org-e-publish (project &optional force) + "Publish PROJECT." + (interactive + (list + (assoc (org-icompleting-read + "Publish project: " + org-e-publish-project-alist nil t) + org-e-publish-project-alist) + current-prefix-arg)) + (setq org-e-publish-initial-buffer (current-buffer)) + (save-window-excursion + (let* ((org-e-publish-use-timestamps-flag + (if force nil org-e-publish-use-timestamps-flag))) + (org-e-publish-projects + (if (stringp project) + ;; If this function is called in batch mode, project is + ;; still a string here. + (list (assoc project org-e-publish-project-alist)) + (list project)))))) + +;;;###autoload +(defun org-e-publish-all (&optional force) + "Publish all projects. +With prefix argument, remove all files in the timestamp +directory and force publishing all files." + (interactive "P") + (when force (org-e-publish-remove-all-timestamps)) + (save-window-excursion + (let ((org-e-publish-use-timestamps-flag + (if force nil org-e-publish-use-timestamps-flag))) + (org-e-publish-projects org-e-publish-project-alist)))) + + +;;;###autoload +(defun org-e-publish-current-file (&optional force) + "Publish the current file. +With prefix argument, force publish the file." + (interactive "P") + (save-window-excursion + (let ((org-e-publish-use-timestamps-flag + (if force nil org-e-publish-use-timestamps-flag))) + (org-e-publish-file (buffer-file-name (buffer-base-buffer)))))) + +;;;###autoload +(defun org-e-publish-current-project (&optional force) + "Publish the project associated with the current file. +With a prefix argument, force publishing of all files in +the project." + (interactive "P") + (save-window-excursion + (let ((project (org-e-publish-get-project-from-filename + (buffer-file-name (buffer-base-buffer)) 'up)) + (org-e-publish-use-timestamps-flag + (if force nil org-e-publish-use-timestamps-flag))) + (if project (org-e-publish project) + (error "File %s is not part of any known project" + (buffer-file-name (buffer-base-buffer))))))) + + + +;;; Index generation + +(defun org-e-publish-collect-index (tree backend info) + "Update index for a file with TREE in cache. + +BACKEND is the back-end being used for transcoding. INFO is +a plist containing publishing options. + +The index relative to current file is stored as an alist. An +association has the following shape: \(TERM FILE-NAME PARENT), +where TERM is the indexed term, as a string, FILE-NAME is the +original full path of the file where the term in encountered, and +PARENT is the headline element containing the original index +keyword." + (org-e-publish-cache-set-file-property + (plist-get info :input-file) :index + (delete-dups + (org-element-map + tree 'keyword + (lambda (k) + (when (string= (downcase (org-element-property :key k)) + "index") + (let ((index (org-element-property :value k)) + (parent (org-export-get-parent-headline k))) + (list index (plist-get info :input-file) parent)))) + info))) + ;; Return parse-tree to avoid altering output. + tree) + +(defun org-e-publish-index-generate-theindex (project directory) + "Retrieve full index from cache and build \"theindex.org\". +PROJECT is the project the index relates to. DIRECTORY is the +publishing directory." + (let ((all-files (org-e-publish-get-base-files + project (plist-get (cdr project) :exclude))) + full-index) + ;; Compile full index. + (mapc + (lambda (file) + (let ((index (org-e-publish-cache-get-file-property file :index))) + (dolist (term index) + (unless (member term full-index) (push term full-index))))) + all-files) + ;; Sort it alphabetically. + (setq full-index + (sort full-index (lambda (a b) (string< (downcase (car a)) + (downcase (car b)))))) + ;; Fill "theindex.org". + (with-temp-buffer + (insert "#+TITLE: Index\n#+OPTIONS: num:nil author:nil\n") + (let ((current-letter nil) (last-entry nil)) + (dolist (idx full-index) + (let* ((entry (org-split-string (car idx) "!")) + (letter (upcase (substring (car entry) 0 1))) + ;; Transform file into a path relative to publishing + ;; directory. + (file (file-relative-name + (nth 1 idx) + (plist-get (cdr project) :base-directory)))) + ;; Check if another letter has to be inserted. + (unless (string= letter current-letter) + (insert (format "* %s\n" letter))) + ;; Compute the first difference between last entry and + ;; current one: it tells the level at which new items + ;; should be added. + (let* ((rank (loop for n from 0 to (length entry) + unless (equal (nth n entry) (nth n last-entry)) + return n)) + (len (length (nthcdr rank entry)))) + ;; For each term after the first difference, create + ;; a new sub-list with the term as body. Moreover, + ;; linkify the last term. + (dotimes (n len) + (insert + (concat + (make-string (* (+ rank n) 2) ? ) " - " + (if (not (= (1- len) n)) (nth (+ rank n) entry) + ;; Last term: Link it to TARGET, if possible. + (let ((target (nth 2 idx))) + (format + "[[%s][%s]]" + ;; Destination. + (cond + ((not target) (format "file:%s" file)) + ((let ((id (org-element-property :id target))) + (and id (format "id:%s" id)))) + ((let ((id (org-element-property :custom-id target))) + (and id (format "file:%s::#%s" file id)))) + (t (format "file:%s::*%s" file + (org-element-property :raw-value target)))) + ;; Description. + (car (last entry))))) + "\n")))) + (setq current-letter letter last-entry entry)))) + ;; Write index. + (write-file (expand-file-name "theindex.org" directory))))) + + + +;;; Caching functions + +(defun org-e-publish-write-cache-file (&optional free-cache) + "Write `org-e-publish-cache' to file. +If FREE-CACHE, empty the cache." + (unless org-e-publish-cache + (error "`org-e-publish-write-cache-file' called, but no cache present")) + + (let ((cache-file (org-e-publish-cache-get ":cache-file:"))) + (unless cache-file + (error "Cannot find cache-file name in `org-e-publish-write-cache-file'")) + (with-temp-file cache-file + (let (print-level print-length) + (insert "(setq org-e-publish-cache (make-hash-table :test 'equal :weakness nil :size 100))\n") + (maphash (lambda (k v) + (insert + (format (concat "(puthash %S " + (if (or (listp v) (symbolp v)) + "'" "") + "%S org-e-publish-cache)\n") k v))) + org-e-publish-cache))) + (when free-cache (org-e-publish-reset-cache)))) + +(defun org-e-publish-initialize-cache (project-name) + "Initialize the projects cache if not initialized yet and return it." + + (unless project-name + (error "Cannot initialize `org-e-publish-cache' without projects name in `org-e-publish-initialize-cache'")) + + (unless (file-exists-p org-e-publish-timestamp-directory) + (make-directory org-e-publish-timestamp-directory t)) + (unless (file-directory-p org-e-publish-timestamp-directory) + (error "Org publish timestamp: %s is not a directory" + org-e-publish-timestamp-directory)) + + (unless (and org-e-publish-cache + (string= (org-e-publish-cache-get ":project:") project-name)) + (let* ((cache-file + (concat + (expand-file-name org-e-publish-timestamp-directory) + project-name ".cache")) + (cexists (file-exists-p cache-file))) + + (when org-e-publish-cache (org-e-publish-reset-cache)) + + (if cexists (load-file cache-file) + (setq org-e-publish-cache + (make-hash-table :test 'equal :weakness nil :size 100)) + (org-e-publish-cache-set ":project:" project-name) + (org-e-publish-cache-set ":cache-file:" cache-file)) + (unless cexists (org-e-publish-write-cache-file nil)))) + org-e-publish-cache) + +(defun org-e-publish-reset-cache () + "Empty org-e-publish-cache and reset it nil." + (message "%s" "Resetting org-e-publish-cache") + (when (hash-table-p org-e-publish-cache) + (clrhash org-e-publish-cache)) + (setq org-e-publish-cache nil)) + +(defun org-e-publish-cache-file-needs-publishing + (filename &optional pub-dir pub-func base-dir) + "Check the timestamp of the last publishing of FILENAME. +Non-nil if the file needs publishing. The function also checks +if any included files have been more recently published, so that +the file including them will be republished as well." + (unless org-e-publish-cache + (error + "`org-e-publish-cache-file-needs-publishing' called, but no cache present")) + (let* ((case-fold-search t) + (key (org-e-publish-timestamp-filename filename pub-dir pub-func)) + (pstamp (org-e-publish-cache-get key)) + (visiting (find-buffer-visiting filename)) + included-files-ctime buf) + + (when (equal (file-name-extension filename) "org") + (setq buf (find-file (expand-file-name filename))) + (with-current-buffer buf + (goto-char (point-min)) + (while (re-search-forward + "^#\\+INCLUDE:[ \t]+\"\\([^\t\n\r\"]*\\)\"[ \t]*.*$" nil t) + (let* ((included-file (expand-file-name (match-string 1)))) + (add-to-list + 'included-files-ctime + (org-e-publish-cache-ctime-of-src included-file base-dir) + t)))) + ;; FIXME: don't kill current buffer. + (unless visiting (kill-buffer buf))) + (if (null pstamp) t + (let ((ctime (org-e-publish-cache-ctime-of-src filename base-dir))) + (or (< pstamp ctime) + (when included-files-ctime + (not (null (delq nil (mapcar (lambda(ct) (< ctime ct)) + included-files-ctime)))))))))) + +(defun org-e-publish-cache-set-file-property + (filename property value &optional project-name) + "Set the VALUE for a PROPERTY of file FILENAME in publishing cache to VALUE. +Use cache file of PROJECT-NAME. If the entry does not exist, it +will be created. Return VALUE." + ;; Evtl. load the requested cache file: + (if project-name (org-e-publish-initialize-cache project-name)) + (let ((pl (org-e-publish-cache-get filename))) + (if pl (progn (plist-put pl property value) value) + (org-e-publish-cache-get-file-property + filename property value nil project-name)))) + +(defun org-e-publish-cache-get-file-property + (filename property &optional default no-create project-name) + "Return the value for a PROPERTY of file FILENAME in publishing cache. +Use cache file of PROJECT-NAME. Return the value of that PROPERTY +or DEFAULT, if the value does not yet exist. If the entry will +be created, unless NO-CREATE is not nil." + ;; Evtl. load the requested cache file: + (if project-name (org-e-publish-initialize-cache project-name)) + (let ((pl (org-e-publish-cache-get filename)) retval) + (if pl + (if (plist-member pl property) + (setq retval (plist-get pl property)) + (setq retval default)) + ;; no pl yet: + (unless no-create + (org-e-publish-cache-set filename (list property default))) + (setq retval default)) + retval)) + +(defun org-e-publish-cache-get (key) + "Return the value stored in `org-e-publish-cache' for key KEY. +Returns nil, if no value or nil is found, or the cache does not +exist." + (unless org-e-publish-cache + (error "`org-e-publish-cache-get' called, but no cache present")) + (gethash key org-e-publish-cache)) + +(defun org-e-publish-cache-set (key value) + "Store KEY VALUE pair in `org-e-publish-cache'. +Returns value on success, else nil." + (unless org-e-publish-cache + (error "`org-e-publish-cache-set' called, but no cache present")) + (puthash key value org-e-publish-cache)) + +(defun org-e-publish-cache-ctime-of-src (f base-dir) + "Get the FILENAME ctime as an integer." + (let ((attr (file-attributes + (expand-file-name (or (file-symlink-p f) f) base-dir)))) + (+ (lsh (car (nth 5 attr)) 16) + (cadr (nth 5 attr))))) + + +(provide 'org-e-publish) + +;;; org-e-publish.el ends here diff --git a/contrib/lisp/org-e-texinfo.el b/contrib/lisp/org-e-texinfo.el new file mode 100644 index 0000000..a19139f --- /dev/null +++ b/contrib/lisp/org-e-texinfo.el @@ -0,0 +1,1844 @@ +;;; org-e-texinfo.el --- Texinfo Back-End For Org Export Engine + +;; Copyright (C) 2012 Jonathan Leech-Pepin +;; Author: Jonathan Leech-Pepin +;; Keywords: outlines, hypermedia, calendar, wp +;; +;; This file is not part of GNU Emacs. +;; +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: +;; +;; This library implements a Texinfo back-end for Org generic +;; exporter. +;; +;; To test it, run +;; +;; M-: (org-export-to-buffer 'e-texinfo "*Test e-texinfo*") RET +;; +;; in an org-mode buffer then switch to the buffer to see the Texinfo +;; export. See contrib/lisp/org-export.el for more details on how +;; this exporter works. +;; +;; It introduces eight new buffer keywords: "TEXINFO_CLASS", +;; "TEXINFO_FILENAME", "TEXINFO_HEADER", "TEXINFO_DIR_CATEGORY", +;; "TEXINFO_DIR_TITLE", "TEXINFO_DIR_DESC" "SUBTITLE" and "SUBAUTHOR". +;; +;; To include inline code snippets (for example for generating @kbd{} +;; and @key{} commands), the following export-snippet keys are +;; accepted: +;; +;; info +;; e-info +;; e-texinfo +;; +;; You can add them for export snippets via any of the below: +;; +;; (add-to-list 'org-export-snippet-translation-alist +;; '("e-info" . "e-texinfo")) +;; (add-to-list 'org-export-snippet-translation-alist +;; '("e-texinfo" . "e-texinfo")) +;; (add-to-list 'org-export-snippet-translation-alist +;; '("info" . "e-texinfo")) +;; + +;;; Code: + +(eval-when-compile (require 'cl)) +(require 'org-export) + +(defvar orgtbl-exp-regexp) + + +;;; Define Back-End + +(defvar org-e-texinfo-translate-alist + '((babel-call . org-e-texinfo-babel-call) + (bold . org-e-texinfo-bold) + (center-block . org-e-texinfo-center-block) + (clock . org-e-texinfo-clock) + (code . org-e-texinfo-code) + (comment . org-e-texinfo-comment) + (comment-block . org-e-texinfo-comment-block) + (drawer . org-e-texinfo-drawer) + (dynamic-block . org-e-texinfo-dynamic-block) + (entity . org-e-texinfo-entity) + (example-block . org-e-texinfo-example-block) + (export-block . org-e-texinfo-export-block) + (export-snippet . org-e-texinfo-export-snippet) + (fixed-width . org-e-texinfo-fixed-width) + (footnote-definition . org-e-texinfo-footnote-definition) + (footnote-reference . org-e-texinfo-footnote-reference) + (headline . org-e-texinfo-headline) + (horizontal-rule . org-e-texinfo-horizontal-rule) + (inline-babel-call . org-e-texinfo-inline-babel-call) + (inline-src-block . org-e-texinfo-inline-src-block) + (inlinetask . org-e-texinfo-inlinetask) + (italic . org-e-texinfo-italic) + (item . org-e-texinfo-item) + (keyword . org-e-texinfo-keyword) + (latex-environment . org-e-texinfo-latex-environment) + (latex-fragment . org-e-texinfo-latex-fragment) + (line-break . org-e-texinfo-line-break) + (link . org-e-texinfo-link) + (macro . org-e-texinfo-macro) + (paragraph . org-e-texinfo-paragraph) + (plain-list . org-e-texinfo-plain-list) + (plain-text . org-e-texinfo-plain-text) + (planning . org-e-texinfo-planning) + (property-drawer . org-e-texinfo-property-drawer) + (quote-block . org-e-texinfo-quote-block) + (quote-section . org-e-texinfo-quote-section) + (radio-target . org-e-texinfo-radio-target) + (section . org-e-texinfo-section) + (special-block . org-e-texinfo-special-block) + (src-block . org-e-texinfo-src-block) + (statistics-cookie . org-e-texinfo-statistics-cookie) + (strike-through . org-e-texinfo-strike-through) + (subscript . org-e-texinfo-subscript) + (superscript . org-e-texinfo-superscript) + (table . org-e-texinfo-table) + (table-cell . org-e-texinfo-table-cell) + (table-row . org-e-texinfo-table-row) + (target . org-e-texinfo-target) + (template . org-e-texinfo-template) + (timestamp . org-e-texinfo-timestamp) + (underline . org-e-texinfo-underline) + (verbatim . org-e-texinfo-verbatim) + (verse-block . org-e-texinfo-verse-block)) + "Alist between element or object types and translators.") + +(defconst org-e-texinfo-options-alist + '((:texinfo-filename "TEXINFO_FILENAME" nil org-e-texinfo-filename t) + (:texinfo-class "TEXINFO_CLASS" nil org-e-texinfo-default-class t) + (:texinfo-header "TEXINFO_HEADER" nil nil newline) + (:subtitle "SUBTITLE" nil nil newline) + (:subauthor "SUBAUTHOR" nil nil newline) + (:texinfo-dircat "TEXINFO_DIR_CATEGORY" nil nil t) + (:texinfo-dirtitle "TEXINFO_DIR_TITLE" nil nil t) + (:texinfo-dirdesc "TEXINFO_DIR_DESC" nil nil t)) + "Alist between Texinfo export properties and ways to set them. +See `org-export-options-alist' for more information on the +structure of the values. + +SUBAUTHOR and SUBTITLE are for the inclusion of additional author +and title information beyond the initial variable.") + +(defconst org-e-texinfo-filters-alist + '((:filter-headline . org-e-texinfo-filter-section-blank-lines) + (:filter-section . org-e-texinfo-filter-section-blank-lines)) + "Alist between filters keywords and back-end specific filters. + See `org-export-filters-alist' for more information") + + +;;; Internal Variables + +;; Add TEXINFO to the list of available of available export blocks. +(add-to-list 'org-element-block-name-alist + '("TEXINFO" . org-element-export-block-parser)) + +;;; User Configurable Variables + +(defgroup org-export-e-texinfo nil + "Options for exporting Org mode files to Texinfo." + :tag "Org Export Texinfo" + :group 'org-export) + +;;; Preamble + +(defcustom org-e-texinfo-filename nil + "Default filename for texinfo output." + :group 'org-export-e-texinfo + :type '(string :tag "Export Filename")) + +(defcustom org-e-texinfo-default-class "info" + "The default Texinfo class." + :group 'org-export-e-texinfo + :type '(string :tag "Texinfo class")) + +(defcustom org-e-texinfo-classes + '(("info" + "\\input texinfo @c -*- texinfo -*-" + ("@chapter %s" . "@unnumbered %s") + ("@section %s" . "@unnumberedsec %s") + ("@subsection %s" . "@unnumberedsubsec %s") + ("@subsubsection %s" . "@unnumberedsubsubsec %s"))) + "Alist of Texinfo classes and associated header and structure. +If #+Texinfo_CLASS is set in the buffer, use its value and the +associated information. Here is the structure of each cell: + + \(class-name + header-string + \(numbered-section . unnumbered-section\) + ...\) + +The sectioning structure +------------------------ + +The sectioning structure of the class is given by the elements +following the header string. For each sectioning level, a number +of strings is specified. A %s formatter is mandatory in each +section string and will be replaced by the title of the section. + +Instead of a list of sectioning commands, you can also specify +a function name. That function will be called with two +parameters, the \(reduced) level of the headline, and a predicate +non-nil when the headline should be numbered. It must return +a format string in which the section title will be added." + :group 'org-export-e-texinfo + :type '(repeat + (list (string :tag "Texinfo class") + (string :tag "Texinfo header") + (repeat :tag "Levels" :inline t + (choice + (cons :tag "Heading" + (string :tag " numbered") + (string :tag "unnumbered")) + (function :tag "Hook computing sectioning")))))) + +;;; Headline + +(defcustom org-e-texinfo-format-headline-function nil + "Function to format headline text. + +This function will be called with 5 arguments: +TODO the todo keyword (string or nil). +TODO-TYPE the type of todo (symbol: `todo', `done', nil) +PRIORITY the priority of the headline (integer or nil) +TEXT the main headline text (string). +TAGS the tags as a list of strings (list of strings or nil). + +The function result will be used in the section format string. + +As an example, one could set the variable to the following, in +order to reproduce the default set-up: + +\(defun org-e-texinfo-format-headline (todo todo-type priority text tags) + \"Default format function for an headline.\" + \(concat (when todo + \(format \"\\\\textbf{\\\\textsc{\\\\textsf{%s}}} \" todo)) + \(when priority + \(format \"\\\\framebox{\\\\#%c} \" priority)) + text + \(when tags + \(format \"\\\\hfill{}\\\\textsc{%s}\" + \(mapconcat 'identity tags \":\"))))" + :group 'org-export-e-texinfo + :type 'function) + + +;;; Footnotes +;; +;; Footnotes are inserted directly + +;;; Timestamps + +(defcustom org-e-texinfo-active-timestamp-format "@emph{%s}" + "A printf format string to be applied to active timestamps." + :group 'org-export-e-texinfo + :type 'string) + +(defcustom org-e-texinfo-inactive-timestamp-format "@emph{%s}" + "A printf format string to be applied to inactive timestamps." + :group 'org-export-e-texinfo + :type 'string) + +(defcustom org-e-texinfo-diary-timestamp-format "@emph{%s}" + "A printf format string to be applied to diary timestamps." + :group 'org-export-e-texinfo + :type 'string) + +;;; Links + +(defcustom org-e-texinfo-link-with-unknown-path-format "@indicateurl{%s}" + "Format string for links with unknown path type." + :group 'org-export-e-texinfo + :type 'string) + +;;; Tables + +(defcustom org-e-texinfo-tables-verbatim nil + "When non-nil, tables are exported verbatim." + :group 'org-export-e-texinfo + :type 'boolean) + +(defcustom org-e-texinfo-table-scientific-notation "%s\\,(%s)" + "Format string to display numbers in scientific notation. +The format should have \"%s\" twice, for mantissa and exponent +\(i.e. \"%s\\\\times10^{%s}\"). + +When nil, no transformation is made." + :group 'org-export-e-texinfo + :type '(choice + (string :tag "Format string") + (const :tag "No formatting"))) + +(defcustom org-e-texinfo-def-table-markup "@samp" + "Default setting for @table environments.") + +;;; Text markup + +(defcustom org-e-texinfo-text-markup-alist '((bold . "@strong{%s}") + (code . code) + (italic . "@emph{%s}") + (verbatim . verb) + (comment . "@c %s")) + "Alist of Texinfo expressions to convert text markup. + +The key must be a symbol among `bold', `italic' and `comment'. +The value is a formatting string to wrap fontified text with. + +Value can also be set to the following symbols: `verb' and +`code'. For the former, Org will use \"@verb\" to +create a format string and select a delimiter character that +isn't in the string. For the latter, Org will use \"@code\" +to typeset and try to protect special characters. + +If no association can be found for a given markup, text will be +returned as-is." + :group 'org-export-e-texinfo + :type 'alist + :options '(bold code italic verbatim comment)) + +;;; Drawers + +(defcustom org-e-texinfo-format-drawer-function nil + "Function called to format a drawer in Texinfo code. + +The function must accept two parameters: + NAME the drawer name, like \"LOGBOOK\" + CONTENTS the contents of the drawer. + +The function should return the string to be exported. + +For example, the variable could be set to the following function +in order to mimic default behaviour: + +\(defun org-e-texinfo-format-drawer-default \(name contents\) + \"Format a drawer element for Texinfo export.\" + contents\)" + :group 'org-export-e-texinfo + :type 'function) + +;;; Inlinetasks + +(defcustom org-e-texinfo-format-inlinetask-function nil + "Function called to format an inlinetask in Texinfo code. + +The function must accept six parameters: + TODO the todo keyword, as a string + TODO-TYPE the todo type, a symbol among `todo', `done' and nil. + PRIORITY the inlinetask priority, as a string + NAME the inlinetask name, as a string. + TAGS the inlinetask tags, as a list of strings. + CONTENTS the contents of the inlinetask, as a string. + +The function should return the string to be exported. + +For example, the variable could be set to the following function +in order to mimic default behaviour: + +\(defun org-e-texinfo-format-inlinetask \(todo type priority name tags contents\) +\"Format an inline task element for Texinfo export.\" + \(let ((full-title + \(concat + \(when todo + \(format \"@strong{%s} \" todo)) + \(when priority (format \"#%c \" priority)) + title + \(when tags + \(format \":%s:\" + \(mapconcat 'identity tags \":\"))))) + \(format (concat \"@center %s\n\n\" + \"%s\" + \"\n\")) + full-title contents))" + :group 'org-export-e-texinfo + :type 'function) + +;;; Src blocks +;; +;; Src Blocks are example blocks, except for LISP + +;;; Plain text + +(defcustom org-e-texinfo-quotes + '(("quotes" + ("\\(\\s-\\|[[(]\\|^\\)\"" . "``") + ("\\(\\S-\\)\"" . "''") + ("\\(\\s-\\|(\\|^\\)'" . "`"))) + "Alist for quotes to use when converting english double-quotes. + +The CAR of each item in this alist is the language code. +The CDR of each item in this alist is a list of three CONS: +- the first CONS defines the opening quote; +- the second CONS defines the closing quote; +- the last CONS defines single quotes. + +For each item in a CONS, the first string is a regexp +for allowed characters before/after the quote, the second +string defines the replacement string for this quote." + :group 'org-export-e-texinfo + :type '(list + (cons :tag "Opening quote" + (string :tag "Regexp for char before") + (string :tag "Replacement quote ")) + (cons :tag "Closing quote" + (string :tag "Regexp for char after ") + (string :tag "Replacement quote ")) + (cons :tag "Single quote" + (string :tag "Regexp for char before") + (string :tag "Replacement quote ")))) + +;;; Compilation + +(defcustom org-e-texinfo-info-process + '("makeinfo %f") + "Commands to process a texinfo file to an INFO file. +This is list of strings, each of them will be given to the shell +as a command. %f in the command will be replaced by the full +file name, %b by the file base name \(i.e without extension) and +%o by the base directory of the file." + :group 'org-export-texinfo + :type '(repeat :tag "Shell command sequence" + (string :tag "Shell command"))) + + +;;; Internal Functions + +(defun org-e-texinfo-filter-section-blank-lines (headline back-end info) + "Filter controlling number of blank lines after a section." + (let ((blanks (make-string 2 ?\n))) + (replace-regexp-in-string "\n\\(?:\n[ \t]*\\)*\\'" blanks headline))) + +(defun org-e-texinfo--find-copying (info) + "Retrieve the headline identified by the property :copying:. + +INFO is the plist containing the export options and tree. It is +used to find and extract the single desired headline. This +cannot be treated as a standard headline since it must be +inserted in a specific location." + (let (copying) + (org-element-map (plist-get info :parse-tree) 'headline + (lambda (copy) + (when (org-element-property :copying copy) + (push copy copying))) info 't) + ;; Retrieve the single entry + (car copying))) + +(defun org-e-texinfo--find-verb-separator (s) + "Return a character not used in string S. +This is used to choose a separator for constructs like \\verb." + (let ((ll "~,./?;':\"|!@#%^&-_=+abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ<>()[]{}")) + (loop for c across ll + when (not (string-match (regexp-quote (char-to-string c)) s)) + return (char-to-string c)))) + +(defun org-e-texinfo--make-option-string (options) + "Return a comma separated string of keywords and values. +OPTIONS is an alist where the key is the options keyword as +a string, and the value a list containing the keyword value, or +nil." + (mapconcat (lambda (pair) + (concat (first pair) + (when (> (length (second pair)) 0) + (concat "=" (second pair))))) + options + ",")) + +(defun org-e-texinfo--quotation-marks (text info) + "Export quotation marks using ` and ' as the markers. +TEXT is a string containing quotation marks to be replaced. INFO +is a plist used as a communication channel." + (mapc (lambda(l) + (let ((start 0)) + (while (setq start (string-match (car l) text start)) + (let ((new-quote (concat (match-string 1 text) (cdr l)))) + (setq text (replace-match new-quote t t text)))))) + (cdr org-e-texinfo-quotes)) + text) + +(defun org-e-texinfo--text-markup (text markup) + "Format TEXT depending on MARKUP text markup. +See `org-e-texinfo-text-markup-alist' for details." + (let ((fmt (cdr (assq markup org-e-texinfo-text-markup-alist)))) + (cond + ;; No format string: Return raw text. + ((not fmt) text) + ((eq 'verb fmt) + (let ((separator (org-e-texinfo--find-verb-separator text))) + (concat "@verb{" separator text separator "}"))) + ((eq 'code fmt) + (let ((start 0) + (rtn "") + char) + (while (string-match "[@{}]" text) + (setq char (match-string 0 text)) + (if (> (match-beginning 0) 0) + (setq rtn (concat rtn (substring text 0 (match-beginning 0))))) + (setq text (substring text (1+ (match-beginning 0)))) + (setq char (concat "@" char) + rtn (concat rtn char))) + (setq text (concat rtn text) + fmt "@code{%s}") + (format fmt text))) + ;; Else use format string. + (t (format fmt text))))) + +;;; Headline sanitizing + +(defun org-e-texinfo--sanitize-headline (headline info) + "Remove all formatting from the text of a headline for use in + node and menu listing." + (mapconcat 'identity + (org-e-texinfo--sanitize-headline-contents headline info) " ")) + +(defun org-e-texinfo--sanitize-headline-contents (headline info) + "Retrieve the content of the headline. + +Any content that can contain further formatting is checked +recursively, to ensure that nested content is also properly +retrieved." + (loop for contents in headline append + (cond + ;; already a string + ((stringp contents) + (list (replace-regexp-in-string " $" "" contents))) + ;; Is exported as-is (value) + ((org-element-map contents '(verbatim code) + (lambda (value) + (org-element-property :value value)))) + ;; Has content and recurse into the content + ((org-element-contents contents) + (org-e-texinfo--sanitize-headline-contents + (org-element-contents contents) info))))) + +;;; Menu sanitizing + +(defun org-e-texinfo--sanitize-menu (title) + "Remove invalid characters from TITLE for use in menus and +nodes. + +Based on TEXINFO specifications, the following must be removed: +@ { } ( ) : . ," + (replace-regexp-in-string "[@{}():,.]" "" title)) + +;;; Content sanitizing + +(defun org-e-texinfo--sanitize-content (text) + "Ensure characters are properly escaped when used in headlines or blocks. + +Escape characters are: @ { }" + (replace-regexp-in-string "\\\([@{}]\\\)" "@\\1" text)) + +;;; Menu creation + +(defun org-e-texinfo--build-menu (tree level info &optional detailed) + "Create the @menu/@end menu information from TREE at headline +level LEVEL. + +TREE contains the parse-tree to work with, either of the entire +document or of a specific parent headline. LEVEL indicates what +level of headlines to look at when generating the menu. INFO is +a plist containing contextual information. + +Detailed determines whether to build a single level of menu, or +recurse into all children as well." + (let ((menu (org-e-texinfo--generate-menu-list tree level info)) + output text-menu) + (cond + (detailed + ;; Looping is done within the menu generation. + (setq text-menu (org-e-texinfo--generate-detailed menu level info))) + (t + (setq text-menu (org-e-texinfo--generate-menu-items menu info)))) + (when text-menu + (setq output (org-e-texinfo--format-menu text-menu)) + (mapconcat 'identity output "\n")))) + +(defun org-e-texinfo--generate-detailed (menu level info) + "Generate a detailed listing of all subheadings within MENU starting at LEVEL. + +MENU is the parse-tree to work with. LEVEL is the starting level +for the menu headlines and from which recursion occurs. INFO is +a plist containing contextual information." + (when level + (let ((max-depth (plist-get info :headline-levels))) + (when (> max-depth level) + (loop for headline in menu append + (let* ((title (org-e-texinfo--menu-headlines headline info)) + ;; Create list of menu entries for the next level + (sublist (org-e-texinfo--generate-menu-list + headline (1+ level) info)) + ;; Generate the menu items for that level. If + ;; there are none omit that heading completely, + ;; otherwise join the title to it's related entries. + (submenu (if (org-e-texinfo--generate-menu-items sublist info) + (append (list title) + (org-e-texinfo--generate-menu-items sublist info)) + 'nil)) + ;; Start the process over the next level down. + (recursion (org-e-texinfo--generate-detailed sublist (1+ level) info))) + (setq recursion (append submenu recursion)) + recursion)))))) + +(defun org-e-texinfo--generate-menu-list (tree level info) + "Generate the list of headlines that are within a given level +of the tree for further formatting. + +TREE is the parse-tree containing the headlines. LEVEL is the +headline level to generate a list of. INFO is a plist holding +contextual information." + (let (seq) + (org-element-map + tree 'headline + (lambda (head) + (when (org-element-property :level head) + (if (and (eq level (org-element-property :level head)) + ;; Do not take note of footnotes or copying headlines + (not (org-element-property :copying head)) + (not (org-element-property :footnote-section-p head))) + (push head seq))))) + ;; Return the list of headlines (reverse to have in actual order) + (reverse seq))) + +(defun org-e-texinfo--generate-menu-items (items info) + "Generate a list of headline information from the listing ITEMS. + +ITEMS is a list of the headlines to be converted into entries. +INFO is a plist containing contextual information. + +Returns a list containing the following information from each +headline: length, title, description. This is used to format the +menu using `org-e-texinfo--format-menu'." + (loop for headline in items collect + (let* ((title (org-e-texinfo--sanitize-menu + (org-e-texinfo--sanitize-headline + (org-element-property :title headline) info))) + (descr (org-export-data + (org-element-property :description headline) info)) + (len (length title)) + (output (list len title descr))) + output))) + +(defun org-e-texinfo--menu-headlines (headline info) + "Retrieve the title from HEADLINE. + +INFO is a plist holding contextual information. + +Return the headline as a list of (length title description) with +length of -1 and nil description. This is used in +`org-e-texinfo--format-menu' to identify headlines as opposed to +entries." + (let ((title (org-export-data + (org-element-property :title headline) info))) + (list -1 title 'nil))) + +(defun org-e-texinfo--format-menu (text-menu) + "Format the TEXT-MENU items to be properly printed in the menu. + +Each entry in the menu should be provided as (length title +description). + +Headlines in the detailed menu are given length -1 to ensure they +are never confused with other entries. They also have no +description. + +Other menu items are output as: + Title:: description + +With the spacing between :: and description based on the length +of the longest menu entry." + + (let* ((lengths (mapcar 'car text-menu)) + (max-length (apply 'max lengths)) + output) + (setq output + (mapcar (lambda (name) + (let* ((title (nth 1 name)) + (desc (nth 2 name)) + (length (nth 0 name))) + (if (> length -1) + (concat "* " title ":: " + (make-string + (- (+ 3 max-length) length) + ?\s) + (if desc + (concat desc))) + (concat "\n" title "\n")))) + text-menu)) + output)) + +;;; Template + +(defun org-e-texinfo-template (contents info) + "Return complete document string after Texinfo conversion. +CONTENTS is the transcoded contents string. INFO is a plist +holding export options." + (let* ((title (org-export-data (plist-get info :title) info)) + (info-filename (or (plist-get info :texinfo-filename) + (file-name-nondirectory + (org-export-output-file-name ".info")))) + (author (org-export-data (plist-get info :author) info)) + (texinfo-header (plist-get info :texinfo-header)) + (subtitle (plist-get info :subtitle)) + (subauthor (plist-get info :subauthor)) + (class (plist-get info :texinfo-class)) + (header (nth 1 (assoc class org-e-texinfo-classes))) + (copying (org-e-texinfo--find-copying info)) + (dircat (plist-get info :texinfo-dircat)) + (dirtitle (plist-get info :texinfo-dirtitle)) + (dirdesc (plist-get info :texinfo-dirdesc)) + ;; Spacing to align description (column 32 - 3 for `* ' and + ;; `.' in text. + (dirspacing (- 29 (length dirtitle))) + (menu (org-e-texinfo-make-menu info 'main)) + (detail-menu (org-e-texinfo-make-menu info 'detailed))) + (concat + ;; Header + header "\n" + "@c %**start of header\n" + ;; Filename and Title + "@setfilename " info-filename "\n" + "@settitle " title "\n" + "\n\n" + "@c Version and Contact Info\n" + "@set AUTHOR " author "\n" + + ;; Additional Header Options set by `#+TEXINFO_HEADER + (if texinfo-header + (concat "\n" + texinfo-header + "\n")) + + "@c %**end of header\n" + "@finalout\n" + "\n\n" + + ;; Copying + "@copying\n" + ;; Only export the content of the headline, do not need the + ;; initial headline. + (org-export-data (nth 2 copying) info) + "@end copying\n" + "\n\n" + + ;; Info directory information + ;; Only supply if both title and category are provided + (if (and dircat dirtitle) + (concat "@dircategory " dircat "\n" + "@direntry\n" + "* " dirtitle "." + (make-string dirspacing ?\s) + dirdesc "\n" + "@end direntry\n")) + "\n\n" + + ;; Title + "@titlepage\n" + "@title " title "\n\n" + (if subtitle + (concat "@subtitle " subtitle "\n")) + "@author " author "\n" + (if subauthor + (concat subauthor "\n")) + "\n" + "@c The following two commands start the copyright page.\n" + "@page\n" + "@vskip 0pt plus 1filll\n" + "@insertcopying\n" + "@end titlepage\n\n" + "@c Output the table of contents at the beginning.\n" + "@contents\n\n" + + ;; Configure Top Node when not for Tex + "@ifnottex\n" + "@node Top\n" + "@top " title " Manual\n" + "@insertcopying\n" + "@end ifnottex\n\n" + + ;; Do not output menus if they are empty + (if menu + ;; Menu + (concat "@menu\n" + menu + "\n\n" + ;; Detailed Menu + (if detail-menu + (concat "@detailmenu\n" + " --- The Detailed Node Listing ---\n" + detail-menu + "\n\n" + "@end detailmenu\n")) + "@end menu\n")) + "\n\n" + + ;; Document's body. + contents + "\n" + ;; Creator. + (let ((creator-info (plist-get info :with-creator))) + (cond + ((not creator-info) "") + ((eq creator-info 'comment) + (format "@c %s\n" (plist-get info :creator))) + (t (concat (plist-get info :creator) "\n")))) + ;; Document end. + "\n@bye"))) + + + +;;; Transcode Functions + +;;; Babel Call +;; +;; Babel Calls are ignored. + +;;; Bold + +(defun org-e-texinfo-bold (bold contents info) + "Transcode BOLD from Org to Texinfo. +CONTENTS is the text with bold markup. INFO is a plist holding +contextual information." + (org-e-texinfo--text-markup contents 'bold)) + +;;; Center Block +;; +;; Center blocks are ignored + +;;; Clock + +(defun org-e-texinfo-clock (clock contents info) + "Transcode a CLOCK element from Org to Texinfo. +CONTENTS is nil. INFO is a plist holding contextual +information." + (concat + "@noindent" + (format "@strong{%s} " org-clock-string) + (format org-e-texinfo-inactive-timestamp-format + (concat (org-translate-time (org-element-property :value clock)) + (let ((time (org-element-property :time clock))) + (and time (format " (%s)" time))))) + "@*")) + +;;; Code + +(defun org-e-texinfo-code (code contents info) + "Transcode a CODE object from Org to Texinfo. +CONTENTS is nil. INFO is a plist used as a communication +channel." + (org-e-texinfo--text-markup (org-element-property :value code) 'code)) + +;;; Comment + +(defun org-e-texinfo-comment (comment contents info) + "Transcode a COMMENT object from Org to Texinfo. +CONTENTS is the text in the comment. INFO is a plist holding +contextual information." + (org-e-texinfo--text-markup (org-element-property :value comment) 'comment)) + +;;; Comment Block + +(defun org-e-texinfo-comment-block (comment-block contents info) + "Transcode a COMMENT-BLOCK object from Org to Texinfo. +CONTENTS is the text within the block. INFO is a plist holding +contextual information." + (format "@ignore\n%s@end ignore" (org-element-property :value comment-block))) + +;;; Drawer + +(defun org-e-texinfo-drawer (drawer contents info) + "Transcode a DRAWER element from Org to Texinfo. +CONTENTS holds the contents of the block. INFO is a plist +holding contextual information." + (let* ((name (org-element-property :drawer-name drawer)) + (output (if (functionp org-e-texinfo-format-drawer-function) + (funcall org-e-texinfo-format-drawer-function + name contents) + ;; If there's no user defined function: simply + ;; display contents of the drawer. + contents))) + output)) + +;;; Dynamic Block + +(defun org-e-texinfo-dynamic-block (dynamic-block contents info) + "Transcode a DYNAMIC-BLOCK element from Org to Texinfo. +CONTENTS holds the contents of the block. INFO is a plist +holding contextual information. See `org-export-data'." + contents) + +;;; Entity + +(defun org-e-texinfo-entity (entity contents info) + "Transcode an ENTITY object from Org to Texinfo. +CONTENTS are the definition itself. INFO is a plist holding +contextual information." + (let ((ent (org-element-property :latex entity))) + (if (org-element-property :latex-math-p entity) (format "@math{%s}" ent) ent))) + +;;; Example Block + +(defun org-e-texinfo-example-block (example-block contents info) + "Transcode an EXAMPLE-BLOCK element from Org to Texinfo. +CONTENTS is nil. INFO is a plist holding contextual +information." + (format "@verbatim\n%s@end verbatim" + (org-export-format-code-default example-block info))) + +;;; Export Block + +(defun org-e-texinfo-export-block (export-block contents info) + "Transcode a EXPORT-BLOCK element from Org to Texinfo. +CONTENTS is nil. INFO is a plist holding contextual information." + (when (string= (org-element-property :type export-block) "TEXINFO") + (org-remove-indentation (org-element-property :value export-block)))) + +;;; Export Snippet + +(defun org-e-texinfo-export-snippet (export-snippet contents info) + "Transcode a EXPORT-SNIPPET object from Org to Texinfo. +CONTENTS is nil. INFO is a plist holding contextual information." + (when (eq (org-export-snippet-backend export-snippet) 'e-texinfo) + (org-element-property :value export-snippet))) + +;;; Fixed Width + +(defun org-e-texinfo-fixed-width (fixed-width contents info) + "Transcode a FIXED-WIDTH element from Org to Texinfo. +CONTENTS is nil. INFO is a plist holding contextual information." + (format "@example\n%s\n@end example" + (org-remove-indentation + (org-e-texinfo--sanitize-content + (org-element-property :value fixed-width))))) + +;;; Footnote Definition +;; +;; Footnote Definitions are ignored. + +;;; Footnote Reference +;; + +(defun org-e-texinfo-footnote-reference (footnote contents info) + "Create a footnote reference for FOOTNOTE. + +FOOTNOTE is the footnote to define. CONTENTS is nil. INFO is a +plist holding contextual information." + (let ((def (org-export-get-footnote-definition footnote info))) + (format "@footnote{%s}" + (org-trim (org-export-data def info))))) + +;;; Headline + +(defun org-e-texinfo-headline (headline contents info) + "Transcode an HEADLINE element from Org to Texinfo. +CONTENTS holds the contents of the headline. INFO is a plist +holding contextual information." + (let* ((class (plist-get info :texinfo-class)) + (level (org-export-get-relative-level headline info)) + (numberedp (org-export-numbered-headline-p headline info)) + (class-sectionning (assoc class org-e-texinfo-classes)) + ;; Find the index type, if any + (index (org-element-property :index headline)) + ;; Retrieve headline text + (text (org-e-texinfo--sanitize-headline + (org-element-property :title headline) info)) + ;; Create node info, to insert it before section formatting. + (node (format "@node %s\n" + (org-e-texinfo--sanitize-menu + (replace-regexp-in-string "%" "%%" text)))) + ;; Menus must be generated with first child, otherwise they + ;; will not nest properly + (menu (let* ((first (org-export-first-sibling-p headline info)) + (parent (org-export-get-parent-headline headline)) + (title (org-e-texinfo--sanitize-headline + (org-element-property :title parent) info)) + heading listing + (tree (plist-get info :parse-tree))) + (if first + (org-element-map + (plist-get info :parse-tree) 'headline + (lambda (ref) + (if (member title (org-element-property :title ref)) + (push ref heading))) + info 't)) + (setq listing (org-e-texinfo--build-menu + (car heading) level info)) + (if listing + (setq listing (replace-regexp-in-string + "%" "%%" listing) + listing (format + "\n@menu\n%s\n@end menu\n\n" listing)) + 'nil))) + ;; Section formatting will set two placeholders: one for the + ;; title and the other for the contents. + (section-fmt + (let ((sec (if (and (symbolp (nth 2 class-sectionning)) + (fboundp (nth 2 class-sectionning))) + (funcall (nth 2 class-sectionning) level numberedp) + (nth (1+ level) class-sectionning)))) + (cond + ;; No section available for that LEVEL. + ((not sec) nil) + ;; Section format directly returned by a function. + ((stringp sec) sec) + ;; (numbered-section . unnumbered-section) + ((not (consp (cdr sec))) + ;; If an index, always unnumbered + (if index + (concat menu node (cdr sec) "\n%s") + ;; Otherwise number as needed. + (concat menu node + (funcall + (if numberedp #'car #'cdr) sec) "\n%s")))))) + (todo + (and (plist-get info :with-todo-keywords) + (let ((todo (org-element-property :todo-keyword headline))) + (and todo (org-export-data todo info))))) + (todo-type (and todo (org-element-property :todo-type headline))) + (tags (and (plist-get info :with-tags) + (org-export-get-tags headline info))) + (priority (and (plist-get info :with-priority) + (org-element-property :priority headline))) + ;; Create the headline text along with a no-tag version. The + ;; latter is required to remove tags from table of contents. + (full-text (org-e-texinfo--sanitize-content + (if (functionp org-e-texinfo-format-headline-function) + ;; User-defined formatting function. + (funcall org-e-texinfo-format-headline-function + todo todo-type priority text tags) + ;; Default formatting. + (concat + (when todo + (format "@strong{%s} " todo)) + (when priority (format "@emph{#%s} " priority)) + text + (when tags + (format ":%s:" + (mapconcat 'identity tags ":"))))))) + (full-text-no-tag + (org-e-texinfo--sanitize-content + (if (functionp org-e-texinfo-format-headline-function) + ;; User-defined formatting function. + (funcall org-e-texinfo-format-headline-function + todo todo-type priority text nil) + ;; Default formatting. + (concat + (when todo (format "@strong{%s} " todo)) + (when priority (format "@emph{#%c} " priority)) + text)))) + (pre-blanks + (make-string (org-element-property :pre-blank headline) 10))) + (cond + ;; Case 1: This is a footnote section: ignore it. + ((org-element-property :footnote-section-p headline) nil) + ;; Case 2: This is the `copying' section: ignore it + ;; This is used elsewhere. + ((org-element-property :copying headline) nil) + ;; Case 3: An index. If it matches one of the known indexes, + ;; print it as such following the contents, otherwise + ;; print the contents and leave the index up to the user. + (index + (format + section-fmt full-text + (concat pre-blanks contents "\n" + (if (member index '("cp" "fn" "ky" "pg" "tp" "vr")) + (concat "@printindex " index))))) + ;; Case 4: This is a deep sub-tree: export it as a list item. + ;; Also export as items headlines for which no section + ;; format has been found. + ((or (not section-fmt) (org-export-low-level-p headline info)) + ;; Build the real contents of the sub-tree. + (let ((low-level-body + (concat + ;; If the headline is the first sibling, start a list. + (when (org-export-first-sibling-p headline info) + (format "@%s\n" (if numberedp 'enumerate 'itemize))) + ;; Itemize headline + "@item\n" full-text "\n" pre-blanks contents))) + ;; If headline is not the last sibling simply return + ;; LOW-LEVEL-BODY. Otherwise, also close the list, before any + ;; blank line. + (if (not (org-export-last-sibling-p headline info)) low-level-body + (replace-regexp-in-string + "[ \t\n]*\\'" + (format "\n@end %s" (if numberedp 'enumerate 'itemize)) + low-level-body)))) + ;; Case 5: Standard headline. Export it as a section. + (t + (cond + ((not (and tags (eq (plist-get info :with-tags) 'not-in-toc))) + ;; Regular section. Use specified format string. + (format (replace-regexp-in-string "%]" "%%]" section-fmt) full-text + (concat pre-blanks contents))) + ((string-match "\\`@\\(.*?\\){" section-fmt) + ;; If tags should be removed from table of contents, insert + ;; title without tags as an alternative heading in sectioning + ;; command. + (format (replace-match (concat (match-string 1 section-fmt) "[%s]") + nil nil section-fmt 1) + ;; Replace square brackets with parenthesis since + ;; square brackets are not supported in optional + ;; arguments. + (replace-regexp-in-string + "\\[" "(" + (replace-regexp-in-string + "\\]" ")" + full-text-no-tag)) + full-text + (concat pre-blanks contents))) + (t + ;; Impossible to add an alternative heading. Fallback to + ;; regular sectioning format string. + (format (replace-regexp-in-string "%]" "%%]" section-fmt) full-text + (concat pre-blanks contents)))))))) + +;;; Horizontal Rule +;; +;; Horizontal rules are ignored + +;;; Inline Babel Call +;; +;; Inline Babel Calls are ignored. + +;;; Inline Src Block + +(defun org-e-texinfo-inline-src-block (inline-src-block contents info) + "Transcode an INLINE-SRC-BLOCK element from Org to Texinfo. +CONTENTS holds the contents of the item. INFO is a plist holding +contextual information." + (let* ((code (org-element-property :value inline-src-block)) + (separator (org-e-texinfo--find-verb-separator code))) + (concat "@verb{" separator code separator "}"))) + +;;; Inlinetask + +(defun org-e-texinfo-inlinetask (inlinetask contents info) + "Transcode an INLINETASK element from Org to Texinfo. +CONTENTS holds the contents of the block. INFO is a plist +holding contextual information." + (let ((title (org-export-data (org-element-property :title inlinetask) info)) + (todo (and (plist-get info :with-todo-keywords) + (let ((todo (org-element-property :todo-keyword inlinetask))) + (and todo (org-export-data todo info))))) + (todo-type (org-element-property :todo-type inlinetask)) + (tags (and (plist-get info :with-tags) + (org-export-get-tags inlinetask info))) + (priority (and (plist-get info :with-priority) + (org-element-property :priority inlinetask)))) + ;; If `org-e-texinfo-format-inlinetask-function' is provided, call it + ;; with appropriate arguments. + (if (functionp org-e-texinfo-format-inlinetask-function) + (funcall org-e-texinfo-format-inlinetask-function + todo todo-type priority title tags contents) + ;; Otherwise, use a default template. + (let ((full-title + (concat + (when todo (format "@strong{%s} " todo)) + (when priority (format "#%c " priority)) + title + (when tags (format ":%s:" + (mapconcat 'identity tags ":")))))) + (format (concat "@center %s\n\n" + "%s" + "\n") + full-title contents))))) + +;;; Italic + +(defun org-e-texinfo-italic (italic contents info) + "Transcode ITALIC from Org to Texinfo. +CONTENTS is the text with italic markup. INFO is a plist holding +contextual information." + (org-e-texinfo--text-markup contents 'italic)) + +;;; Item + +(defun org-e-texinfo-item (item contents info) + "Transcode an ITEM element from Org to Texinfo. +CONTENTS holds the contents of the item. INFO is a plist holding +contextual information." + (let* ((tag (org-element-property :tag item)) + (desc (org-export-data tag info))) + (concat "\n@item " (if tag desc) "\n" + (org-trim contents) "\n"))) + +;;; Keyword + +(defun org-e-texinfo-keyword (keyword contents info) + "Transcode a KEYWORD element from Org to Texinfo. +CONTENTS is nil. INFO is a plist holding contextual information." + (let ((key (org-element-property :key keyword)) + (value (org-element-property :value keyword))) + (cond + ((string= key "TEXINFO") value) + ((string= key "CINDEX") (format "@cindex %s" value)) + ((string= key "FINDEX") (format "@findex %s" value)) + ((string= key "KINDEX") (format "@kindex %s" value)) + ((string= key "PINDEX") (format "@pindex %s" value)) + ((string= key "TINDEX") (format "@tindex %s" value)) + ((string= key "VINDEX") (format "@vindex %s" value))))) + +;;; Latex Environment +;; +;; Latex environments are ignored + +;;; Latex Fragment +;; +;; Latex fragments are ignored. + +;;; Line Break + +(defun org-e-texinfo-line-break (line-break contents info) + "Transcode a LINE-BREAK object from Org to Texinfo. +CONTENTS is nil. INFO is a plist holding contextual information." + "@*") + +;;; Link + +(defun org-e-texinfo-link (link desc info) + "Transcode a LINK object from Org to Texinfo. + +DESC is the description part of the link, or the empty string. +INFO is a plist holding contextual information. See +`org-export-data'." + (let* ((type (org-element-property :type link)) + (raw-path (org-element-property :path link)) + ;; Ensure DESC really exists, or set it to nil. + (desc (and (not (string= desc "")) desc)) + (path (cond + ((member type '("http" "https" "ftp")) + (concat type ":" raw-path)) + ((string= type "file") + (when (string-match "\\(.+\\)::.+" raw-path) + (setq raw-path (match-string 1 raw-path))) + (if (file-name-absolute-p raw-path) + (concat "file://" (expand-file-name raw-path)) + (concat "file://" raw-path))) + (t raw-path))) + (email (if (string= type "mailto") + (let ((text (replace-regexp-in-string + "@" "@@" raw-path))) + (concat text (if desc (concat "," desc)))))) + protocol) + (cond + ;; Links pointing to an headline: Find destination and build + ;; appropriate referencing command. + ((member type '("custom-id" "id")) + (let ((destination (org-export-resolve-id-link link info))) + (case (org-element-type destination) + ;; Id link points to an external file. + (plain-text + (if desc (format "@uref{file://%s,%s}" destination desc) + (format "@uref{file://%s}" destination))) + ;; LINK points to an headline. Use the headline as the NODE target + (headline + (format "@ref{%s}" + (org-export-data + (org-element-property :title destination) info))) + (otherwise + (let ((path (org-export-solidify-link-text path))) + (if (not desc) (format "@ref{%s}" path) + (format "@ref{%s,,%s}" path desc))))))) + ((member type '("fuzzy")) + (let ((destination (org-export-resolve-fuzzy-link link info))) + (case (org-element-type destination) + ;; Id link points to an external file. + (plain-text + (if desc (format "@uref{file://%s,%s}" destination desc) + (format "@uref{file://%s}" destination))) + ;; LINK points to an headline. Use the headline as the NODE target + (headline + (format "@ref{%s}" + (org-export-data + (org-element-property :title destination) info))) + (otherwise + (let ((path (org-export-solidify-link-text path))) + (if (not desc) (format "@ref{%s}" path) + (format "@ref{%s,,%s}" path desc))))))) + ;; Special case for email addresses + (email + (format "@email{%s}" email)) + ;; External link with a description part. + ((and path desc) (format "@uref{%s,%s}" path desc)) + ;; External link without a description part. + (path (format "@uref{%s}" path)) + ;; No path, only description. Try to do something useful. + (t (format org-e-texinfo-link-with-unknown-path-format desc))))) + +;;; Macro + +(defun org-e-texinfo-macro (macro contents info) + "Transcode a MACRO element from Org to Texinfo. +CONTENTS is nil. INFO is a plist holding contextual information." + ;; Use available tools. + (org-export-expand-macro macro info)) + +;;; Menu + +(defun org-e-texinfo-make-menu (info level) + "Create the menu for inclusion in the texifo document. + +INFO is the parsed buffer that contains the headlines. LEVEL +determines whether to make the main menu, or the detailed menu. + +This is only used for generating the primary menu. In-Node menus +are generated directly." + (let* ((parse (plist-get info :parse-tree)) + ;; Top determines level to build menu from, it finds the + ;; level of the first headline in the export. + (top (org-element-map + parse 'headline + (lambda (headline) + (org-element-property :level headline)) info 't))) + (cond + ;; Generate the main menu + ((eq level 'main) + (org-e-texinfo--build-menu parse top info)) + ;; Generate the detailed (recursive) menu + ((eq level 'detailed) + ;; Requires recursion + ;;(org-e-texinfo--build-detailed-menu parse top info) + (org-e-texinfo--build-menu parse top info 'detailed)) + ;; Otherwise do nothing + (t)))) + +;;; Paragraph + +(defun org-e-texinfo-paragraph (paragraph contents info) + "Transcode a PARAGRAPH element from Org to Texinfo. +CONTENTS is the contents of the paragraph, as a string. INFO is +the plist used as a communication channel." + contents) + +;;; Plain List + +(defun org-e-texinfo-plain-list (plain-list contents info) + "Transcode a PLAIN-LIST element from Org to Texinfo. +CONTENTS is the contents of the list. INFO is a plist holding +contextual information." + (let* ((attr (org-export-read-attribute :attr_texinfo plain-list)) + (indic (or (plist-get attr :indic) + org-e-texinfo-def-table-markup)) + (type (org-element-property :type plain-list)) + (table-type (or (plist-get attr :table-type) + "table")) + ;; Ensure valid texinfo table type. + (table-type (if (memq table-type '("table" "ftable" "vtable")) + table-type + "table")) + (list-type (cond + ((eq type 'ordered) "enumerate") + ((eq type 'unordered) "itemize") + ((eq type 'descriptive) table-type)))) + (format "@%s%s\n@end %s" + (if (eq type 'descriptive) + (concat list-type " " indic) + list-type) + contents + list-type))) + +;;; Plain Text + +(defun org-e-texinfo-plain-text (text info) + "Transcode a TEXT string from Org to Texinfo. +TEXT is the string to transcode. INFO is a plist holding +contextual information." + ;; LaTeX into @LaTeX{} and TeX into @TeX{} + (let ((case-fold-search nil) + (start 0)) + (while (string-match "\\(\\(?:La\\)?TeX\\)" text start) + (setq text (replace-match + (format "@%s{}" (match-string 1 text)) nil t text) + start (match-end 0)))) + ;; Handle quotation marks + (setq text (org-e-texinfo--quotation-marks text info)) + ;; Convert special strings. + (when (plist-get info :with-special-strings) + (while (string-match (regexp-quote "...") text) + (setq text (replace-match "@dots{}" nil t text)))) + ;; Handle break preservation if required. + (when (plist-get info :preserve-breaks) + (setq text (replace-regexp-in-string "\\(\\\\\\\\\\)?[ \t]*\n" " @*\n" + text))) + ;; Return value with @ { and } protected. + (org-e-texinfo--sanitize-content text)) + +;;; Planning + +(defun org-e-texinfo-planning (planning contents info) + "Transcode a PLANNING element from Org to Texinfo. +CONTENTS is nil. INFO is a plist holding contextual +information." + (concat + "@noindent" + (mapconcat + 'identity + (delq nil + (list + (let ((closed (org-element-property :closed planning))) + (when closed + (concat + (format "@strong%s} " org-closed-string) + (format org-e-texinfo-inactive-timestamp-format + (org-translate-time closed))))) + (let ((deadline (org-element-property :deadline planning))) + (when deadline + (concat + (format "@strong{%s} " org-deadline-string) + (format org-e-texinfo-active-timestamp-format + (org-translate-time deadline))))) + (let ((scheduled (org-element-property :scheduled planning))) + (when scheduled + (concat + (format "@strong{%s} " org-scheduled-string) + (format org-e-texinfo-active-timestamp-format + (org-translate-time scheduled))))))) + " ") + "@*")) + +;;; Property Drawer + +(defun org-e-texinfo-property-drawer (property-drawer contents info) + "Transcode a PROPERTY-DRAWER element from Org to Texinfo. +CONTENTS is nil. INFO is a plist holding contextual +information." + ;; The property drawer isn't exported but we want separating blank + ;; lines nonetheless. + "") + +;;; Quote Block + +(defun org-e-texinfo-quote-block (quote-block contents info) + "Transcode a QUOTE-BLOCK element from Org to Texinfo. +CONTENTS holds the contents of the block. INFO is a plist +holding contextual information." + (let* ((title (org-element-property :name quote-block)) + (start-quote (concat "@quotation" + (if title + (format " %s" title))))) + (format "%s\n%s@end quotation" start-quote contents))) + +;;; Quote Section + +(defun org-e-texinfo-quote-section (quote-section contents info) + "Transcode a QUOTE-SECTION element from Org to Texinfo. +CONTENTS is nil. INFO is a plist holding contextual information." + (let ((value (org-remove-indentation + (org-element-property :value quote-section)))) + (when value (format "@verbatim\n%s@end verbatim" value)))) + +;;; Radio Target + +(defun org-e-texinfo-radio-target (radio-target text info) + "Transcode a RADIO-TARGET object from Org to Texinfo. +TEXT is the text of the target. INFO is a plist holding +contextual information." + (format "@anchor{%s}%s" + (org-export-solidify-link-text + (org-element-property :value radio-target)) + text)) + +;;; Section + +(defun org-e-texinfo-section (section contents info) + "Transcode a SECTION element from Org to Texinfo. +CONTENTS holds the contents of the section. INFO is a plist +holding contextual information." + contents) + +;;; Special Block +;; +;; Are ignored at the moment + +;;; Src Block + +(defun org-e-texinfo-src-block (src-block contents info) + "Transcode a SRC-BLOCK element from Org to Texinfo. +CONTENTS holds the contents of the item. INFO is a plist holding +contextual information." + (let* ((lang (org-element-property :language src-block)) + (lisp-p (string-match-p "lisp" lang))) + (cond + ;; Case 1. Lisp Block + (lisp-p + (format "@lisp\n%s\n@end lisp" + (org-export-format-code-default src-block info))) + ;; Case 2. Other blocks + (t + (format "@example\n%s\n@end example" + (org-export-format-code-default src-block info)))))) + +;;; Statistics Cookie + +(defun org-e-texinfo-statistics-cookie (statistics-cookie contents info) + "Transcode a STATISTICS-COOKIE object from Org to Texinfo. +CONTENTS is nil. INFO is a plist holding contextual information." + (org-element-property :value statistics-cookie)) + +;;; Strike-Through +;; +;; Strikethrough is ignored + +;;; Subscript + +(defun org-e-texinfo-subscript (subscript contents info) + "Transcode a SUBSCRIPT object from Org to Texinfo. +CONTENTS is the contents of the object. INFO is a plist holding +contextual information." + (format "@math{_%s}" contents)) + +;;; Superscript + +(defun org-e-texinfo-superscript (superscript contents info) + "Transcode a SUPERSCRIPT object from Org to Texinfo. +CONTENTS is the contents of the object. INFO is a plist holding +contextual information." + (format "@math{^%s}" contents)) + +;;; Table +;; +;; `org-e-texinfo-table' is the entry point for table transcoding. It +;; takes care of tables with a "verbatim" attribute. Otherwise, it +;; delegates the job to either `org-e-texinfo-table--table.el-table' or +;; `org-e-texinfo-table--org-table' functions, depending of the type of +;; the table. +;; +;; `org-e-texinfo-table--align-string' is a subroutine used to build +;; alignment string for Org tables. + +(defun org-e-texinfo-table (table contents info) + "Transcode a TABLE element from Org to Texinfo. +CONTENTS is the contents of the table. INFO is a plist holding +contextual information." + (cond + ;; Case 1: verbatim table. + ((or org-e-texinfo-tables-verbatim + (let ((attr (mapconcat 'identity + (org-element-property :attr_latex table) + " "))) + (and attr (string-match "\\" attr)))) + (format "@verbatim \n%s\n@end verbatim" + ;; Re-create table, without affiliated keywords. + (org-trim + (org-element-interpret-data + `(table nil ,@(org-element-contents table)))))) + ;; Case 2: table.el table. Convert it using appropriate tools. + ((eq (org-element-property :type table) 'table.el) + (org-e-texinfo-table--table.el-table table contents info)) + ;; Case 3: Standard table. + (t (org-e-texinfo-table--org-table table contents info)))) + +(defun org-e-texinfo-table-column-widths (table info) + "Determine the largest table cell in each column to process alignment. + +TABLE is the table element to transcode. INFO is a plist used as +a communication channel." + (let* ((rows (org-element-map table 'table-row 'identity info)) + (collected (loop for row in rows collect + (org-element-map + row 'table-cell 'identity info))) + (number-cells (length (car collected))) + cells counts) + (loop for row in collected do + (push (mapcar (lambda (ref) + (let* ((start (org-element-property :contents-begin ref)) + (end (org-element-property :contents-end ref)) + (length (- end start))) + length)) row) cells)) + (setq cells (remove-if #'null cells)) + (push (loop for count from 0 to (- number-cells 1) collect + (loop for item in cells collect + (nth count item))) counts) + (mapconcat (lambda (size) + (make-string size ?a)) (mapcar (lambda (ref) + (apply 'max `,@ref)) (car counts)) + "} {"))) + +(defun org-e-texinfo-table--org-table (table contents info) + "Return appropriate Texinfo code for an Org table. + +TABLE is the table type element to transcode. CONTENTS is its +contents, as a string. INFO is a plist used as a communication +channel. + +This function assumes TABLE has `org' as its `:type' attribute." + (let* ((attr (org-export-read-attribute :attr_texinfo table)) + (col-width (plist-get attr :columns)) + (columns (if col-width + (format "@columnfractions %s" + col-width) + (format "{%s}" + (org-e-texinfo-table-column-widths + table info))))) + ;; Prepare the final format string for the table. + (cond + ;; Longtable. + ;; Others. + (t (concat + (format "@multitable %s\n%s@end multitable" + columns + contents)))))) + +(defun org-e-texinfo-table--table.el-table (table contents info) + "Returns nothing. + +Rather than return an invalid table, nothing is returned." + 'nil) + +;;; Table Cell + +(defun org-e-texinfo-table-cell (table-cell contents info) + "Transcode a TABLE-CELL element from Org to Texinfo. +CONTENTS is the cell contents. INFO is a plist used as +a communication channel." + (concat (if (and contents + org-e-texinfo-table-scientific-notation + (string-match orgtbl-exp-regexp contents)) + ;; Use appropriate format string for scientific + ;; notation. + (format org-e-texinfo-table-scientific-notation + (match-string 1 contents) + (match-string 2 contents)) + contents) + (when (org-export-get-next-element table-cell info) "\n@tab "))) + +;;; Table Row + +(defun org-e-texinfo-table-row (table-row contents info) + "Transcode a TABLE-ROW element from Org to Texinfo. +CONTENTS is the contents of the row. INFO is a plist used as +a communication channel." + ;; Rules are ignored since table separators are deduced from + ;; borders of the current row. + (when (eq (org-element-property :type table-row) 'standard) + (concat "@item " contents "\n"))) + +;;; Target + +(defun org-e-texinfo-target (target contents info) + "Transcode a TARGET object from Org to Texinfo. +CONTENTS is nil. INFO is a plist holding contextual +information." + (format "@anchor{%s}" + (org-export-solidify-link-text (org-element-property :value target)))) + +;;; Timestamp + +(defun org-e-texinfo-timestamp (timestamp contents info) + "Transcode a TIMESTAMP object from Org to Texinfo. +CONTENTS is nil. INFO is a plist holding contextual +information." + (let ((value (org-translate-time (org-element-property :value timestamp))) + (type (org-element-property :type timestamp))) + (cond ((memq type '(active active-range)) + (format org-e-texinfo-active-timestamp-format value)) + ((memq type '(inactive inactive-range)) + (format org-e-texinfo-inactive-timestamp-format value)) + (t (format org-e-texinfo-diary-timestamp-format value))))) + +;;; Underline +;; +;; Underline is ignored + +;;; Verbatim + +(defun org-e-texinfo-verbatim (verbatim contents info) + "Transcode a VERBATIM object from Org to Texinfo. +CONTENTS is nil. INFO is a plist used as a communication +channel." + (org-e-texinfo--text-markup (org-element-property :value verbatim) 'verbatim)) + +;;; Verse Block + +(defun org-e-texinfo-verse-block (verse-block contents info) + "Transcode a VERSE-BLOCK element from Org to Texinfo. +CONTENTS is verse block contents. INFO is a plist holding +contextual information." + ;; In a verse environment, add a line break to each newline + ;; character and change each white space at beginning of a line + ;; into a space of 1 em. Also change each blank line with + ;; a vertical space of 1 em. + (progn + (setq contents (replace-regexp-in-string + "^ *\\\\\\\\$" "\\\\vspace*{1em}" + (replace-regexp-in-string + "\\(\\\\\\\\\\)?[ \t]*\n" " \\\\\\\\\n" contents))) + (while (string-match "^[ \t]+" contents) + (let ((new-str (format "\\hspace*{%dem}" + (length (match-string 0 contents))))) + (setq contents (replace-match new-str nil t contents)))) + (format "\\begin{verse}\n%s\\end{verse}" contents))) + + +;;; Interactive functions + +(defun org-e-texinfo-export-to-texinfo + (&optional subtreep visible-only body-only ext-plist pub-dir) + "Export current buffer to a Texinfo file. + +If narrowing is active in the current buffer, only export its +narrowed part. + +If a region is active, export that region. + +When optional argument SUBTREEP is non-nil, export the sub-tree +at point, extracting information from the headline properties +first. + +When optional argument VISIBLE-ONLY is non-nil, don't export +contents of hidden elements. + +When optional argument BODY-ONLY is non-nil, only write code +between \"\\begin{document}\" and \"\\end{document}\". + +EXT-PLIST, when provided, is a property list with external +parameters overriding Org default settings, but still inferior to +file-local settings. + +When optional argument PUB-DIR is set, use it as the publishing +directory. + +Return output file's name." + (interactive) + (let ((outfile (org-export-output-file-name ".texi" subtreep pub-dir))) + (org-export-to-file + 'e-texinfo outfile subtreep visible-only body-only ext-plist))) + +(defun org-e-texinfo-export-to-info + (&optional subtreep visible-only body-only ext-plist pub-dir) + "Export current buffer to Texinfo then process through to INFO. + +If narrowing is active in the current buffer, only export its +narrowed part. + +If a region is active, export that region. + +When optional argument SUBTREEP is non-nil, export the sub-tree +at point, extracting information from the headline properties +first. + +When optional argument VISIBLE-ONLY is non-nil, don't export +contents of hidden elements. + +When optional argument BODY-ONLY is non-nil, only write code +between \"\\begin{document}\" and \"\\end{document}\". + +EXT-PLIST, when provided, is a property list with external +parameters overriding Org default settings, but still inferior to +file-local settings. + +When optional argument PUB-DIR is set, use it as the publishing +directory. + +Return INFO file's name." + (interactive) + (org-e-texinfo-compile + (org-e-texinfo-export-to-texinfo + subtreep visible-only body-only ext-plist pub-dir))) + +(defun org-e-texinfo-compile (texifile) + "Compile a texinfo file. + +TEXIFILE is the name of the file being compiled. Processing is +done through the command specified in `org-e-texinfo-info-process'. + +Return INFO file name or an error if it couldn't be produced." + (let* ((wconfig (current-window-configuration)) + (texifile (file-truename texifile)) + (base (file-name-sans-extension texifile)) + errors) + (message (format "Processing Texinfo file %s ..." texifile)) + (unwind-protect + (progn + (cond + ;; A function is provided: Apply it. + ((functionp org-e-texinfo-info-process) + (funcall org-e-texinfo-info-process (shell-quote-argument texifile))) + ;; A list is provided: Replace %b, %f and %o with appropriate + ;; values in each command before applying it. Output is + ;; redirected to "*Org INFO Texinfo Output*" buffer. + ((consp org-e-texinfo-info-process) + (let* ((out-dir (or (file-name-directory texifile) "./")) + (outbuf (get-buffer-create "*Org Info Texinfo Output*"))) + (mapc + (lambda (command) + (shell-command + (replace-regexp-in-string + "%b" (shell-quote-argument base) + (replace-regexp-in-string + "%f" (shell-quote-argument texifile) + (replace-regexp-in-string + "%o" (shell-quote-argument out-dir) command t t) t t) t t) + outbuf)) + org-e-texinfo-info-process) + ;; Collect standard errors from output buffer. + (setq errors (org-e-texinfo-collect-errors outbuf)))) + (t (error "No valid command to process to Info"))) + (let ((infofile (concat base ".info"))) + ;; Check for process failure. Provide collected errors if + ;; possible. + (if (not (file-exists-p infofile)) + (error (concat (format "INFO file %s wasn't produced" infofile) + (when errors (concat ": " errors)))) + ;; Else remove log files, when specified, and signal end of + ;; process to user, along with any error encountered. + (message (concat "Process completed" + (if (not errors) "." + (concat " with errors: " errors))))) + ;; Return output file name. + infofile)) + (set-window-configuration wconfig)))) + +(defun org-e-texinfo-collect-errors (buffer) + "Collect some kind of errors from \"makeinfo\" command output. + +BUFFER is the buffer containing output. + +Return collected error types as a string, or nil if there was +none." + (with-current-buffer buffer + (save-excursion + (goto-char (point-min)) + ;; Find final "makeinfo" run. + (when t + (let ((case-fold-search t) + (errors "")) + (when (save-excursion + (re-search-forward "perhaps incorrect sectioning?" nil t)) + (setq errors (concat errors " [incorrect sectionnng]"))) + (when (save-excursion + (re-search-forward "missing close brace" nil t)) + (setq errors (concat errors " [syntax error]"))) + (when (save-excursion + (re-search-forward "Unknown command" nil t)) + (setq errors (concat errors " [undefined @command]"))) + (when (save-excursion + (re-search-forward "No matching @end" nil t)) + (setq errors (concat errors " [block incomplete]"))) + (when (save-excursion + (re-search-forward "requires a sectioning" nil t)) + (setq errors (concat errors " [invalid section command]"))) + (when (save-excursion + (re-search-forward "\\[unexpected\]" nil t)) + (setq errors (concat errors " [unexpected error]"))) + (when (save-excursion + (re-search-forward "misplaced " nil t)) + (setq errors (concat errors " [syntax error]"))) + (and (org-string-nw-p errors) (org-trim errors))))))) + +(provide 'org-e-texinfo) +;;; org-e-texinfo.el ends here diff --git a/contrib/lisp/org-elisp-symbol.el b/contrib/lisp/org-elisp-symbol.el new file mode 100644 index 0000000..96b0e5d --- /dev/null +++ b/contrib/lisp/org-elisp-symbol.el @@ -0,0 +1,161 @@ +;;; org-elisp-symbol.el --- Org links to emacs-lisp symbols +;; +;; Copyright 2007-2012 Free Software Foundation, Inc. +;; +;; Author: bzg AT gnu DOT org +;; Version: 0.2 +;; Keywords: org, remember, lisp +;; URL: http://www.cognition.ens.fr/~guerry/u/org-elisp-symbol.el +;; +;; This file is not part of GNU Emacs. +;; +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, write to the Free Software +;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +;; +;;; Commentary: +;; +;; Org-mode already lets you store/insert links to emacs-lisp files, +;; just like any other file. This package lets you precisely link to +;; any emacs-lisp symbol and access useful information about the symbol. +;; +;; Here is the list of available properties when linking from a elisp-symbol: +;; +;; :name The symbol's name. +;; :stype The symbol's type (commandp, function, etc.) +;; :def The function used to set the symbol's value (defun, etc.) +;; :keys The keys associated with the command. +;; :args The arguments of the function. +;; :docstring The docstring of the symbol. +;; :doc The first line of the dostring. +;; :comment A comment line just above the sexp, if any. +;; :fixme A FIXME comment line just above the sexp, if any. +;; +;; Let's say we have a defun like this one: +;; +;; ;; FIXME update docstring +;; (defun org-export-latex-lists () +;; "Convert lists to LaTeX." +;; (goto-char (point-min)) +;; (while (re-search-forward org-export-latex-list-beginning-re nil t) +;; (beginning-of-line) +;; (insert (org-list-to-latex (org-list-parse-list t)) "\n"))) +;; +;; And a remember template like: +;; +;; (setq org-remember-templates +;; '((?s "* DEBUG `%:name' (%:args)\n\n%?\n\nFixme: %:fixme\n \ +;; Doc: \"%:doc\"\n\n%a"))) +;; +;; Then M-x `org-remember' on this sexp will produce this buffer: +;; +;; ===================================================================== +;; * DEBUG `org-export-latex-lists' () +;; +;; <== point +;; +;; Fixme: update the docstring +;; Doc: "Convert lists to LaTeX." +;; +;; [[file:~/path/file.el::defun%20my-func][Function: my-func]] +;; ===================================================================== +;; +;; Put this file into your load-path and the following into your ~/.emacs: +;; (require 'org-elisp-symbol) + +;;; Code: + +(provide 'org-elisp-symbol) + +(require 'org) + +(org-add-link-type "elisp-symbol" 'org-elisp-symbol-open) +(add-hook 'org-store-link-functions 'org-elisp-symbol-store-link) + +(defun org-elisp-symbol-open (path) + "Visit the emacs-lisp elisp-symbol at PATH." + (let* ((search (when (string-match "::\\(.+\\)\\'" path) + (match-string 1 path))) + (path (substring path 0 (match-beginning 0)))) + (org-open-file path t nil search))) + +(defun org-elisp-symbol-store-link () + "Store a link to an emacs-lisp elisp-symbol." + (when (eq major-mode 'emacs-lisp-mode) + (save-excursion + (or (looking-at "^(") (beginning-of-defun)) + (looking-at "^(\\([a-z]+\\) \\([^)\n ]+\\) ?\n?[ \t]*\\(?:(\\(.*\\))\\)?") + (let* ((end (save-excursion + (save-match-data + (end-of-defun) (point)))) + (def (match-string 1)) + (name (match-string 2)) + (sym-name (intern-soft name)) + (stype (cond ((commandp sym-name) "Command") + ((functionp sym-name) "Function") + ((user-variable-p sym-name) "User variable") + ((string= def "defvar") "Variable") + ((string= def "defmacro") "Macro") + ((string= def "defun") "Function or command") + (t "Symbol"))) + (args (if (match-string 3) + (mapconcat (lambda (a) (unless (string-match "^&" a) a)) + (split-string (match-string 3)) " ") + "no arg")) + (docstring (cond ((functionp sym-name) + (or (documentation sym-name) + "[no documentation]")) + ((string-match "[Vv]ariable" stype) + (documentation-property sym-name + 'variable-documentation)) + (t "no documentation"))) + (doc (and (string-match "^\\([^\n]+\\)$" docstring) + (match-string 1 docstring))) + (fixme (save-excursion + (beginning-of-defun) (end-of-defun) + (if (re-search-forward "^;+ ?FIXME[ :]*\\(.*\\)$" end t) + (match-string 1) "nothing to fix"))) + (comment (save-excursion + (beginning-of-defun) (end-of-defun) + (if (re-search-forward "^;;+ ?\\(.*\\)$" end t) + (match-string 1) "no comment"))) + keys keys-desc link description) + (if (equal stype "Command") + (setq keys (where-is-internal sym-name) + keys-desc + (if keys (mapconcat 'key-description keys " ") "none"))) + (setq link (concat "file:" (abbreviate-file-name buffer-file-name) + "::" def " " name)) + (setq description (concat stype ": " name)) + (org-store-link-props + :type "elisp-symbol" + :link link + :description description + :def def + :name name + :stype stype + :args args + :keys keys-desc + :docstring docstring + :doc doc + :fixme fixme + :comment comment))))) + +(provide 'org-elisp-symbol) + + +;;;;########################################################################## +;;;; User Options, Variables +;;;;########################################################################## + +;;; org-elisp-symbol.el ends here diff --git a/contrib/lisp/org-eval-light.el b/contrib/lisp/org-eval-light.el new file mode 100644 index 0000000..36f3c6d --- /dev/null +++ b/contrib/lisp/org-eval-light.el @@ -0,0 +1,201 @@ +;;; org-eval-light.el --- Display result of evaluating code in various languages (light) + +;; Copyright (C) 2008-2012 Free Software Foundation, Inc. + +;; Author: Carsten Dominik , +;; Eric Schulte +;; Keywords: outlines, hypermedia, calendar, wp, literate programming, +;; reproducible research +;; Homepage: http://orgmode.org +;; Version: 0.04 + +;; This file is not yet part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;; This file is based off of org-eval, with the following changes. +;; +;; 1) forms are only executed manually, (allowing for the execution of +;; an entire subtree of forms) +;; 2) use the org-mode style src blocks, rather than the muse style +;; blocks +;; 3) forms are not replaced by their outputs, but rather the output +;; is placed in the buffer immediately following the src block +;; commented by `org-eval-light-make-region-example' (when +;; evaluated with a prefix argument no output is placed in the +;; buffer) +;; 4) add defadvice to org-ctrl-c-ctrl-c so that when called inside of +;; a source block it will call `org-eval-light-current-snippet' + +;;; Code: +(require 'org) + +(defgroup org-eval-light nil + "Options concerning including output from commands into the Org-mode buffer." + :tag "Org Eval" + :group 'org) + +(defvar org-eval-light-example-size-cutoff 10 + "The number of lines under which an example is considered +'small', and is exported with the '^:' syntax instead of in a +large example block") + +(defvar org-eval-light-regexp nil) + +(defun org-eval-light-set-interpreters (var value) + (set-default var value) + (setq org-eval-light-regexp + (concat "#\\+begin_src \\(" + (mapconcat 'regexp-quote value "\\|") + "\\)\\([^\000]+?\\)#\\+end_src"))) + +(defcustom org-eval-light-interpreters '("lisp" "emacs-lisp" "ruby" "shell") + "Interpreters allows for evaluation tags. +This is a list of program names (as strings) that can evaluate code and +insert the output into an Org-mode buffer. Valid choices are + +lisp Interpret Emacs Lisp code and display the result +shell Pass command to the shell and display the result +perl The perl interpreter +python Thy python interpreter +ruby The ruby interpreter" + :group 'org-eval-light + :set 'org-eval-light-set-interpreters + :type '(set :greedy t + (const "lisp") + (const "emacs-lisp") + (const "perl") + (const "python") + (const "ruby") + (const "shell"))) + +;;; functions +(defun org-eval-light-inside-snippet () + (interactive) + (save-excursion + (let ((case-fold-search t) + (start-re "^#\\+begin_src\\( \\([^ \t\n]+\\)\\)?.*\n") + (end-re "\n#\\+end_src") + (pos (point)) + beg end) + (if (and (setq beg (re-search-backward start-re nil t)) + (setq end (re-search-forward end-re nil t)) + (<= beg pos) (>= end pos)) + t)))) + +(defun org-eval-light-make-region-example (beg end) + "Comment out region using either the '^:' or the BEGIN_EXAMPLE +syntax based on the size of the region as compared to +`org-eval-light-example-size-cutoff'." + (interactive "*r") + (let ((size (abs (- (line-number-at-pos end) + (line-number-at-pos beg))))) + (if (= size 0) + (let ((result (buffer-substring beg end))) + (delete-region beg end) + (insert (concat ": " result))) + (if (<= size org-eval-light-example-size-cutoff) + (save-excursion + (goto-char beg) + (dotimes (n size) + (move-beginning-of-line 1) (insert ": ") (forward-line 1))) + (let ((result (buffer-substring beg end))) + (delete-region beg end) + (insert (concat "#+BEGIN_EXAMPLE\n" result "#+END_EXAMPLE\n"))))))) + +(defun org-eval-light-current-snippet (&optional arg) + "Execute the current #+begin_src #+end_src block, and dump the +results into the buffer immediately following the src block, +commented by `org-eval-light-make-region-example'." + (interactive "P") + (let ((line (org-current-line)) + (case-fold-search t) + (info (org-edit-src-find-region-and-lang)) + beg end lang result) + (setq beg (nth 0 info) + end (nth 1 info) + lang (nth 2 info)) + (unless (member lang org-eval-light-interpreters) + (error "Language is not in `org-eval-light-interpreters': %s" lang)) + (goto-line line) + (setq result (org-eval-light-code lang (buffer-substring beg end))) + (unless arg + (save-excursion + (re-search-forward "^#\\+end_src" nil t) (open-line 1) (forward-char 2) + (let ((beg (point)) + (end (progn (insert result) + (point)))) + (message (format "from %S %S" beg end)) + (org-eval-light-make-region-example beg end)))))) + +(defun org-eval-light-eval-subtree (&optional arg) + "Replace EVAL snippets in the entire subtree." + (interactive "P") + (save-excursion + (org-narrow-to-subtree) + (goto-char (point-min)) + (while (re-search-forward org-eval-light-regexp nil t) + (org-eval-light-current-snippet arg)) + (widen))) + +(defun org-eval-light-code (interpreter code) + (cond + ((member interpreter '("lisp" "emacs-lisp")) + (org-eval-light-lisp (concat "(progn\n" code "\n)"))) + ((equal interpreter "shell") + (shell-command-to-string code)) + ((member interpreter '("perl" "python" "ruby")) + (org-eval-light-run (executable-find interpreter) code)) + (t (error "Cannot evaluate code type %s" interpreter)))) + +(defun org-eval-light-lisp (form) + "Evaluate the given form and return the result as a string." + (require 'pp) + (save-match-data + (condition-case err + (let ((object (eval (read form)))) + (cond + ((stringp object) object) + ((and (listp object) + (not (eq object nil))) + (let ((string (pp-to-string object))) + (substring string 0 (1- (length string))))) + ((numberp object) + (number-to-string object)) + ((eq object nil) "") + (t + (pp-to-string object)))) + (error + (org-display-warning (format "%s: Error evaluating %s: %s" + "???" form err)) + "; INVALID LISP CODE")))) + +(defun org-eval-light-run (cmd code) + (with-temp-buffer + (insert code) + (shell-command-on-region (point-min) (point-max) cmd nil 'replace) + (buffer-string))) + +(defadvice org-ctrl-c-ctrl-c (around org-cc-eval-source activate) + (if (org-eval-light-inside-snippet) + (call-interactively 'org-eval-light-current-snippet) + ad-do-it)) + +(provide 'org-eval-light) + +;;; org-eval-light.el ends here diff --git a/contrib/lisp/org-eval.el b/contrib/lisp/org-eval.el new file mode 100644 index 0000000..9968669 --- /dev/null +++ b/contrib/lisp/org-eval.el @@ -0,0 +1,219 @@ +;;; org-eval.el --- Display result of evaluating code in various languages +;; Copyright (C) 2008-2012 Free Software Foundation, Inc. +;; +;; Author: Carsten Dominik +;; Keywords: outlines, hypermedia, calendar, wp +;; Homepage: http://orgmode.org +;; Version: 0.04 +;; +;; This file is not yet part of GNU Emacs. +;; +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: +;; +;; This modules allows to include output from various commands into an +;; Org-mode buffer, both for live display, and for export. +;; This technique has been copied from emacs-wiki and Emacs Muse, and +;; we try to make it work here in a way as similar as possible to +;; Muse, so that people who move between both worlds don't need to learn +;; new syntax. +;; +;; Basically it works like this: +;; +;; (concat "aaa" "bbb") +;; +;; will display "aaabbb" in the buffer and export like that as well. +;; The leading lisp tag will also accept the attributes "markup" and +;; "lang", to specify how the text should be formatted during export. +;; For example, +;; +;; .... +;; +;; will format the result of the lisp form as if it was lisp source +;; code. Internally, it will wrap the text into a +;; +;; #+begin_src emacs-lisp +;; #+end_src +;; +;; structure so that the right things happen when the exporter is running. +;; +;; By default, only the tag is turned on, but you can configure +;; the variable `org-eval-interpreters' to add more interpreters like +;; `perl', `python', or the `shell'. +;; +;; You can edit the code snippets with "C-c '" (org-edit-src-code). +;; +;; Please note that this mechanism is potentially dangerous, because it +;; executes code that you don't even see. This gives you great power, +;; but also enough rope to hang yourself. And, it gives your friends +;; who send you Org files plenty of opportunity for good and bad jokes. +;; This is also why this module is not turned on by default, but only +;; available as a contributed package. +;; +;; +;; +(require 'org) + +;;; Customization + +(defgroup org-eval nil + "Options concerning including output from commands into the Org-mode buffer." + :tag "Org Eval" + :group 'org) + +(defface org-eval + (org-compatible-face nil + '((((class color grayscale) (min-colors 88) (background light)) + (:foreground "grey40")) + (((class color grayscale) (min-colors 88) (background dark)) + (:foreground "grey60")) + (((class color) (min-colors 8) (background light)) + (:foreground "green")) + (((class color) (min-colors 8) (background dark)) + (:foreground "yellow")))) + "Face for command output that is included into an Org-mode buffer." + :group 'org-eval + :group 'org-faces + :version "22.1") + +(defvar org-eval-regexp nil) + +(defun org-eval-set-interpreters (var value) + (set-default var value) + (setq org-eval-regexp + (concat "<\\(" + (mapconcat 'regexp-quote value "\\|") + "\\)" + "\\([^>]\\{0,50\\}?\\)>" + "\\([^\000]+?\\)"))) + +(defcustom org-eval-interpreters '("lisp") + "Interpreters allows for evaluation tags. +This is a list of program names (as strings) that can evaluate code and +insert the output into an Org-mode buffer. Valid choices are + +lisp Interpret Emacs Lisp code and display the result +shell Pass command to the shell and display the result +perl The perl interpreter +python Thy python interpreter +ruby The ruby interpreter" + :group 'org-eval + :set 'org-eval-set-interpreters + :type '(set :greedy t + (const "lisp") + (const "perl") + (const "python") + (const "ruby") + (const "shell"))) + +(defun org-eval-handle-snippets (limit &optional replace) + "Evaluate code snippets and display the results as display property. +When REPLACE is non-nil, replace the code region with the result (used +for export)." + (let (a) + (while (setq a (text-property-any (point) (or limit (point-max)) + 'org-eval t)) + (remove-text-properties + a (next-single-property-change a 'org-eval nil limit) + '(display t intangible t org-eval t)))) + (while (re-search-forward org-eval-regexp limit t) + (let* ((beg (match-beginning 0)) + (end (match-end 0)) + (kind (match-string 1)) + (attr (match-string 2)) + (code (match-string 3)) + (value (org-eval-code kind code)) + markup lang) + (if replace + (progn + (setq attr (save-match-data (org-eval-get-attributes attr)) + markup (cdr (assoc "markup" attr)) + lang (cdr (assoc "lang" attr))) + (replace-match + (concat (if markup (format "#+BEGIN_%s" (upcase markup))) + (if (and markup (equal (downcase markup) "src")) + (concat " " (or lang "fundamental"))) + "\n" + value + (if markup (format "\n#+END_%s\n" (upcase markup)))) + t t)) + (add-text-properties + beg end + (list 'display value 'intangible t 'font-lock-multiline t + 'face 'org-eval + 'org-eval t)))))) + +(defun org-eval-replace-snippts () + "Replace EVAL snippets in the entire buffer. +This should go into the `org-export-preprocess-hook'." + (goto-char (point-min)) + (org-eval-handle-snippets nil 'replace)) + +(add-hook 'org-export-preprocess-hook 'org-eval-replace-snippts) +(add-hook 'org-font-lock-hook 'org-eval-handle-snippets) + +(defun org-eval-get-attributes (str) + (let ((start 0) key value rtn) + (while (string-match "\\<\\([a-zA-Z]+\\)\\>=\"\\([^\"]+\\)\"" str start) + (setq key (match-string 1 str) + value (match-string 2 str) + start (match-end 0)) + (push (cons key value) rtn)) + rtn)) + +(defun org-eval-code (interpreter code) + (cond + ((equal interpreter "lisp") + (org-eval-lisp (concat "(progn\n" code "\n)"))) + ((equal interpreter "shell") + (shell-command-to-string code)) + ((member interpreter '("perl" "python" "ruby")) + (org-eval-run (executable-find interpreter) code)) + (t (error "Cannot evaluate code type %s" interpreter)))) + +(defun org-eval-lisp (form) + "Evaluate the given form and return the result as a string." + (require 'pp) + (save-match-data + (condition-case err + (let ((object (eval (read form)))) + (cond + ((stringp object) object) + ((and (listp object) + (not (eq object nil))) + (let ((string (pp-to-string object))) + (substring string 0 (1- (length string))))) + ((numberp object) + (number-to-string object)) + ((eq object nil) "") + (t + (pp-to-string object)))) + (error + (org-display-warning (format "%s: Error evaluating %s: %s" + "???" form err)) + "; INVALID LISP CODE")))) + +(defun org-eval-run (cmd code) + (with-temp-buffer + (insert code) + (shell-command-on-region (point-min) (point-max) cmd nil 'replace) + (buffer-string))) + +(provide 'org-eval) + +;;; org-eval.el ends here diff --git a/contrib/lisp/org-exp-bibtex.el b/contrib/lisp/org-exp-bibtex.el new file mode 100644 index 0000000..8a99243 --- /dev/null +++ b/contrib/lisp/org-exp-bibtex.el @@ -0,0 +1,148 @@ +;;; org-exp-bibtex.el --- Export bibtex fragments + +;; Copyright (C) 2009-2012 Taru Karttunen + +;; Author: Taru Karttunen + +;; This file is not currently part of GNU Emacs. + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 2, or (at +;; your option) any later version. + +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program ; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: +;; +;; This is an utility to handle BibTeX export to both LaTeX and html +;; exports. It uses the bibtex2html software from +;; http://www.lri.fr/~filliatr/bibtex2html/ +;; +;; The usage is as follows: +;; #+BIBLIOGRAPHY: bibfilebasename stylename optional-options +;; e.g. given foo.bib and using style plain: +;; #+BIBLIOGRAPHY: foo plain option:-d +;; +;; Optional options are of the form: +;; +;; option:-foobar pass '-foobar' to bibtex2html +;; e.g. +;; option:-d sort by date. +;; option:-a sort as BibTeX (usually by author) *default* +;; option:-u unsorted i.e. same order as in .bib file +;; option:-r reverse the sort. +;; see the bibtex2html man page for more. Multiple options can be combined like: +;; option:-d option:-r +;; +;; Limiting to only the entries cited in the document: +;; limit:t + +;; For LaTeX export this simply inserts the lines +;; \bibliographystyle{plain} +;; \bibliography{foo} +;; into the tex-file when exporting. + +;; For Html export it: +;; 1) converts all \cite{foo} to links to the bibliography +;; 2) creates a foo.html and foo_bib.html +;; 3) includes the contents of foo.html in the exported html file + +(require 'org) +(require 'org-exp) + +(defvar org-export-current-backend) ; dynamically bound in org-exp.el +(defun org-export-bibtex-preprocess () + "Export all BibTeX." + (interactive) + (save-window-excursion + (setq oebp-cite-plist '()) + + ;; Convert #+BIBLIOGRAPHY: name style + (goto-char (point-min)) + (while (re-search-forward "^#\\+BIBLIOGRAPHY:[ \t]+\\(\\S-+\\)[ \t]+\\(\\S-+\\)\\([^\r\n]*\\)" nil t) + (let ((file (match-string 1)) + (style (match-string 2)) + (opt (org-exp-bibtex-options-to-plist (match-string 3)))) + (replace-match + (cond + ((eq org-export-current-backend 'html) ;; We are exporting to HTML + (let (extra-args cite-list end-hook tmp-files) + (dolist (elt opt) + (when (equal "option" (car elt)) + (setq extra-args (cons (cdr elt) extra-args)))) + + (when (assoc "limit" opt) ;; Limit is true - collect references + (org-exp-bibtex-docites (lambda () + (dolist (c (org-split-string (match-string 1) ",")) + (add-to-list 'cite-list c)))) +;; (message "cites: %s" cite-list) + (let ((tmp (make-temp-file "org-exp-bibtex"))) + (with-temp-file tmp (dolist (i cite-list) (insert (concat i "\n")))) + (setq tmp-files (cons tmp tmp-files)) + (setq extra-args (append extra-args `("-citefile" ,tmp))))) + + (when (not (eq 0 (apply 'call-process (append '("bibtex2html" nil nil nil) + `("-a" "--nodoc" "--style" ,style "--no-header") + extra-args + (list (concat file ".bib")))))) + (error "Executing bibtex2html failed")) + + (dolist (f tmp-files) (delete-file f))) + + (with-temp-buffer + (save-match-data + (insert-file-contents (concat file ".html")) + (goto-char (point-min)) + (while (re-search-forward (org-re "a name=\"\\([-_[:word:]]+\\)\">\\([[:word:]]+\\)") nil t) + (setq oebp-cite-plist (cons (cons (match-string 1) (match-string 2)) oebp-cite-plist))) + (goto-char (point-min)) + (while (re-search-forward "
" nil t) + (replace-match "
" t t)) + (concat "\n#+BEGIN_HTML\n
\n

References

\n" (buffer-string) "\n
\n#+END_HTML\n")))) + ((eq org-export-current-backend 'latex) ;; Latex export + (concat "\n#+LATEX: \\bibliographystyle{" style "}" + "\n#+LATEX: \\bibliography{" file "}\n"))) t t))) + + ;; Convert cites to links in html + (when (eq org-export-current-backend 'html) + ;; Split citation commands with multiple keys + (org-exp-bibtex-docites + (lambda () + (let ((keys (save-match-data (org-split-string (match-string 1) ",")))) + (when (> (length keys) 1) + (replace-match (mapconcat (lambda (k) (format "\\cite{%s}" k)) keys "") + t t))))) + ;; Replace the citation commands with links + (org-exp-bibtex-docites + (lambda () (let* ((cn (match-string 1)) + (cv (assoc cn oebp-cite-plist))) +;; (message "L: %s" (concat "\[_{}[[" cn "][" (if cv (cdr cv) cn) "]]\]")) + (replace-match (concat "\[_{}[[#" cn "][" (if cv (cdr cv) cn) "]]\]")) t t)))))) + +(defun org-exp-bibtex-docites (fun) + (save-excursion + (save-match-data + (goto-char (point-min)) + (when (eq org-export-current-backend 'html) + (while (re-search-forward "\\\\cite{\\([^}\n]+\\)}" nil t) + (apply fun nil)))))) + +(defun org-exp-bibtex-options-to-plist (options) + (save-match-data + (flet ((f (o) (let ((s (split-string o ":"))) (cons (nth 0 s) (nth 1 s))))) + (mapcar 'f (split-string options nil t))))) + +(add-hook 'org-export-preprocess-hook 'org-export-bibtex-preprocess) + +(provide 'org-exp-bibtex) + +;;; org-exp-bibtex.el ends here diff --git a/contrib/lisp/org-expiry.el b/contrib/lisp/org-expiry.el new file mode 100644 index 0000000..9f4517d --- /dev/null +++ b/contrib/lisp/org-expiry.el @@ -0,0 +1,361 @@ +;;; org-expiry.el --- expiry mechanism for Org entries +;; +;; Copyright 2007-2012 Free Software Foundation, Inc. +;; +;; Author: bzg AT gnu DOT org +;; Version: 0.2 +;; Keywords: org expiry + +;; This file is not part of GNU Emacs. + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, write to the Free Software +;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +;; +;;; Commentary: +;; +;; This gives you a chance to get rid of old entries in your Org files +;; by expiring them. +;; +;; By default, entries that have no EXPIRY property are considered to be +;; new (i.e. 0 day old) and only entries older than one year go to the +;; expiry process, which consist in adding the ARCHIVE tag. None of +;; your tasks will be deleted with the default settings. +;; +;; When does an entry expires? +;; +;; Consider this entry: +;; +;; * Stop watching TV +;; :PROPERTIES: +;; :CREATED: <2008-01-07 lun 08:01> +;; :EXPIRY: <2008-01-09 08:01> +;; :END: +;; +;; This entry will expire on the 9th, january 2008. + +;; * Stop watching TV +;; :PROPERTIES: +;; :CREATED: <2008-01-07 lun 08:01> +;; :EXPIRY: +1w +;; :END: +;; +;; This entry will expire on the 14th, january 2008, one week after its +;; creation date. +;; +;; What happen when an entry is expired? Nothing until you explicitely +;; M-x org-expiry-process-entries When doing this, org-expiry will check +;; for expired entries and request permission to process them. +;; +;; Processing an expired entries means calling the function associated +;; with `org-expiry-handler-function'; the default is to add the tag +;; :ARCHIVE:, but you can also add a EXPIRED keyword or even archive +;; the subtree. +;; +;; Is this useful? Well, when you're in a brainstorming session, it +;; might be useful to know about the creation date of an entry, and be +;; able to archive those entries that are more than xxx days/weeks old. +;; +;; When you're in such a session, you can insinuate org-expiry like +;; this: M-x org-expiry-insinuate +;; +;; Then, each time you're pressing M-RET to insert an item, the CREATION +;; property will be automatically added. Same when you're scheduling or +;; deadlining items. You can deinsinuate: M-x org-expiry-deinsinuate + +;;; Code: + +;;; User variables: + +(defgroup org-expiry nil + "Org expiry process." + :tag "Org Expiry" + :group 'org) + +(defcustom org-expiry-inactive-timestamps nil + "Insert inactive timestamps for the created and expired time properties" + :type 'boolean + :group 'org-expiry) + +(defcustom org-expiry-created-property-name "CREATED" + "The name of the property for setting the creation date." + :type 'string + :group 'org-expiry) + +(defcustom org-expiry-expiry-property-name "EXPIRY" + "The name of the property for setting the expiry date/delay." + :type 'string + :group 'org-expiry) + +(defcustom org-expiry-keyword "EXPIRED" + "The default keyword for `org-expiry-add-keyword'." + :type 'string + :group 'org-expiry) + +(defcustom org-expiry-wait "+1y" + "Time span between the creation date and the expiry. +The default value for this variable (\"+1y\") means that entries +will expire if there are at least one year old. + +If the expiry delay cannot be retrieved from the entry or the +subtree above, the expiry process compares the expiry delay with +`org-expiry-wait'. This can be either an ISO date or a relative +time specification. See `org-read-date' for details." + :type 'string + :group 'org-expiry) + +(defcustom org-expiry-created-date "+0d" + "The default creation date. +The default value of this variable (\"+0d\") means that entries +without a creation date will be handled as if they were created +today. + +If the creation date cannot be retrieved from the entry or the +subtree above, the expiry process will compare the expiry delay +with this date. This can be either an ISO date or a relative +time specification. See `org-read-date' for details on relative +time specifications." + :type 'string + :group 'org-expiry) + +(defcustom org-expiry-handler-function 'org-toggle-archive-tag + "Function to process expired entries. +Possible candidates for this function are: + +`org-toggle-archive-tag' +`org-expiry-add-keyword' +`org-expiry-archive-subtree'" + :type 'function + :group 'org-expiry) + +(defcustom org-expiry-confirm-flag t + "Non-nil means confirm expiration process." + :type '(choice + (const :tag "Always require confirmation" t) + (const :tag "Do not require confirmation" nil) + (const :tag "Require confirmation in interactive expiry process" + interactive)) + :group 'org-expiry) + +(defcustom org-expiry-advised-functions + '(org-scheduled org-deadline org-time-stamp) + "A list of advised functions. +`org-expiry-insinuate' will activate the expiry advice for these +functions. `org-expiry-deinsinuate' will deactivate them." + :type 'boolean + :group 'list) + +;;; Advices and insinuation: + +(defadvice org-schedule (after org-schedule-update-created) + "Update the creation-date property when calling `org-schedule'." + (org-expiry-insert-created)) + +(defadvice org-deadline (after org-deadline-update-created) + "Update the creation-date property when calling `org-deadline'." + (org-expiry-insert-created)) + +(defadvice org-time-stamp (after org-time-stamp-update-created) + "Update the creation-date property when calling `org-time-stamp'." + (org-expiry-insert-created)) + +(defun org-expiry-insinuate (&optional arg) + "Add hooks and activate advices for org-expiry. +If ARG, also add a hook to `before-save-hook' in `org-mode' and +restart `org-mode' if necessary." + (interactive "P") + (ad-activate 'org-schedule) + (ad-activate 'org-time-stamp) + (ad-activate 'org-deadline) + (add-hook 'org-insert-heading-hook 'org-expiry-insert-created) + (add-hook 'org-after-todo-state-change-hook 'org-expiry-insert-created) + (add-hook 'org-after-tags-change-hook 'org-expiry-insert-created) + (when arg + (add-hook 'org-mode-hook + (lambda() (add-hook 'before-save-hook + 'org-expiry-process-entries t t))) + ;; need this to refresh org-mode hooks + (when (eq major-mode 'org-mode) + (org-mode) + (if (org-called-interactively-p) + (message "Org-expiry insinuated, `org-mode' restarted."))))) + +(defun org-expiry-deinsinuate (&optional arg) + "Remove hooks and deactivate advices for org-expiry. +If ARG, also remove org-expiry hook in Org's `before-save-hook' +and restart `org-mode' if necessary." + (interactive "P") + (ad-deactivate 'org-schedule) + (ad-deactivate 'org-time-stamp) + (ad-deactivate 'org-deadline) + (remove-hook 'org-insert-heading-hook 'org-expiry-insert-created) + (remove-hook 'org-after-todo-state-change-hook 'org-expiry-insert-created) + (remove-hook 'org-after-tags-change-hook 'org-expiry-insert-created) + (remove-hook 'org-mode-hook + (lambda() (add-hook 'before-save-hook + 'org-expiry-process-entries t t))) + (when arg + ;; need this to refresh org-mode hooks + (when (eq major-mode 'org-mode) + (org-mode) + (if (org-called-interactively-p) + (message "Org-expiry de-insinuated, `org-mode' restarted."))))) + +;;; org-expiry-expired-p: + +(defun org-expiry-expired-p () + "Check if the entry at point is expired. +Return nil if the entry is not expired. Otherwise return the +amount of time between today and the expiry date. + +If there is no creation date, use `org-expiry-created-date'. +If there is no expiry date, use `org-expiry-expiry-date'." + (let* ((ex-prop org-expiry-expiry-property-name) + (cr-prop org-expiry-created-property-name) + (ct (current-time)) + (cr (org-read-date nil t (or (org-entry-get (point) cr-prop t) "+0d"))) + (ex-field (or (org-entry-get (point) ex-prop t) org-expiry-wait)) + (ex (if (string-match "^[ \t]?[+-]" ex-field) + (time-add cr (time-subtract (org-read-date nil t ex-field) ct)) + (org-read-date nil t ex-field)))) + (if (time-less-p ex ct) + (time-subtract ct ex)))) + +;;; Expire an entry or a region/buffer: + +(defun org-expiry-process-entry (&optional force) + "Call `org-expiry-handler-function' on entry. +If FORCE is non-nil, don't require confirmation from the user. +Otherwise rely on `org-expiry-confirm-flag' to decide." + (interactive "P") + (save-excursion + (when (org-called-interactively-p) (org-reveal)) + (when (org-expiry-expired-p) + (org-back-to-heading) + (looking-at org-complex-heading-regexp) + (let* ((ov (make-overlay (point) (match-end 0))) + (e (org-expiry-expired-p)) + (d (time-to-number-of-days e))) + (overlay-put ov 'face 'secondary-selection) + (if (or force + (null org-expiry-confirm-flag) + (and (eq org-expiry-confirm-flag 'interactive) + (not (interactive))) + (and org-expiry-confirm-flag + (y-or-n-p (format "Entry expired by %d days. Process? " d)))) + (funcall 'org-expiry-handler-function)) + (delete-overlay ov))))) + +(defun org-expiry-process-entries (beg end) + "Process all expired entries between BEG and END. +The expiry process will run the function defined by +`org-expiry-handler-functions'." + (interactive "r") + (save-excursion + (let ((beg (if (org-region-active-p) + (region-beginning) (point-min))) + (end (if (org-region-active-p) + (region-end) (point-max)))) + (goto-char beg) + (let ((expired 0) (processed 0)) + (while (and (outline-next-heading) (< (point) end)) + (when (org-expiry-expired-p) + (setq expired (1+ expired)) + (if (if (org-called-interactively-p) + (call-interactively 'org-expiry-process-entry) + (org-expiry-process-entry)) + (setq processed (1+ processed))))) + (if (equal expired 0) + (message "No expired entry") + (message "Processed %d on %d expired entries" + processed expired)))))) + +;;; Insert created/expiry property: + +(defun org-expiry-insert-created (&optional arg) + "Insert or update a property with the creation date. +If ARG, always update it. With one `C-u' prefix, silently update +to today's date. With two `C-u' prefixes, prompt the user for to +update the date." + (interactive "P") + (let* ((d (org-entry-get (point) org-expiry-created-property-name)) + d-time d-hour timestr) + (when (or (null d) arg) + ;; update if no date or non-nil prefix argument + ;; FIXME Use `org-time-string-to-time' + (setq d-time (if d (org-time-string-to-time d) + (current-time))) + (setq d-hour (format-time-string "%H:%M" d-time)) + (setq timestr + ;; two C-u prefixes will call org-read-date + (if (equal arg '(16)) + (concat "<" (org-read-date + nil nil nil nil d-time d-hour) ">") + (format-time-string (cdr org-time-stamp-formats)))) + ;; maybe transform to inactive timestamp + (if org-expiry-inactive-timestamps + (setq timestr (concat "[" (substring timestr 1 -1) "]"))) + (save-excursion + (org-entry-put + (point) org-expiry-created-property-name timestr))))) + +(defun org-expiry-insert-expiry (&optional today) + "Insert a property with the expiry date. +With one `C-u' prefix, don't prompt interactively for the date +and insert today's date." + (interactive "P") + (let* ((d (org-entry-get (point) org-expiry-expiry-property-name)) + d-time d-hour) + (setq d-time (if d (org-time-string-to-time d) + (current-time))) + (setq d-hour (format-time-string "%H:%M" d-time)) + (setq timestr (if today + (format-time-string (cdr org-time-stamp-formats)) + (concat "<" (org-read-date + nil nil nil nil d-time d-hour) ">"))) + ;; maybe transform to inactive timestamp + (if org-expiry-inactive-timestamps + (setq timestr (concat "[" (substring timestr 1 -1) "]"))) + + (save-excursion + (org-entry-put + (point) org-expiry-expiry-property-name timestr)))) + +;;; Functions to process expired entries: + +(defun org-expiry-archive-subtree () + "Archive the entry at point if it is expired." + (interactive) + (save-excursion + (if (org-expiry-expired-p) + (org-archive-subtree) + (if (org-called-interactively-p) + (message "Entry at point is not expired."))))) + +(defun org-expiry-add-keyword (&optional keyword) + "Add KEYWORD to the entry at point if it is expired." + (interactive "sKeyword: ") + (if (or (member keyword org-todo-keywords-1) + (setq keyword org-expiry-keyword)) + (save-excursion + (if (org-expiry-expired-p) + (org-todo keyword) + (if (org-called-interactively-p) + (message "Entry at point is not expired.")))) + (error "\"%s\" is not a to-do keyword in this buffer" keyword))) + +;; FIXME what about using org-refile ? + +(provide 'org-expiry) + +;;; org-expiry.el ends here diff --git a/contrib/lisp/org-export-generic.el b/contrib/lisp/org-export-generic.el new file mode 100644 index 0000000..4de38c7 --- /dev/null +++ b/contrib/lisp/org-export-generic.el @@ -0,0 +1,1504 @@ +;; org-export-generic.el --- Export frameworg with custom backends + +;; Copyright (C) 2009-2012 Free Software Foundation, Inc. + +;; Author: Wes Hardaker +;; Keywords: outlines, hypermedia, calendar, wp, export +;; Homepage: http://orgmode.org +;; Version: 6.25trans +;; Acks: Much of this code was stolen form the ascii export from Carsten +;; +;; This file is not yet part of GNU Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . +;; +;; ---------------------------------------------------------------------- +;; +;; OVERVIEW +;; +;; org-export-generic is basically a simple translation system that +;; knows how to parse at least most of a .org buffer and then add +;; various formatting prefixes before and after each section type. It +;; does this by examining a property list stored in org-generic-alist. +;; You can dynamically add propety lists of your own using the +;; org-set-generic-type function: +;; +;; (org-set-generic-type +;; "really-basic-text" +;; '(:file-suffix ".txt" +;; :key-binding ?R +;; +;; :title-format "=== %s ===\n" +;; :body-header-section-numbers t +;; :body-header-section-number-format "%s) " +;; :body-section-header-prefix "\n" +;; :body-section-header-suffix "\n" +;; :body-line-format " %s\n" +;; :body-line-wrap 75 +;; )) +;; +;; Note: Upper case key-bindings are reserved for your use. Lower +;; case key bindings may conflict with future export-generic +;; publications. +;; +;; Then run org-export (ctrl-c ctrl-e) and select generic or run +;; org-export-generic. You'll then be prompted with a list of export +;; types to choose from which will include your new type assigned to +;; the key "r". +;; +;; ---------------------------------------------------------------------- +;; +;; TODO (non-ordered) +;; * handle function references +;; * handle other types of multi-complex-listy-things to do +;; ideas: (t ?- "%s" ?-) +;; * handle indent specifiers better +;; ideas: (4 ?\ "%s") +;; * need flag to remove indents from body text +;; * handle links +;; * handle internationalization strings better +;; * date/author/etc needs improvment (internationalization too) +;; * allow specifying of section ordering +;; ideas: :ordering ("header" "toc" "body" "footer") +;; ^ matches current hard coded ordering +;; * err, actually *do* a footer +;; * deal with usage of org globals +;; *** should we even consider them, or let the per-section specifiers do it +;; *** answer: remove; mostly removed now +;; * deal with interactive support for picking a export specifier label +;; * char specifiers that need extra length because of formatting +;; idea: (?- 4) for 4-longer +;; * centering specifier +;; idea: ('center " -- %s -- ") +;; * remove more of the unneeded export-to-ascii copy code +;; * tags +;; *** supported now, but need separate format per tag +;; *** allow different open/closing prefixes +;; * properties +;; * drawers +;; * Escape camel-case for wiki exporters. +;; * Adjust to depth limits on headers --- need to roll-over from headers +;; to lists, as per other exporters +;; * optmization (many plist extracts should be in let vars) +;; * define defcustom spec for the specifier list +;; * fonts: at least monospace is not handled at all here. +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: + +(require 'org-exp) +(require 'assoc) +(eval-when-compile (require 'cl)) + +(defgroup org-export-generic nil + "Options specific for ASCII export of Org-mode files." + :tag "Org Export ASCII" + :group 'org-export) + +(defcustom org-export-generic-links-to-notes t + "Non-nil means convert links to notes before the next headline. +When nil, the link will be exported in place. If the line becomes long +in this way, it will be wrapped." + :group 'org-export-generic + :type 'boolean) + + +(defvar org-generic-current-indentation nil) ; For communication + +(defvar org-generic-alist + '( + ;; + ;; generic DEMO exporter + ;; + ;; (this tries to use every specifier for demo purposes) + ;; + ("demo" + :file-suffix ".txt" + :key-binding ?d + + :header-prefix "
\n" + :header-suffix "
\n" + + :author-export t + :tags-export t + + :drawers-export t + + + :title-prefix ?= + :title-format "

%s

\n" + :title-suffix ?= + + :date-export t + :date-prefix "" + :date-format "
Date: %s
" + :date-suffix "
\n\n" + + :toc-export t + :toc-header-prefix "\n" + :toc-header-format "__%s__\n" + :toc-header-suffix "\n" + + :toc-prefix "\n" + :toc-suffix "\n" + + :toc-section-numbers t + :toc-section-number-format "\#(%s) " + :toc-format "--%s--" + :toc-format-with-todo "!!%s!!\n" + :toc-indent-char ?\ + :toc-indent-depth 4 + + :toc-tags-export t + :toc-tags-prefix " " + :toc-tags-format "*%s*" + :toc-tags-suffix "\n" + :toc-tags-none-string "\n" + + :body-header-section-numbers 3 ; t = all, nil = none + + ; lists indicate different things per level + ; list contents or straight value can either be a + ; ?x char reference for printing strings that match the header len + ; "" string to print directly + :body-section-header-prefix ("

" "

" "

" + "

" "

" "
") + :body-section-header-format "%s" + :body-section-header-suffix ("
\n" "\n" "\n" + "\n" "\n" "\n") + + :timestamps-export t + :priorities-export t + :todo-keywords-export t + + :body-tags-export t + :body-tags-prefix " " + :body-tags-suffix "\n" + + ; section prefixes/suffixes can be direct strings or lists as well + :body-section-prefix "\n" + :body-section-suffix "\n" + ; :body-section-prefix ("\n" "\n" "\n") + ; :body-section-suffix ("\n" "\n" "\n") + + + ; if preformated text should be included (eg, : prefixed) + :body-line-export-preformated t + :body-line-fixed-prefix "
\n"
+     :body-line-fixed-suffix       "\n
\n" + :body-line-fixed-format "%s\n" + + + :body-list-prefix "\n" + :body-list-suffix "\n" + :body-list-format "
  • %s
  • \n" + + :body-number-list-prefix "
      \n" + :body-number-list-suffix "
    \n" + :body-number-list-format "
  • %s
  • \n" + :body-number-list-leave-number t + + :body-list-checkbox-todo "" + :body-list-checkbox-todo-end "" + :body-list-checkbox-done "" + :body-list-checkbox-done-end "" + :body-list-checkbox-half "" + :body-list-checkbox-half-end "" + + + + + ; other body lines + :body-line-format "%s" + :body-line-wrap 60 ; wrap at 60 chars + + ; print above and below all body parts + :body-text-prefix "

    \n" + :body-text-suffix "

    \n" + + ) + + ;; + ;; ascii exporter + ;; + ;; (close to the original ascii specifier) + ;; + ("ascii" + :file-suffix ".txt" + :key-binding ?a + + :header-prefix "" + :header-suffix "" + + :title-prefix ?= + :title-format "%s\n" + :title-suffix ?= + + :date-export t + :date-prefix "" + :date-format "Date: %s\n" + :date-suffix "" + + :toc-header-prefix "" + :toc-header-format "%s\n" + :toc-header-suffix ?= + + :toc-export t + :toc-section-numbers t + :toc-section-number-format "%s " + :toc-format "%s\n" + :toc-format-with-todo "%s (*)\n" + :toc-indent-char ?\ + :toc-indent-depth 4 + + :body-header-section-numbers 3 + :body-section-prefix "\n" + + ; :body-section-header-prefix "\n" + ; :body-section-header-format "%s\n" + ; :body-section-header-suffix (?\$ ?\# ?^ ?\~ ?\= ?\-) + + :body-section-header-prefix ("" "" "" "* " " + " " - ") + :body-section-header-format "%s\n" + :body-section-header-suffix (?~ ?= ?- "\n" "\n" "\n") + + ; :body-section-marker-prefix "" + ; :body-section-marker-chars (?\$ ?\# ?^ ?\~ ?\= ?\-) + ; :body-section-marker-suffix "\n" + + :body-line-export-preformated t + :body-line-format "%s\n" + :body-line-wrap 75 + + ; :body-text-prefix "\n" + ; :body-text-suffix "\n" + + + :body-bullet-list-prefix (?* ?+ ?-) + ; :body-bullet-list-suffix (?* ?+ ?-) + ) + + ;; + ;; wikipedia + ;; + ("wikipedia" + :file-suffix ".txt" + :key-binding ?w + + :header-prefix "" + :header-suffix "" + + :title-format "= %s =\n" + + :date-export nil + + :toc-export nil + + :body-header-section-numbers nil + :body-section-prefix "\n" + + :body-section-header-prefix ("= " "== " "=== " + "==== " "===== " "====== ") + :body-section-header-suffix (" =\n\n" " ==\n\n" " ===\n\n" + " ====\n\n" " =====\n\n" " ======\n\n") + + :body-line-export-preformated t ;; yes/no/maybe??? + :body-line-format "%s\n" + :body-line-wrap 75 + + :body-line-fixed-format " %s\n" + + :body-list-format "* %s\n" + :body-number-list-format "# %s\n" + + :body-bullet-list-prefix ("* " "** " "*** " "**** " "***** ") + ) + ;; + ;; mediawiki + ;; + ("mediawiki" + :file-suffix ".txt" + :key-binding ?m + + :header-prefix "" + :header-suffix "" + + :title-format "= %s =\n" + + :date-export nil + + :toc-export nil + + :body-header-section-numbers nil + :body-section-prefix "\n" + + :body-section-header-prefix ("= " "== " "=== " + "==== " "===== " "====== ") + :body-section-header-suffix (" =\n\n" " ==\n\n" " ===\n\n" + " ====\n\n" " =====\n\n" " ======\n\n") + + :body-line-export-preformated t ;; yes/no/maybe??? + :body-line-format "%s\n" + :body-line-wrap 75 + + :body-line-fixed-format " %s\n" + + :body-list-format "* %s\n" + :body-number-list-format "# %s\n" + + :body-bullet-list-prefix ("* " "** " "*** " "**** " "***** ") + :body-list-checkbox-todo "☐ " + :body-list-checkbox-done "☒ " + :body-table-start "{|" + :body-table-end "|}" + :body-table-cell-start "|" + :body-table-cell-end "\n" + :body-table-last-cell-end "|-" + :body-table-hline-start "" + + + ) + ;; + ;; internet-draft .xml for xml2rfc exporter + ;; + ("ietfid" + ;; this tries to use every specifier for demo purposes + :file-suffix ".xml" + :key-binding ?i + + :title-prefix " + + + + + + + + + +" + :title-format "\n%s\n\n" + :title-suffix " + Comany, Inc.. +
    + + + + + + + + + +
    +
    + + Operations and Management + FIXME +\n" + :date-export nil + + :toc-export nil + + :body-header-section-numbers nil + + :body-section-header-format "
    \n" + :body-section-suffix "
    \n" + + ; if preformated text should be included (eg, : prefixed) + :body-line-export-preformated t + :body-line-fixed-prefix "
    \n\n" + :body-line-fixed-suffix "\n\n
    \n" + + ; other body lines + :body-line-format "%s" + :body-line-wrap 75 + + ; print above and below all body parts + :body-text-prefix "\n" + :body-text-suffix "\n" + + :body-list-prefix "\n" + :body-list-suffix "\n" + :body-list-format "%s\n" + + ) + ("trac-wiki" + :file-suffix ".txt" + :key-binding ?T + + ;; lifted from wikipedia exporter + :header-prefix "" + :header-suffix "" + + :title-format "= %s =\n" + + :date-export nil + + :toc-export nil + + :body-header-section-numbers nil + :body-section-prefix "\n" + + :body-section-header-prefix (" == " " === " " ==== " + " ===== " ) + :body-section-header-suffix (" ==\n\n" " ===\n\n" " ====\n\n" + " =====\n\n" " ======\n\n" " =======\n\n") + + :body-line-export-preformated t ;; yes/no/maybe??? + :body-line-format "%s\n" + :body-line-wrap 75 + + :body-line-fixed-format " %s\n" + + :body-list-format " * %s\n" + :body-number-list-format " # %s\n" + ;; :body-list-prefix "LISTSTART" + ;; :body-list-suffix "LISTEND" + + ;; this is ignored! [2010/02/02:rpg] + :body-bullet-list-prefix ("* " "** " "*** " "**** " "***** ") + ) + ("tikiwiki" + :file-suffix ".txt" + :key-binding ?U + + ;; lifted from wikipedia exporter + :header-prefix "" + :header-suffix "" + + :title-format "-= %s =-\n" + + :date-export nil + + :toc-export nil + + :body-header-section-numbers nil + :body-section-prefix "\n" + + :body-section-header-prefix ("! " "!! " "!!! " "!!!! " + "!!!!! " "!!!!!! " "!!!!!!! ") + :body-section-header-suffix (" \n" " \n" " \n" + " \n" " \n" " \n") + + + :body-line-export-preformated t ;; yes/no/maybe??? + :body-line-format "%s " + :body-line-wrap nil + + :body-line-fixed-format " %s\n" + + :body-list-format "* %s\n" + :body-number-list-format "# %s\n" + ;; :body-list-prefix "LISTSTART" + ;; :body-list-suffix "LISTEND" + :blockquote-start "\n^\n" + :blockquote-end "^\n\n" + :body-newline-paragraph "\n" + :bold-format "__%s__" + :italic-format "''%s''" + :underline-format "===%s===" + :strikethrough-format "--%s--" + :code-format "-+%s+-" + :verbatim-format "~pp~%s~/pp~" + ) + ) + "A assoc list of property lists to specify export definitions" +) + +(setq org-generic-export-type "demo") + +(defvar org-export-generic-section-type "") +(defvar org-export-generic-section-suffix "") + +;;;###autoload +(defun org-set-generic-type (type definition) + "Adds a TYPE and DEFINITION to the existing list of defined generic +export definitions." + (aput 'org-generic-alist type definition)) + +;;; helper functions for org-set-generic-type +(defvar org-export-generic-keywords nil) +(defmacro* def-org-export-generic-keyword (keyword + &key documentation + type) + "Define KEYWORD as a legitimate element for inclusion in +the body of an org-set-generic-type definition." + `(progn + (pushnew ,keyword org-export-generic-keywords) + ;; TODO: push the documentation and type information + ;; somewhere where it will do us some good. + )) + +(def-org-export-generic-keyword :body-newline-paragraph + :documentation "Bound either to NIL or to a pattern to be +inserted in the output for every blank line in the input. + The intention is to handle formats where text is flowed, and +newlines are interpreted as significant \(e.g., as indicating +preformatted text\). A common non-nil value for this keyword +is \"\\n\". Should typically be combined with a value for +:body-line-format that does NOT end with a newline." + :type string) + +;;; fontification keywords +(def-org-export-generic-keyword :bold-format) +(def-org-export-generic-keyword :italic-format) +(def-org-export-generic-keyword :underline-format) +(def-org-export-generic-keyword :strikethrough-format) +(def-org-export-generic-keyword :code-format) +(def-org-export-generic-keyword :verbatim-format) + + + + +(defun org-export-generic-remember-section (type suffix &optional prefix) + (setq org-export-generic-section-type type) + (setq org-export-generic-section-suffix suffix) + (if prefix + (insert prefix)) +) + +(defun org-export-generic-check-section (type &optional prefix suffix) + "checks to see if type is already in use, or we're switching parts +If we're switching, then insert a potentially previously remembered +suffix, and insert the current prefix immediately and then save the +suffix a later change time." + + (when (not (equal type org-export-generic-section-type)) + (if org-export-generic-section-suffix + (insert org-export-generic-section-suffix)) + (setq org-export-generic-section-type type) + (setq org-export-generic-section-suffix suffix) + (if prefix + (insert prefix)))) + +;;;###autoload +(defun org-export-generic (arg) + "Export the outline as generic output. +If there is an active region, export only the region. +The prefix ARG specifies how many levels of the outline should become +underlined headlines. The default is 3." + (interactive "P") + (setq-default org-todo-line-regexp org-todo-line-regexp) + (let* ((opt-plist (org-combine-plists (org-default-export-plist) + (org-infile-export-plist))) + (region-p (org-region-active-p)) + (rbeg (and region-p (region-beginning))) + (rend (and region-p (region-end))) + (subtree-p + (when region-p + (save-excursion + (goto-char rbeg) + (and (org-at-heading-p) + (>= (org-end-of-subtree t t) rend))))) + (level-offset (if subtree-p + (save-excursion + (goto-char rbeg) + (+ (funcall outline-level) + (if org-odd-levels-only 1 0))) + 0)) + (opt-plist (setq org-export-opt-plist + (if subtree-p + (org-export-add-subtree-options opt-plist rbeg) + opt-plist))) + + helpstart + (bogus (mapc (lambda (x) + (setq helpstart + (concat helpstart "\[" + (char-to-string + (plist-get (cdr x) :key-binding)) + "] " (car x) "\n"))) + org-generic-alist)) + + (help (concat helpstart " + +\[ ] the current setting of the org-generic-export-type variable +")) + + (cmds + + (append + (mapcar (lambda (x) + (list + (plist-get (cdr x) :key-binding) + (car x))) + org-generic-alist) + (list (list ? "default")))) + + r1 r2 ass + + ;; read in the type to use + (export-plist + (progn + (save-excursion + (save-window-excursion + (delete-other-windows) + (with-output-to-temp-buffer "*Org Export/Generic Styles Help*" + (princ help)) + (org-fit-window-to-buffer (get-buffer-window + "*Org Export/Generic Styles Help*")) + (message "Select command: ") + (setq r1 (read-char-exclusive)))) + (setq r2 (if (< r1 27) (+ r1 96) r1)) + (unless (setq ass (cadr (assq r2 cmds))) + (error "No command associated with key %c" r1)) + + (cdr (assoc + (if (equal ass "default") org-generic-export-type ass) + org-generic-alist)))) + + (custom-times org-display-custom-times) + (org-generic-current-indentation '(0 . 0)) + (level 0) (old-level 0) line txt lastwastext + (umax nil) + (umax-toc nil) + (case-fold-search nil) + (bfname (buffer-file-name (or (buffer-base-buffer) (current-buffer)))) + (filesuffix (or (plist-get export-plist :file-suffix) ".foo")) + (filename (concat (file-name-as-directory + (org-export-directory :ascii opt-plist)) + (file-name-sans-extension + (or (and subtree-p + (org-entry-get (region-beginning) + "EXPORT_FILE_NAME" t)) + (file-name-nondirectory bfname))) + filesuffix)) + (filename (if (equal (file-truename filename) + (file-truename bfname)) + (concat filename filesuffix) + filename)) + (buffer (find-file-noselect filename)) + (org-levels-open (make-vector org-level-max nil)) + (odd org-odd-levels-only) + (date (plist-get opt-plist :date)) + (author (plist-get opt-plist :author)) + (title (or (and subtree-p (org-export-get-title-from-subtree)) + (plist-get opt-plist :title) + (and (not + (plist-get opt-plist :skip-before-1st-heading)) + (org-export-grab-title-from-buffer)) + (file-name-sans-extension + (file-name-nondirectory bfname)))) + (email (plist-get opt-plist :email)) + (language (plist-get opt-plist :language)) + (quote-re0 (concat "^[ \t]*" org-quote-string "\\>")) +; (quote-re (concat "^\\(\\*+\\)\\([ \t]*" org-quote-string "\\>\\)")) + (todo nil) + (lang-words nil) + (region + (buffer-substring + (if (org-region-active-p) (region-beginning) (point-min)) + (if (org-region-active-p) (region-end) (point-max)))) + (org-export-current-backend 'org-export-generic) + (lines (org-split-string + (org-export-preprocess-string + region + :for-backend 'ascii + :skip-before-1st-heading + (plist-get opt-plist :skip-before-1st-heading) + :drawers (plist-get export-plist :drawers-export) + :tags (plist-get export-plist :tags-export) + :priority (plist-get export-plist :priority-export) + :footnotes (plist-get export-plist :footnotes-export) + :timestamps (plist-get export-plist :timestamps-export) + :todo-keywords (plist-get export-plist :todo-keywords-export) + :verbatim-multiline t + :select-tags (plist-get export-plist :select-tags-export) + :exclude-tags (plist-get export-plist :exclude-tags-export) + :emph-multiline t + :archived-trees + (plist-get export-plist :archived-trees-export) + :add-text (plist-get opt-plist :text)) + "\n")) + ;; export-generic plist variables + (withtags (plist-get export-plist :tags-export)) + (tagsintoc (plist-get export-plist :toc-tags-export)) + (tocnotagsstr (or (plist-get export-plist :toc-tags-none-string) "")) + (tocdepth (plist-get export-plist :toc-indent-depth)) + (tocindentchar (plist-get export-plist :toc-indent-char)) + (tocsecnums (plist-get export-plist :toc-section-numbers)) + (tocsecnumform (plist-get export-plist :toc-section-number-format)) + (tocformat (plist-get export-plist :toc-format)) + (tocformtodo (plist-get export-plist :toc-format-with-todo)) + (tocprefix (plist-get export-plist :toc-prefix)) + (tocsuffix (plist-get export-plist :toc-suffix)) + (bodyfixedpre (plist-get export-plist :body-line-fixed-prefix)) + (bodyfixedsuf (plist-get export-plist :body-line-fixed-suffix)) + (bodyfixedform (or (plist-get export-plist :body-line-fixed-format) + "%s")) + (listprefix (plist-get export-plist :body-list-prefix)) + (listsuffix (plist-get export-plist :body-list-suffix)) + (listformat (or (plist-get export-plist :body-list-format) "%s\n")) + (numlistleavenum + (plist-get export-plist :body-number-list-leave-number)) + (numlistprefix (plist-get export-plist :body-number-list-prefix)) + (numlistsuffix (plist-get export-plist :body-number-list-suffix)) + (numlistformat + (or (plist-get export-plist :body-number-list-format) "%s\n")) + (listchecktodo + (or (plist-get export-plist :body-list-checkbox-todo) "\\1")) + (listcheckdone + (or (plist-get export-plist :body-list-checkbox-done) "\\1")) + (listcheckhalf + (or (plist-get export-plist :body-list-checkbox-half) "\\1")) + (listchecktodoend + (or (plist-get export-plist :body-list-checkbox-todo-end) "")) + (listcheckdoneend + (or (plist-get export-plist :body-list-checkbox-done-end) "")) + (listcheckhalfend + (or (plist-get export-plist :body-list-checkbox-half-end) "")) + (bodytablestart + (or (plist-get export-plist :body-table-start) "")) + (bodytableend + (or (plist-get export-plist :body-table-end) "")) + (bodytablerowstart + (or (plist-get export-plist :body-table-row-start) "")) + (bodytablerowend + (or (plist-get export-plist :body-table-row-end) "")) + (bodytablecellstart + (or (plist-get export-plist :body-table-cell-start) "")) + (bodytablecellend + (or (plist-get export-plist :body-table-cell-end) "")) + (bodytablefirstcellstart + (or (plist-get export-plist :body-table-first-cell-start) "")) + (bodytableinteriorcellstart + (or (plist-get export-plist :body-table-interior-cell-start) "")) + (bodytableinteriorcellend + (or (plist-get export-plist :body-table-interior-cell-end) "")) + (bodytablelastcellend + (or (plist-get export-plist :body-table-last-cell-end) "")) + (bodytablehlinestart + (or (plist-get export-plist :body-table-hline-start) " \\1")) + (bodytablehlineend + (or (plist-get export-plist :body-table-hline-end) "")) + + + + (bodynewline-paragraph (plist-get export-plist :body-newline-paragraph)) + (bodytextpre (plist-get export-plist :body-text-prefix)) + (bodytextsuf (plist-get export-plist :body-text-suffix)) + (bodylinewrap (plist-get export-plist :body-line-wrap)) + (bodylineform (or (plist-get export-plist :body-line-format) "%s")) + (blockquotestart (or (plist-get export-plist :blockquote-start) "\n\n\t")) + (blockquoteend (or (plist-get export-plist :blockquote-end) "\n\n")) + + ;; dynamic variables used heinously in fontification + ;; not referenced locally... + (format-boldify (plist-get export-plist :bold-format)) + (format-italicize (plist-get export-plist :italic-format)) + (format-underline (plist-get export-plist :underline-format)) + (format-strikethrough (plist-get export-plist :strikethrough-format)) + (format-code (plist-get export-plist :code-format)) + (format-verbatim (plist-get export-plist :verbatim-format)) + + + + thetoc toctags have-headings first-heading-pos + table-open table-buffer link-buffer link desc desc0 rpl wrap) + + (let ((inhibit-read-only t)) + (org-unmodified + (remove-text-properties (point-min) (point-max) + '(:org-license-to-kill t)))) + + (setq org-min-level (org-get-min-level lines level-offset)) + (setq org-last-level org-min-level) + (org-init-section-numbers) + + (find-file-noselect filename) + + (setq lang-words (or (assoc language org-export-language-setup) + (assoc "en" org-export-language-setup))) + (switch-to-buffer-other-window buffer) + (erase-buffer) + (fundamental-mode) + ;; create local variables for all options, to make sure all called + ;; functions get the correct information + (mapc (lambda (x) + (set (make-local-variable (nth 2 x)) + (plist-get opt-plist (car x)))) + org-export-plist-vars) + (org-set-local 'org-odd-levels-only odd) + (setq umax (if arg (prefix-numeric-value arg) + org-export-headline-levels)) + (setq umax-toc umax) + + ;; File header + (if title + (insert + (org-export-generic-header title export-plist + :title-prefix + :title-format + :title-suffix))) + + (if (and (or author email) + (plist-get export-plist :author-export)) + (insert (concat (nth 1 lang-words) ": " (or author "") + (if email (concat " <" email ">") "") + "\n"))) + + (cond + ((and date (string-match "%" date)) + (setq date (format-time-string date))) + (date) + (t (setq date (format-time-string "%Y-%m-%d %T %Z")))) + + (if (and date (plist-get export-plist :date-export)) + (insert + (org-export-generic-header date export-plist + :date-prefix + :date-format + :date-suffix))) + + ;; export the table of contents first + (if (plist-get export-plist :toc-export) + (progn + (push + (org-export-generic-header (nth 3 lang-words) export-plist + :toc-header-prefix + :toc-header-format + :toc-header-suffix) + thetoc) + + (if tocprefix + (push tocprefix thetoc)) + + (mapc '(lambda (line) + (if (string-match org-todo-line-regexp line) + ;; This is a headline + (progn + (setq have-headings t) + (setq level (- (match-end 1) (match-beginning 1) + level-offset) + level (org-tr-level level) + txt (match-string 3 line) + todo + (or (and org-export-mark-todo-in-toc + (match-beginning 2) + (not (member (match-string 2 line) + org-done-keywords))) + ; TODO, not DONE + (and org-export-mark-todo-in-toc + (= level umax-toc) + (org-search-todo-below + line lines level)))) + (setq txt (org-html-expand-for-generic txt)) + + (while (string-match org-bracket-link-regexp txt) + (setq txt + (replace-match + (match-string (if (match-end 2) 3 1) txt) + t t txt))) + + (if (and (not tagsintoc) + (string-match + (org-re "[ \t]+:[[:alnum:]_@:]+:[ \t]*$") + txt)) + (setq txt (replace-match "" t t txt)) + ; include tags but formated + (if (string-match + (org-re "[ \t]+:\\([[:alnum:]_@:]+\\):[ \t]*$") + txt) + (progn + (setq + toctags + (org-export-generic-header + (match-string 1 txt) + export-plist :toc-tags-prefix + :toc-tags-format :toc-tags-suffix)) + (string-match + (org-re "[ \t]+:[[:alnum:]_@:]+:[ \t]*$") + txt) + (setq txt (replace-match "" t t txt))) + (setq toctags tocnotagsstr))) + + (if (string-match quote-re0 txt) + (setq txt (replace-match "" t t txt))) + + (if (<= level umax-toc) + (progn + (push + (concat + + (make-string + (* (max 0 (- level org-min-level)) tocdepth) + tocindentchar) + + (if tocsecnums + (format tocsecnumform + (org-section-number level)) + "") + + (format + (if todo tocformtodo tocformat) + txt) + + toctags) + + thetoc) + (setq org-last-level level)) + )))) + lines) + (if tocsuffix + (push tocsuffix thetoc)) + (setq thetoc (if have-headings (nreverse thetoc) nil)))) + + (org-init-section-numbers) + (org-export-generic-check-section "top") + (while (setq line (pop lines)) + (when (and link-buffer (string-match org-outline-regexp-bol line)) + (org-export-generic-push-links (nreverse link-buffer)) + (setq link-buffer nil)) + (setq wrap nil) + ;; Remove the quoted HTML tags. + ;; XXX + (setq line (org-html-expand-for-generic line)) + ;; Replace links with the description when possible + ;; XXX + (while (string-match org-bracket-link-regexp line) + (setq link (match-string 1 line) + desc0 (match-string 3 line) + desc (or desc0 (match-string 1 line))) + (if (and (> (length link) 8) + (equal (substring link 0 8) "coderef:")) + (setq line (replace-match + (format (org-export-get-coderef-format (substring link 8) desc) + (cdr (assoc + (substring link 8) + org-export-code-refs))) + t t line)) + (setq rpl (concat "[" + (or (match-string 3 line) (match-string 1 line)) + "]")) + (when (and desc0 (not (equal desc0 link))) + (if org-export-generic-links-to-notes + (push (cons desc0 link) link-buffer) + (setq rpl (concat rpl " (" link ")") + wrap (+ (length line) (- (length (match-string 0 line))) + (length desc))))) + (setq line (replace-match rpl t t line)))) + (when custom-times + (setq line (org-translate-time line))) + (cond + ((string-match "^\\(\\*+\\)[ \t]+\\(.*\\)" line) + ;; + ;; a Headline + ;; + (org-export-generic-check-section "headline") + + (setq first-heading-pos (or first-heading-pos (point))) + (setq level (org-tr-level (- (match-end 1) (match-beginning 1) + level-offset)) + txt (match-string 2 line)) + (org-generic-level-start level old-level txt umax export-plist lines) + (setq old-level level)) + + ((and org-export-with-tables + (string-match "^\\([ \t]*\\)\\(|\\|\\+-+\\+\\)" line)) + ;; + ;; a Table + ;; + (org-export-generic-check-section "table") + + (if (not table-open) + ;; New table starts + (setq table-open t table-buffer nil)) + ;; Accumulate table lines + (setq table-buffer (cons line table-buffer)) + (when (or (not lines) + (not (string-match "^\\([ \t]*\\)\\(|\\|\\+-+\\+\\)" + (car lines)))) + (setq table-open nil + table-buffer (nreverse table-buffer)) + (insert (mapconcat + (lambda (x) + (org-fix-indentation x org-generic-current-indentation)) + (org-format-table-generic table-buffer) + "\n") "\n"))) + + ((string-match "^\\([ \t]*\\)\\(:\\( \\|$\\)\\)" line) + ;; + ;; pre-formatted text + ;; + (setq line (replace-match "\\1" nil nil line)) + + (org-export-generic-check-section "preformat" bodyfixedpre bodyfixedsuf) + + (insert (format bodyfixedform line))) + + ((or (string-match "^\\([ \t]*\\)\\([\-\+][ \t]*\\)" line) + ;; if the bullet list item is an asterisk, the leading space is /mandatory/ + ;; [2010/02/02:rpg] + (string-match "^\\([ \t]+\\)\\(\\*[ \t]*\\)" line)) + ;; + ;; plain list item + ;; TODO: nested lists + ;; + ;; first add a line break between any previous paragraph or line item and this + ;; one + (when bodynewline-paragraph + (insert bodynewline-paragraph)) + + ;; I believe this gets rid of leading whitespace. + (setq line (replace-match "" nil nil line)) + + ;; won't this insert the suffix /before/ the last line of the list? + ;; also isn't it spoofed by bulleted lists that have a line skip between the list items + ;; unless 'org-empty-line-terminates-plain-lists' is true? + (org-export-generic-check-section "liststart" listprefix listsuffix) + + ;; deal with checkboxes + (cond + ((string-match "^\\(\\[ \\]\\)[ \t]*" line) + (setq line (concat (replace-match listchecktodo nil nil line) + listchecktodoend))) + ((string-match "^\\(\\[X\\]\\)[ \t]*" line) + (setq line (concat (replace-match listcheckdone nil nil line) + listcheckdoneend))) + ((string-match "^\\(\\[/\\]\\)[ \t]*" line) + (setq line (concat (replace-match listcheckhalf nil nil line) + listcheckhalfend))) + ) + + (insert (format listformat (org-export-generic-fontify line)))) + ((string-match "^\\([ \t]+\\)\\([0-9]+\\.[ \t]*\\)" line) + ;; + ;; numbered list item + ;; + ;; TODO: nested lists + ;; + (setq line (replace-match (if numlistleavenum "\\2" "") nil nil line)) + + (org-export-generic-check-section "numliststart" + numlistprefix numlistsuffix) + + ;; deal with checkboxes + ;; TODO: whoops; leaving the numbers is a problem for ^ matching + (cond + ((string-match "\\(\\[ \\]\\)[ \t]*" line) + (setq line (concat (replace-match listchecktodo nil nil line) + listchecktodoend))) + ((string-match "\\(\\[X\\]\\)[ \t]*" line) + (setq line (concat (replace-match listcheckdone nil nil line) + listcheckdoneend))) + ((string-match "\\(\\[/\\]\\)[ \t]*" line) + (setq line (concat (replace-match listcheckhalf nil nil line) + listcheckhalfend))) + ) + + (insert (format numlistformat (org-export-generic-fontify line)))) + + ((equal line "ORG-BLOCKQUOTE-START") + (setq line blockquotestart)) + ((equal line "ORG-BLOCKQUOTE-END") + (setq line blockquoteend)) + ((string-match "^\\s-*$" line) + ;; blank line + (if bodynewline-paragraph + (insert bodynewline-paragraph))) + (t + ;; + ;; body + ;; + (org-export-generic-check-section "body" bodytextpre bodytextsuf) + + (setq line + (org-export-generic-fontify line)) + + ;; XXX: properties? list? + (if (string-match "^\\([ \t]*\\)\\([-+*][ \t]+\\)\\(.*?\\)\\( ::\\)" line) + (setq line (replace-match "\\1\\3:" t nil line))) + + (setq line (org-fix-indentation line org-generic-current-indentation)) + + ;; Remove forced line breaks + (if (string-match "\\\\\\\\[ \t]*$" line) + (setq line (replace-match "" t t line))) + + (if bodylinewrap + ;; XXX: was dependent on wrap var which was calculated by??? + (if (> (length line) bodylinewrap) + (setq line + (org-export-generic-wrap line bodylinewrap)) + (setq line line))) + (insert (format bodylineform line))))) + + ;; if we're at a level > 0; insert the closing body level stuff + (let ((counter 0)) + (while (> (- level counter) 0) + (insert + (org-export-generic-format export-plist :body-section-suffix 0 + (- level counter))) + (setq counter (1+ counter)))) + + (org-export-generic-check-section "bottom") + + (org-export-generic-push-links (nreverse link-buffer)) + + (normal-mode) + + ;; insert the table of contents + (when thetoc + (goto-char (point-min)) + (if (re-search-forward "^[ \t]*\\[TABLE-OF-CONTENTS\\][ \t]*$" nil t) + (progn + (goto-char (match-beginning 0)) + (replace-match "")) + (goto-char first-heading-pos)) + (mapc 'insert thetoc) + (or (looking-at "[ \t]*\n[ \t]*\n") + (insert "\n\n"))) + + ;; Convert whitespace place holders + (goto-char (point-min)) + (let (beg end) + (while (setq beg (next-single-property-change (point) 'org-whitespace)) + (setq end (next-single-property-change beg 'org-whitespace)) + (goto-char beg) + (delete-region beg end) + (insert (make-string (- end beg) ?\ )))) + + (save-buffer) + + ;; remove display and invisible chars + (let (beg end) + (goto-char (point-min)) + (while (setq beg (next-single-property-change (point) 'display)) + (setq end (next-single-property-change beg 'display)) + (delete-region beg end) + (goto-char beg) + (insert "=>")) + (goto-char (point-min)) + (while (setq beg (next-single-property-change (point) 'org-cwidth)) + (setq end (next-single-property-change beg 'org-cwidth)) + (delete-region beg end) + (goto-char beg))) + (goto-char (point-min)))) + + +(defun org-export-generic-format (export-plist prop &optional len n reverse) + "converts a property specification to a string given types of properties + +The EXPORT-PLIST should be defined as the lookup plist. +The PROP should be the property name to search for in it. +LEN is set to the length of multi-characters strings to generate (or 0) +N is the tree depth +REVERSE means to reverse the list if the plist match is a list + " + (let* ((prefixtype (plist-get export-plist prop)) + subtype) + (cond + ((null prefixtype) "") + ((and len (char-or-string-p prefixtype) (not (stringp prefixtype))) + ;; sequence of chars + (concat (make-string len prefixtype) "\n")) + ((stringp prefixtype) + prefixtype) + ((and n (listp prefixtype)) + (if reverse + (setq prefixtype (reverse prefixtype))) + (setq subtype (if (> n (length prefixtype)) + (car (last prefixtype)) + (nth (1- n) prefixtype))) + (if (stringp subtype) + subtype + (concat (make-string len subtype) "\n"))) + (t "")) + )) + +(defun org-export-generic-header (header export-plist + prefixprop formatprop postfixprop + &optional n reverse) + "convert a header to an output string given formatting property names" + (let* ((formatspec (plist-get export-plist formatprop)) + (len (length header))) + (concat + (org-export-generic-format export-plist prefixprop len n reverse) + (format (or formatspec "%s") header) + (org-export-generic-format export-plist postfixprop len n reverse)) + )) + +(defun org-export-generic-preprocess (parameters) + "Do extra work for ASCII export" + ;; Put quotes around verbatim text + (goto-char (point-min)) + (while (re-search-forward org-verbatim-re nil t) + (goto-char (match-end 2)) + (backward-delete-char 1) (insert "'") + (goto-char (match-beginning 2)) + (delete-char 1) (insert "`") + (goto-char (match-end 2))) + ;; Remove target markers + (goto-char (point-min)) + (while (re-search-forward "<<]*\\)>>>?\\([ \t]*\\)" nil t) + (replace-match "\\1\\2"))) + +(defun org-html-expand-for-generic (line) + "Handle quoted HTML for ASCII export." + (if org-export-html-expand + (while (string-match "@<[^<>\n]*>" line) + ;; We just remove the tags for now. + (setq line (replace-match "" nil nil line)))) + line) + +(defun org-export-generic-wrap (line where) + "Wrap LINE at or before WHERE." + (let* ((ind (org-get-indentation line)) + (indstr (make-string ind ?\ )) + (len (length line)) + (result "") + pos didfirst) + (while (> len where) + (catch 'found + (loop for i from where downto (/ where 2) do + (and (equal (aref line i) ?\ ) + (setq pos i) + (throw 'found t)))) + (if pos + (progn + (setq result + (concat result + (if didfirst indstr "") + (substring line 0 pos) + "\n")) + (setq didfirst t) + (setq line (substring line (1+ pos))) + (setq len (length line))) + (setq result (concat result line)) + (setq len 0))) + (concat result indstr line))) + +(defun org-export-generic-push-links (link-buffer) + "Push out links in the buffer." + (when link-buffer + ;; We still have links to push out. + (insert "\n") + (let ((ind "")) + (save-match-data + (if (save-excursion + (re-search-backward + "^\\(\\([ \t]*\\)\\|\\(\\*+ \\)\\)[^ \t\n]" nil t)) + (setq ind (or (match-string 2) + (make-string (length (match-string 3)) ?\ ))))) + (mapc (lambda (x) (insert ind "[" (car x) "]: " (cdr x) "\n")) + link-buffer)) + (insert "\n"))) + +(defun org-generic-level-start (level old-level title umax export-plist + &optional lines) + "Insert a new level in a generic export." + (let ((n (- level umax 1)) + (ind 0) + (diff (- level old-level)) (counter 0) + (secnums (plist-get export-plist :body-header-section-numbers)) + (secnumformat + (plist-get export-plist :body-header-section-number-format)) + char tagstring) + (unless org-export-with-tags + (if (string-match (org-re "[ \t]+\\(:[[:alnum:]_@:]+:\\)[ \t]*$") title) + (setq title (replace-match "" t t title)))) + + (cond + ;; going deeper + ((> level old-level) + (while (< (+ old-level counter) (1- level)) + (insert + (org-export-generic-format export-plist :body-section-prefix 0 + (+ old-level counter))) + (setq counter (1+ counter)) + )) + ;; going up + ((< level old-level) + (while (> (- old-level counter) (1- level)) + (insert + (org-export-generic-format export-plist :body-section-suffix 0 + (- old-level counter))) + (setq counter (1+ counter)) + )) + ;; same level + ((= level old-level) + (insert + (org-export-generic-format export-plist :body-section-suffix 0 level)) + ) + ) + (insert + (org-export-generic-format export-plist :body-section-prefix 0 level)) + + (if (and org-export-with-section-numbers + secnums + (or (not (numberp secnums)) + (< level secnums))) + (setq title + (concat (format (or secnumformat "%s ") + (org-section-number level)) title))) + + ;; handle tags and formatting + (if (string-match + (org-re "[ \t]+:\\([[:alnum:]_@:]+\\):[ \t]*$") title) + (progn + (if (plist-get export-plist :body-tags-export) + (setq tagstring (org-export-generic-header (match-string 1 title) + export-plist + :body-tags-prefix + :body-tags-format + :body-tags-suffix))) + (string-match (org-re "[ \t]+:[[:alnum:]_@:]+:[ \t]*$") title) + (setq title (replace-match "" t t title))) + (setq tagstring (plist-get export-plist :body-tags-none-string))) + + (insert + (org-export-generic-header title export-plist + :body-section-header-prefix + :body-section-header-format + :body-section-header-suffix + level)) + (if tagstring + (insert tagstring)) + + (setq org-generic-current-indentation '(0 . 0)))) + +(defun org-insert-centered (s &optional underline) + "Insert the string S centered and underline it with character UNDERLINE." + (let ((ind (max (/ (- fill-column (string-width s)) 2) 0))) + (insert (make-string ind ?\ ) s "\n") + (if underline + (insert (make-string ind ?\ ) + (make-string (string-width s) underline) + "\n")))) + +(defvar org-table-colgroup-info nil) +(defun org-format-table-generic (lines) + "Format a table for ascii export." + (if (stringp lines) + (setq lines (org-split-string lines "\n"))) + (if (not (string-match "^[ \t]*|" (car lines))) + ;; Table made by table.el - test for spanning + lines + + ;; A normal org table + ;; Get rid of hlines at beginning and end + (if (string-match "^[ \t]*|-" (car lines)) (setq lines (cdr lines))) + (setq lines (nreverse lines)) + (if (string-match "^[ \t]*|-" (car lines)) (setq lines (cdr lines))) + (setq lines (nreverse lines)) + (when org-export-table-remove-special-lines + ;; Check if the table has a marking column. If yes remove the + ;; column and the special lines + (setq lines (org-table-clean-before-export lines))) + ;; Get rid of the vertical lines except for grouping + (let ((vl (org-colgroup-info-to-vline-list org-table-colgroup-info)) + (rtn (list bodytablestart)) line vl1 start) + (while (setq line (pop lines)) + (setq line (concat bodytablerowstart line)) + (if (string-match org-table-hline-regexp line) + (and (string-match "|\\(.*\\)|" line) + (setq line (replace-match (concat bodytablehlinestart bodytablehlineend) t nil line))) + (setq start 0 vl1 vl) + (if (string-match "|\\(.*\\)|" line) + (setq line (replace-match (concat bodytablefirstcellstart bodytablecellstart " \\1 " bodytablecellend bodytablelastcellend) t nil line))) + (while (string-match "|" line start) + (setq start (+ (match-end 0) (length (concat bodytablecellend bodytableinteriorcellend bodytableinteriorcellstart bodytablecellstart)))) + (or (pop vl1) (setq line (replace-match (concat bodytablecellend bodytableinteriorcellend bodytableinteriorcellstart bodytablecellstart) t t line))))) + (setq line (concat line bodytablerowend)) + (push line rtn)) + (setq rtn (cons bodytableend rtn)) + (nreverse rtn)))) + +(defun org-colgroup-info-to-vline-list (info) + (let (vl new last) + (while info + (setq last new new (pop info)) + (if (or (memq last '(:end :startend)) + (memq new '(:start :startend))) + (push t vl) + (push nil vl))) + (setq vl (nreverse vl)) + (and vl (setcar vl nil)) + vl)) + + +;;; FIXME: this should probably turn into a defconstant later [2010/05/20:rpg] +(defvar org-export-generic-emphasis-alist + '(("*" format-boldify nil) + ("/" format-italicize nil) + ("_" format-underline nil) + ("+" format-strikethrough nil) + ("=" format-code t) + ("~" format-verbatim t)) + "Alist of org format -> formatting variables for fontification. +Each element of the list is a list of three elements. +The first element is the character used as a marker for fontification. +The second element is a variable name, set in org-export-generic. That +variable will be dereferenced to obtain a formatting string to wrap +fontified text with. +The third element decides whether to protect converted text from other +conversions.") + +;;; Cargo-culted from the latex translation. I couldn't figure out how +;;; to keep the structure since the generic export operates on lines, rather +;;; than on a buffer as in the latex export, meaning that none of the +;;; search forward code could be kept. This led me to rewrite the +;;; whole thing recursively. A huge lose for efficiency (potentially), +;;; but I couldn't figure out how to make the looping work. +;;; Worse, it's /doubly/ recursive, because this function calls +;;; org-export-generic-emph-format, which can call it recursively... +;;; [2010/05/20:rpg] +(defun org-export-generic-fontify (string) + "Convert fontification according to generic rules." + (if (string-match org-emph-re string) + ;; The match goes one char after the *string*, except at the end of a line + (let ((emph (assoc (match-string 3 string) + org-export-generic-emphasis-alist)) + (beg (match-beginning 0)) + (end (match-end 0))) + (unless emph + (message "`org-export-generic-emphasis-alist' has no entry for formatting triggered by \"%s\"" + (match-string 3 string))) + ;; now we need to determine whether we have strikethrough or + ;; a list, which is a bit nasty + (if (and (equal (match-string 3 string) "+") + (save-match-data + (string-match "\\`-+\\'" (match-string 4 string)))) + ;; a list --- skip this match and recurse on the point after the + ;; first emph char... + (concat (substring string 0 (1+ (match-beginning 3))) + (org-export-generic-fontify (substring string (match-beginning 3)))) + (concat (substring string 0 beg) ;; part before the match + (match-string 1 string) + (org-export-generic-emph-format (second emph) + (match-string 4 string) + (third emph)) + (or (match-string 5 string) "") + (org-export-generic-fontify (substring string end))))) + string)) + +(defun org-export-generic-emph-format (format-varname string protect) + "Return a string that results from applying the markup indicated by +FORMAT-VARNAME to STRING." + (let ((format (symbol-value format-varname))) + (let ((string-to-emphasize + (if protect + string + (org-export-generic-fontify string)))) + (if format + (format format string-to-emphasize) + string-to-emphasize)))) + +(provide 'org-generic) +(provide 'org-export-generic) + +;;; org-export-generic.el ends here diff --git a/contrib/lisp/org-export.el b/contrib/lisp/org-export.el new file mode 100644 index 0000000..4f01b7e --- /dev/null +++ b/contrib/lisp/org-export.el @@ -0,0 +1,4518 @@ +;;; org-export.el --- Generic Export Engine For Org + +;; Copyright (C) 2012 Free Software Foundation, Inc. + +;; Author: Nicolas Goaziou +;; Keywords: outlines, hypermedia, calendar, wp + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: +;; +;; This library implements a generic export engine for Org, built on +;; its syntactical parser: Org Elements. +;; +;; Besides that parser, the generic exporter is made of three distinct +;; parts: +;; +;; - The communication channel consists in a property list, which is +;; created and updated during the process. Its use is to offer +;; every piece of information, would it be about initial environment +;; or contextual data, all in a single place. The exhaustive list +;; of properties is given in "The Communication Channel" section of +;; this file. +;; +;; - The transcoder walks the parse tree, ignores or treat as plain +;; text elements and objects according to export options, and +;; eventually calls back-end specific functions to do the real +;; transcoding, concatenating their return value along the way. +;; +;; - The filter system is activated at the very beginning and the very +;; end of the export process, and each time an element or an object +;; has been converted. It is the entry point to fine-tune standard +;; output from back-end transcoders. See "The Filter System" +;; section for more information. +;; +;; The core function is `org-export-as'. It returns the transcoded +;; buffer as a string. +;; +;; An export back-end is defined with `org-export-define-backend', +;; which sets one mandatory variable: his translation table. Its name +;; is always `org-BACKEND-translate-alist' where BACKEND stands for +;; the name chosen for the back-end. Its value is an alist whose keys +;; are elements and objects types and values translator functions. +;; See function's docstring for more information about translators. +;; +;; Optionally, `org-export-define-backend' can also support specific +;; buffer keywords, OPTION keyword's items and filters. Also refer to +;; function documentation for more information. +;; +;; If the new back-end shares most properties with another one, +;; `org-export-define-derived-backend' can be used to simplify the +;; process. +;; +;; Any back-end can define its own variables. Among them, those +;; customizable should belong to the `org-export-BACKEND' group. +;; +;; Tools for common tasks across back-ends are implemented in the +;; penultimate part of this file. A dispatcher for standard back-ends +;; is provided in the last one. + +;;; Code: + +(eval-when-compile (require 'cl)) +(require 'org-element) + + +(declare-function org-e-ascii-export-as-ascii "org-e-ascii" + (&optional subtreep visible-only body-only ext-plist)) +(declare-function org-e-ascii-export-to-ascii "org-e-ascii" + (&optional subtreep visible-only body-only ext-plist pub-dir)) +(declare-function org-e-html-export-as-html "org-e-html" + (&optional subtreep visible-only body-only ext-plist)) +(declare-function org-e-html-export-to-html "org-e-html" + (&optional subtreep visible-only body-only ext-plist pub-dir)) +(declare-function org-e-latex-export-as-latex "org-e-latex" + (&optional subtreep visible-only body-only ext-plist)) +(declare-function org-e-latex-export-to-latex "org-e-latex" + (&optional subtreep visible-only body-only ext-plist pub-dir)) +(declare-function org-e-latex-export-to-pdf "org-e-latex" + (&optional subtreep visible-only body-only ext-plist pub-dir)) +(declare-function org-e-odt-export-to-odt "org-e-odt" + (&optional subtreep visible-only body-only ext-plist pub-dir)) +(declare-function org-e-publish "org-e-publish" (project &optional force)) +(declare-function org-e-publish-all "org-e-publish" (&optional force)) +(declare-function org-e-publish-current-file "org-e-publish" (&optional force)) +(declare-function org-e-publish-current-project "org-e-publish" + (&optional force)) +(declare-function org-export-blocks-preprocess "org-exp-blocks") + +(defvar org-e-publish-project-alist) +(defvar org-table-number-fraction) +(defvar org-table-number-regexp) + + + +;;; Internal Variables +;; +;; Among internal variables, the most important is +;; `org-export-options-alist'. This variable define the global export +;; options, shared between every exporter, and how they are acquired. + +(defconst org-export-max-depth 19 + "Maximum nesting depth for headlines, counting from 0.") + +(defconst org-export-options-alist + '((:author "AUTHOR" nil user-full-name t) + (:creator "CREATOR" nil org-export-creator-string) + (:date "DATE" nil nil t) + (:description "DESCRIPTION" nil nil newline) + (:email "EMAIL" nil user-mail-address t) + (:exclude-tags "EXCLUDE_TAGS" nil org-export-exclude-tags split) + (:headline-levels nil "H" org-export-headline-levels) + (:keywords "KEYWORDS" nil nil space) + (:language "LANGUAGE" nil org-export-default-language t) + (:preserve-breaks nil "\\n" org-export-preserve-breaks) + (:section-numbers nil "num" org-export-with-section-numbers) + (:select-tags "SELECT_TAGS" nil org-export-select-tags split) + (:time-stamp-file nil "timestamp" org-export-time-stamp-file) + (:title "TITLE" nil nil space) + (:with-archived-trees nil "arch" org-export-with-archived-trees) + (:with-author nil "author" org-export-with-author) + (:with-clocks nil "c" org-export-with-clocks) + (:with-creator nil "creator" org-export-with-creator) + (:with-drawers nil "d" org-export-with-drawers) + (:with-email nil "email" org-export-with-email) + (:with-emphasize nil "*" org-export-with-emphasize) + (:with-entities nil "e" org-export-with-entities) + (:with-fixed-width nil ":" org-export-with-fixed-width) + (:with-footnotes nil "f" org-export-with-footnotes) + (:with-inlinetasks nil "inline" org-export-with-inlinetasks) + (:with-plannings nil "p" org-export-with-planning) + (:with-priority nil "pri" org-export-with-priority) + (:with-special-strings nil "-" org-export-with-special-strings) + (:with-sub-superscript nil "^" org-export-with-sub-superscripts) + (:with-toc nil "toc" org-export-with-toc) + (:with-tables nil "|" org-export-with-tables) + (:with-tags nil "tags" org-export-with-tags) + (:with-tasks nil "tasks" org-export-with-tasks) + (:with-timestamps nil "<" org-export-with-timestamps) + (:with-todo-keywords nil "todo" org-export-with-todo-keywords)) + "Alist between export properties and ways to set them. + +The CAR of the alist is the property name, and the CDR is a list +like (KEYWORD OPTION DEFAULT BEHAVIOUR) where: + +KEYWORD is a string representing a buffer keyword, or nil. Each + property defined this way can also be set, during subtree + export, through an headline property named after the keyword + with the \"EXPORT_\" prefix (i.e. DATE keyword and EXPORT_DATE + property). +OPTION is a string that could be found in an #+OPTIONS: line. +DEFAULT is the default value for the property. +BEHAVIOUR determine how Org should handle multiple keywords for + the same property. It is a symbol among: + nil Keep old value and discard the new one. + t Replace old value with the new one. + `space' Concatenate the values, separating them with a space. + `newline' Concatenate the values, separating them with + a newline. + `split' Split values at white spaces, and cons them to the + previous list. + +KEYWORD and OPTION have precedence over DEFAULT. + +All these properties should be back-end agnostic. Back-end +specific properties are set through `org-export-define-backend'. +Properties redefined there have precedence over these.") + +(defconst org-export-special-keywords + '("SETUP_FILE" "OPTIONS" "MACRO") + "List of in-buffer keywords that require special treatment. +These keywords are not directly associated to a property. The +way they are handled must be hard-coded into +`org-export--get-inbuffer-options' function.") + +(defconst org-export-filters-alist + '((:filter-bold . org-export-filter-bold-functions) + (:filter-babel-call . org-export-filter-babel-call-functions) + (:filter-center-block . org-export-filter-center-block-functions) + (:filter-clock . org-export-filter-clock-functions) + (:filter-code . org-export-filter-code-functions) + (:filter-comment . org-export-filter-comment-functions) + (:filter-comment-block . org-export-filter-comment-block-functions) + (:filter-drawer . org-export-filter-drawer-functions) + (:filter-dynamic-block . org-export-filter-dynamic-block-functions) + (:filter-entity . org-export-filter-entity-functions) + (:filter-example-block . org-export-filter-example-block-functions) + (:filter-export-block . org-export-filter-export-block-functions) + (:filter-export-snippet . org-export-filter-export-snippet-functions) + (:filter-final-output . org-export-filter-final-output-functions) + (:filter-fixed-width . org-export-filter-fixed-width-functions) + (:filter-footnote-definition . org-export-filter-footnote-definition-functions) + (:filter-footnote-reference . org-export-filter-footnote-reference-functions) + (:filter-headline . org-export-filter-headline-functions) + (:filter-horizontal-rule . org-export-filter-horizontal-rule-functions) + (:filter-inline-babel-call . org-export-filter-inline-babel-call-functions) + (:filter-inline-src-block . org-export-filter-inline-src-block-functions) + (:filter-inlinetask . org-export-filter-inlinetask-functions) + (:filter-italic . org-export-filter-italic-functions) + (:filter-item . org-export-filter-item-functions) + (:filter-keyword . org-export-filter-keyword-functions) + (:filter-latex-environment . org-export-filter-latex-environment-functions) + (:filter-latex-fragment . org-export-filter-latex-fragment-functions) + (:filter-line-break . org-export-filter-line-break-functions) + (:filter-link . org-export-filter-link-functions) + (:filter-macro . org-export-filter-macro-functions) + (:filter-paragraph . org-export-filter-paragraph-functions) + (:filter-parse-tree . org-export-filter-parse-tree-functions) + (:filter-plain-list . org-export-filter-plain-list-functions) + (:filter-plain-text . org-export-filter-plain-text-functions) + (:filter-planning . org-export-filter-planning-functions) + (:filter-property-drawer . org-export-filter-property-drawer-functions) + (:filter-quote-block . org-export-filter-quote-block-functions) + (:filter-quote-section . org-export-filter-quote-section-functions) + (:filter-radio-target . org-export-filter-radio-target-functions) + (:filter-section . org-export-filter-section-functions) + (:filter-special-block . org-export-filter-special-block-functions) + (:filter-src-block . org-export-filter-src-block-functions) + (:filter-statistics-cookie . org-export-filter-statistics-cookie-functions) + (:filter-strike-through . org-export-filter-strike-through-functions) + (:filter-subscript . org-export-filter-subscript-functions) + (:filter-superscript . org-export-filter-superscript-functions) + (:filter-table . org-export-filter-table-functions) + (:filter-table-cell . org-export-filter-table-cell-functions) + (:filter-table-row . org-export-filter-table-row-functions) + (:filter-target . org-export-filter-target-functions) + (:filter-timestamp . org-export-filter-timestamp-functions) + (:filter-underline . org-export-filter-underline-functions) + (:filter-verbatim . org-export-filter-verbatim-functions) + (:filter-verse-block . org-export-filter-verse-block-functions)) + "Alist between filters properties and initial values. + +The key of each association is a property name accessible through +the communication channel. Its value is a configurable global +variable defining initial filters. + +This list is meant to install user specified filters. Back-end +developers may install their own filters using +`org-export-define-backend'. Filters defined there will always +be prepended to the current list, so they always get applied +first.") + +(defconst org-export-default-inline-image-rule + `(("file" . + ,(format "\\.%s\\'" + (regexp-opt + '("png" "jpeg" "jpg" "gif" "tiff" "tif" "xbm" + "xpm" "pbm" "pgm" "ppm") t)))) + "Default rule for link matching an inline image. +This rule applies to links with no description. By default, it +will be considered as an inline image if it targets a local file +whose extension is either \"png\", \"jpeg\", \"jpg\", \"gif\", +\"tiff\", \"tif\", \"xbm\", \"xpm\", \"pbm\", \"pgm\" or \"ppm\". +See `org-export-inline-image-p' for more information about +rules.") + + + +;;; User-configurable Variables +;; +;; Configuration for the masses. +;; +;; They should never be accessed directly, as their value is to be +;; stored in a property list (cf. `org-export-options-alist'). +;; Back-ends will read their value from there instead. + +(defgroup org-export nil + "Options for exporting Org mode files." + :tag "Org Export" + :group 'org) + +(defgroup org-export-general nil + "General options for export engine." + :tag "Org Export General" + :group 'org-export) + +(defcustom org-export-with-archived-trees 'headline + "Whether sub-trees with the ARCHIVE tag should be exported. + +This can have three different values: +nil Do not export, pretend this tree is not present. +t Do export the entire tree. +`headline' Only export the headline, but skip the tree below it. + +This option can also be set with the #+OPTIONS line, +e.g. \"arch:nil\"." + :group 'org-export-general + :type '(choice + (const :tag "Not at all" nil) + (const :tag "Headline only" 'headline) + (const :tag "Entirely" t))) + +(defcustom org-export-with-author t + "Non-nil means insert author name into the exported file. +This option can also be set with the #+OPTIONS line, +e.g. \"author:nil\"." + :group 'org-export-general + :type 'boolean) + +(defcustom org-export-with-clocks nil + "Non-nil means export CLOCK keywords. +This option can also be set with the #+OPTIONS line, +e.g. \"c:t\"." + :group 'org-export-general + :type 'boolean) + +(defcustom org-export-with-creator 'comment + "Non-nil means the postamble should contain a creator sentence. + +The sentence can be set in `org-export-creator-string' and +defaults to \"Generated by Org mode XX in Emacs XXX.\". + +If the value is `comment' insert it as a comment." + :group 'org-export-general + :type '(choice + (const :tag "No creator sentence" nil) + (const :tag "Sentence as a comment" 'comment) + (const :tag "Insert the sentence" t))) + +(defcustom org-export-creator-string + (format "Generated by Org mode %s in Emacs %s." + (if (fboundp 'org-version) (org-version) "(Unknown)") + emacs-version) + "String to insert at the end of the generated document." + :group 'org-export-general + :type '(string :tag "Creator string")) + +(defcustom org-export-with-drawers t + "Non-nil means export contents of standard drawers. + +When t, all drawers are exported. This may also be a list of +drawer names to export. This variable doesn't apply to +properties drawers. + +This option can also be set with the #+OPTIONS line, +e.g. \"d:nil\"." + :group 'org-export-general + :type '(choice + (const :tag "All drawers" t) + (const :tag "None" nil) + (repeat :tag "Selected drawers" + (string :tag "Drawer name")))) + +(defcustom org-export-with-email nil + "Non-nil means insert author email into the exported file. +This option can also be set with the #+OPTIONS line, +e.g. \"email:t\"." + :group 'org-export-general + :type 'boolean) + +(defcustom org-export-with-emphasize t + "Non-nil means interpret *word*, /word/, and _word_ as emphasized text. + +If the export target supports emphasizing text, the word will be +typeset in bold, italic, or underlined, respectively. Not all +export backends support this. + +This option can also be set with the #+OPTIONS line, e.g. \"*:nil\"." + :group 'org-export-general + :type 'boolean) + +(defcustom org-export-exclude-tags '("noexport") + "Tags that exclude a tree from export. + +All trees carrying any of these tags will be excluded from +export. This is without condition, so even subtrees inside that +carry one of the `org-export-select-tags' will be removed. + +This option can also be set with the #+EXCLUDE_TAGS: keyword." + :group 'org-export-general + :type '(repeat (string :tag "Tag"))) + +(defcustom org-export-with-fixed-width t + "Non-nil means lines starting with \":\" will be in fixed width font. + +This can be used to have pre-formatted text, fragments of code +etc. For example: + : ;; Some Lisp examples + : (while (defc cnt) + : (ding)) +will be looking just like this in also HTML. See also the QUOTE +keyword. Not all export backends support this. + +This option can also be set with the #+OPTIONS line, e.g. \"::nil\"." + :group 'org-export-translation + :type 'boolean) + +(defcustom org-export-with-footnotes t + "Non-nil means Org footnotes should be exported. +This option can also be set with the #+OPTIONS line, +e.g. \"f:nil\"." + :group 'org-export-general + :type 'boolean) + +(defcustom org-export-headline-levels 3 + "The last level which is still exported as a headline. + +Inferior levels will produce itemize lists when exported. + +This option can also be set with the #+OPTIONS line, e.g. \"H:2\"." + :group 'org-export-general + :type 'integer) + +(defcustom org-export-default-language "en" + "The default language for export and clocktable translations, as a string. +This may have an association in +`org-clock-clocktable-language-setup'." + :group 'org-export-general + :type '(string :tag "Language")) + +(defcustom org-export-preserve-breaks nil + "Non-nil means preserve all line breaks when exporting. + +Normally, in HTML output paragraphs will be reformatted. + +This option can also be set with the #+OPTIONS line, +e.g. \"\\n:t\"." + :group 'org-export-general + :type 'boolean) + +(defcustom org-export-with-entities t + "Non-nil means interpret entities when exporting. + +For example, HTML export converts \\alpha to α and \\AA to +Å. + +For a list of supported names, see the constant `org-entities' +and the user option `org-entities-user'. + +This option can also be set with the #+OPTIONS line, +e.g. \"e:nil\"." + :group 'org-export-general + :type 'boolean) + +(defcustom org-export-with-inlinetasks t + "Non-nil means inlinetasks should be exported. +This option can also be set with the #+OPTIONS line, +e.g. \"inline:nil\"." + :group 'org-export-general + :type 'boolean) + +(defcustom org-export-with-planning nil + "Non-nil means include planning info in export. +This option can also be set with the #+OPTIONS: line, +e.g. \"p:t\"." + :group 'org-export-general + :type 'boolean) + +(defcustom org-export-with-priority nil + "Non-nil means include priority cookies in export. +This option can also be set with the #+OPTIONS line, +e.g. \"pri:t\"." + :group 'org-export-general + :type 'boolean) + +(defcustom org-export-with-section-numbers t + "Non-nil means add section numbers to headlines when exporting. + +When set to an integer n, numbering will only happen for +headlines whose relative level is higher or equal to n. + +This option can also be set with the #+OPTIONS line, +e.g. \"num:t\"." + :group 'org-export-general + :type 'boolean) + +(defcustom org-export-select-tags '("export") + "Tags that select a tree for export. + +If any such tag is found in a buffer, all trees that do not carry +one of these tags will be ignored during export. Inside trees +that are selected like this, you can still deselect a subtree by +tagging it with one of the `org-export-exclude-tags'. + +This option can also be set with the #+SELECT_TAGS: keyword." + :group 'org-export-general + :type '(repeat (string :tag "Tag"))) + +(defcustom org-export-with-special-strings t + "Non-nil means interpret \"\-\", \"--\" and \"---\" for export. + +When this option is turned on, these strings will be exported as: + + Org HTML LaTeX + -----+----------+-------- + \\- ­ \\- + -- – -- + --- — --- + ... … \ldots + +This option can also be set with the #+OPTIONS line, +e.g. \"-:nil\"." + :group 'org-export-general + :type 'boolean) + +(defcustom org-export-with-sub-superscripts t + "Non-nil means interpret \"_\" and \"^\" for export. + +When this option is turned on, you can use TeX-like syntax for +sub- and superscripts. Several characters after \"_\" or \"^\" +will be considered as a single item - so grouping with {} is +normally not needed. For example, the following things will be +parsed as single sub- or superscripts. + + 10^24 or 10^tau several digits will be considered 1 item. + 10^-12 or 10^-tau a leading sign with digits or a word + x^2-y^3 will be read as x^2 - y^3, because items are + terminated by almost any nonword/nondigit char. + x_{i^2} or x^(2-i) braces or parenthesis do grouping. + +Still, ambiguity is possible - so when in doubt use {} to enclose +the sub/superscript. If you set this variable to the symbol +`{}', the braces are *required* in order to trigger +interpretations as sub/superscript. This can be helpful in +documents that need \"_\" frequently in plain text. + +This option can also be set with the #+OPTIONS line, +e.g. \"^:nil\"." + :group 'org-export-general + :type '(choice + (const :tag "Interpret them" t) + (const :tag "Curly brackets only" {}) + (const :tag "Do not interpret them" nil))) + +(defcustom org-export-with-toc t + "Non-nil means create a table of contents in exported files. + +The TOC contains headlines with levels up +to`org-export-headline-levels'. When an integer, include levels +up to N in the toc, this may then be different from +`org-export-headline-levels', but it will not be allowed to be +larger than the number of headline levels. When nil, no table of +contents is made. + +This option can also be set with the #+OPTIONS line, +e.g. \"toc:nil\" or \"toc:3\"." + :group 'org-export-general + :type '(choice + (const :tag "No Table of Contents" nil) + (const :tag "Full Table of Contents" t) + (integer :tag "TOC to level"))) + +(defcustom org-export-with-tables t + "If non-nil, lines starting with \"|\" define a table. +For example: + + | Name | Address | Birthday | + |-------------+----------+-----------| + | Arthur Dent | England | 29.2.2100 | + +This option can also be set with the #+OPTIONS line, e.g. \"|:nil\"." + :group 'org-export-general + :type 'boolean) + +(defcustom org-export-with-tags t + "If nil, do not export tags, just remove them from headlines. + +If this is the symbol `not-in-toc', tags will be removed from +table of contents entries, but still be shown in the headlines of +the document. + +This option can also be set with the #+OPTIONS line, +e.g. \"tags:nil\"." + :group 'org-export-general + :type '(choice + (const :tag "Off" nil) + (const :tag "Not in TOC" not-in-toc) + (const :tag "On" t))) + +(defcustom org-export-with-tasks t + "Non-nil means include TODO items for export. +This may have the following values: +t include tasks independent of state. +todo include only tasks that are not yet done. +done include only tasks that are already done. +nil remove all tasks before export +list of keywords keep only tasks with these keywords" + :group 'org-export-general + :type '(choice + (const :tag "All tasks" t) + (const :tag "No tasks" nil) + (const :tag "Not-done tasks" todo) + (const :tag "Only done tasks" done) + (repeat :tag "Specific TODO keywords" + (string :tag "Keyword")))) + +(defcustom org-export-time-stamp-file t + "Non-nil means insert a time stamp into the exported file. +The time stamp shows when the file was created. + +This option can also be set with the #+OPTIONS line, +e.g. \"timestamp:nil\"." + :group 'org-export-general + :type 'boolean) + +(defcustom org-export-with-timestamps t + "Non nil means allow timestamps in export. + +It can be set to `active', `inactive', t or nil, in order to +export, respectively, only active timestamps, only inactive ones, +all of them or none. + +This option can also be set with the #+OPTIONS line, e.g. +\"<:nil\"." + :group 'org-export-general + :type '(choice + (const :tag "All timestamps" t) + (const :tag "Only active timestamps" active) + (const :tag "Only inactive timestamps" inactive) + (const :tag "No timestamp" nil))) + +(defcustom org-export-with-todo-keywords t + "Non-nil means include TODO keywords in export. +When nil, remove all these keywords from the export." + :group 'org-export-general + :type 'boolean) + +(defcustom org-export-allow-BIND 'confirm + "Non-nil means allow #+BIND to define local variable values for export. +This is a potential security risk, which is why the user must +confirm the use of these lines." + :group 'org-export-general + :type '(choice + (const :tag "Never" nil) + (const :tag "Always" t) + (const :tag "Ask a confirmation for each file" confirm))) + +(defcustom org-export-snippet-translation-alist nil + "Alist between export snippets back-ends and exporter back-ends. + +This variable allows to provide shortcuts for export snippets. + +For example, with a value of '\(\(\"h\" . \"e-html\"\)\), the +HTML back-end will recognize the contents of \"@@h:@@\" as +HTML code while every other back-end will ignore it." + :group 'org-export-general + :type '(repeat + (cons + (string :tag "Shortcut") + (string :tag "Back-end")))) + +(defcustom org-export-coding-system nil + "Coding system for the exported file." + :group 'org-export-general + :type 'coding-system) + +(defcustom org-export-copy-to-kill-ring t + "Non-nil means exported stuff will also be pushed onto the kill ring." + :group 'org-export-general + :type 'boolean) + +(defcustom org-export-initial-scope 'buffer + "The initial scope when exporting with `org-export-dispatch'. +This variable can be either set to `buffer' or `subtree'." + :group 'org-export-general + :type '(choice + (const :tag "Export current buffer" 'buffer) + (const :tag "Export current subtree" 'subtree))) + +(defcustom org-export-show-temporary-export-buffer t + "Non-nil means show buffer after exporting to temp buffer. +When Org exports to a file, the buffer visiting that file is ever +shown, but remains buried. However, when exporting to +a temporary buffer, that buffer is popped up in a second window. +When this variable is nil, the buffer remains buried also in +these cases." + :group 'org-export-general + :type 'boolean) + +(defcustom org-export-dispatch-use-expert-ui nil + "Non-nil means using a non-intrusive `org-export-dispatch'. +In that case, no help buffer is displayed. Though, an indicator +for current export scope is added to the prompt \(i.e. \"b\" when +output is restricted to body only, \"s\" when it is restricted to +the current subtree and \"v\" when only visible elements are +considered for export\). Also, \[?] allows to switch back to +standard mode." + :group 'org-export-general + :type 'boolean) + + + +;;; Defining New Back-ends + +(defmacro org-export-define-backend (backend translators &rest body) + "Define a new back-end BACKEND. + +TRANSLATORS is an alist between object or element types and +functions handling them. + +These functions should return a string without any trailing +space, or nil. They must accept three arguments: the object or +element itself, its contents or nil when it isn't recursive and +the property list used as a communication channel. + +Contents, when not nil, are stripped from any global indentation +\(although the relative one is preserved). They also always end +with a single newline character. + +If, for a given type, no function is found, that element or +object type will simply be ignored, along with any blank line or +white space at its end. The same will happen if the function +returns the nil value. If that function returns the empty +string, the type will be ignored, but the blank lines or white +spaces will be kept. + +In addition to element and object types, one function can be +associated to the `template' symbol and another one to the +`plain-text' symbol. + +The former returns the final transcoded string, and can be used +to add a preamble and a postamble to document's body. It must +accept two arguments: the transcoded string and the property list +containing export options. + +The latter, when defined, is to be called on every text not +recognized as an element or an object. It must accept two +arguments: the text string and the information channel. It is an +appropriate place to protect special chars relative to the +back-end. + +BODY can start with pre-defined keyword arguments. The following +keywords are understood: + + :export-block + + String, or list of strings, representing block names that + will not be parsed. This is used to specify blocks that will + contain raw code specific to the back-end. These blocks + still have to be handled by the relative `export-block' type + translator. + + :filters-alist + + Alist between filters and function, or list of functions, + specific to the back-end. See `org-export-filters-alist' for + a list of all allowed filters. Filters defined here + shouldn't make a back-end test, as it may prevent back-ends + derived from this one to behave properly. + + :options-alist + + Alist between back-end specific properties introduced in + communication channel and how their value are acquired. See + `org-export-options-alist' for more information about + structure of the values. + +As an example, here is how the `e-ascii' back-end is defined: + +\(org-export-define-backend e-ascii + \((bold . org-e-ascii-bold) + \(center-block . org-e-ascii-center-block) + \(clock . org-e-ascii-clock) + \(code . org-e-ascii-code) + \(drawer . org-e-ascii-drawer) + \(dynamic-block . org-e-ascii-dynamic-block) + \(entity . org-e-ascii-entity) + \(example-block . org-e-ascii-example-block) + \(export-block . org-e-ascii-export-block) + \(export-snippet . org-e-ascii-export-snippet) + \(fixed-width . org-e-ascii-fixed-width) + \(footnote-definition . org-e-ascii-footnote-definition) + \(footnote-reference . org-e-ascii-footnote-reference) + \(headline . org-e-ascii-headline) + \(horizontal-rule . org-e-ascii-horizontal-rule) + \(inline-src-block . org-e-ascii-inline-src-block) + \(inlinetask . org-e-ascii-inlinetask) + \(italic . org-e-ascii-italic) + \(item . org-e-ascii-item) + \(keyword . org-e-ascii-keyword) + \(latex-environment . org-e-ascii-latex-environment) + \(latex-fragment . org-e-ascii-latex-fragment) + \(line-break . org-e-ascii-line-break) + \(link . org-e-ascii-link) + \(macro . org-e-ascii-macro) + \(paragraph . org-e-ascii-paragraph) + \(plain-list . org-e-ascii-plain-list) + \(plain-text . org-e-ascii-plain-text) + \(planning . org-e-ascii-planning) + \(property-drawer . org-e-ascii-property-drawer) + \(quote-block . org-e-ascii-quote-block) + \(quote-section . org-e-ascii-quote-section) + \(radio-target . org-e-ascii-radio-target) + \(section . org-e-ascii-section) + \(special-block . org-e-ascii-special-block) + \(src-block . org-e-ascii-src-block) + \(statistics-cookie . org-e-ascii-statistics-cookie) + \(strike-through . org-e-ascii-strike-through) + \(subscript . org-e-ascii-subscript) + \(superscript . org-e-ascii-superscript) + \(table . org-e-ascii-table) + \(table-cell . org-e-ascii-table-cell) + \(table-row . org-e-ascii-table-row) + \(target . org-e-ascii-target) + \(template . org-e-ascii-template) + \(timestamp . org-e-ascii-timestamp) + \(underline . org-e-ascii-underline) + \(verbatim . org-e-ascii-verbatim) + \(verse-block . org-e-ascii-verse-block)) + :export-block \"ASCII\" + :filters-alist ((:filter-headline . org-e-ascii-filter-headline-blank-lines) + \(:filter-section . org-e-ascii-filter-headline-blank-lines)) + :options-alist ((:ascii-charset nil nil org-e-ascii-charset)))" + (declare (debug (&define name sexp [&rest [keywordp sexp]] defbody)) + (indent 1)) + (let (filters options export-block) + (while (keywordp (car body)) + (case (pop body) + (:export-block (let ((names (pop body))) + (setq export-block + (if (consp names) (mapcar 'upcase names) + (list (upcase names)))))) + (:filters-alist (setq filters (pop body))) + (:options-alist (setq options (pop body))) + (t (pop body)))) + `(progn + ;; Define translators. + (defvar ,(intern (format "org-%s-translate-alist" backend)) ',translators + "Alist between element or object types and translators.") + ;; Define options. + ,(when options + `(defconst ,(intern (format "org-%s-options-alist" backend)) ',options + ,(format "Alist between %s export properties and ways to set them. +See `org-export-options-alist' for more information on the +structure of the values." + backend))) + ;; Define filters. + ,(when filters + `(defconst ,(intern (format "org-%s-filters-alist" backend)) ',filters + "Alist between filters keywords and back-end specific filters. +See `org-export-filters-alist' for more information.")) + ;; Tell parser to not parse EXPORT-BLOCK blocks. + ,(when export-block + `(mapc + (lambda (name) + (add-to-list 'org-element-block-name-alist + `(,name . org-element-export-block-parser))) + ',export-block)) + ;; Splice in the body, if any. + ,@body))) + +(defmacro org-export-define-derived-backend (child parent &rest body) + "Create a new back-end as a variant of an existing one. + +CHILD is the name of the derived back-end. PARENT is the name of +the parent back-end. + +BODY can start with pre-defined keyword arguments. The following +keywords are understood: + + :export-block + + String, or list of strings, representing block names that + will not be parsed. This is used to specify blocks that will + contain raw code specific to the back-end. These blocks + still have to be handled by the relative `export-block' type + translator. + + :filters-alist + + Alist of filters that will overwrite or complete filters + defined in PARENT back-end. See `org-export-filters-alist' + for more a list of allowed filters. + + :options-alist + + Alist of back-end specific properties that will overwrite or + complete those defined in PARENT back-end. Refer to + `org-export-options-alist' for more information about + structure of the values. + + :translate-alist + + Alist of element and object types and transcoders that will + overwrite or complete transcode table from PARENT back-end. + Refer to `org-export-define-backend' for detailed information + about transcoders. + +As an example, here is how one could define \"my-latex\" back-end +as a variant of `e-latex' back-end with a custom template +function: + + \(org-export-define-derived-backend my-latex e-latex + :translate-alist ((template . my-latex-template-fun))) + +The back-end could then be called with, for example: + + \(org-export-to-buffer 'my-latex \"*Test my-latex*\")" + (declare (debug (&define name sexp [&rest [keywordp sexp]] def-body)) + (indent 2)) + (let (filters options translate export-block) + (while (keywordp (car body)) + (case (pop body) + (:export-block (let ((names (pop body))) + (setq export-block + (if (consp names) (mapcar 'upcase names) + (list (upcase names)))))) + (:filters-alist (setq filters (pop body))) + (:options-alist (setq options (pop body))) + (:translate-alist (setq translate (pop body))) + (t (pop body)))) + `(progn + ;; Tell parser to not parse EXPORT-BLOCK blocks. + ,(when export-block + `(mapc + (lambda (name) + (add-to-list 'org-element-block-name-alist + `(,name . org-element-export-block-parser))) + ',export-block)) + ;; Define filters. + ,(let ((parent-filters (intern (format "org-%s-filters-alist" parent)))) + (when (or (boundp parent-filters) filters) + `(defconst ,(intern (format "org-%s-filters-alist" child)) + ',(append filters + (and (boundp parent-filters) + (copy-sequence (symbol-value parent-filters)))) + "Alist between filters keywords and back-end specific filters. +See `org-export-filters-alist' for more information."))) + ;; Define options. + ,(let ((parent-options (intern (format "org-%s-options-alist" parent)))) + (when (or (boundp parent-options) options) + `(defconst ,(intern (format "org-%s-options-alist" child)) + ',(append options + (and (boundp parent-options) + (copy-sequence (symbol-value parent-options)))) + ,(format "Alist between %s export properties and ways to set them. +See `org-export-options-alist' for more information on the +structure of the values." + child)))) + ;; Define translators. + (defvar ,(intern (format "org-%s-translate-alist" child)) + ',(append translate + (copy-sequence + (symbol-value + (intern (format "org-%s-translate-alist" parent))))) + "Alist between element or object types and translators.") + ;; Splice in the body, if any. + ,@body))) + + + +;;; The Communication Channel +;; +;; During export process, every function has access to a number of +;; properties. They are of two types: +;; +;; 1. Environment options are collected once at the very beginning of +;; the process, out of the original buffer and configuration. +;; Collecting them is handled by `org-export-get-environment' +;; function. +;; +;; Most environment options are defined through the +;; `org-export-options-alist' variable. +;; +;; 2. Tree properties are extracted directly from the parsed tree, +;; just before export, by `org-export-collect-tree-properties'. +;; +;; Here is the full list of properties available during transcode +;; process, with their category (option, tree or local) and their +;; value type. +;; +;; + `:author' :: Author's name. +;; - category :: option +;; - type :: string +;; +;; + `:back-end' :: Current back-end used for transcoding. +;; - category :: tree +;; - type :: symbol +;; +;; + `:creator' :: String to write as creation information. +;; - category :: option +;; - type :: string +;; +;; + `:date' :: String to use as date. +;; - category :: option +;; - type :: string +;; +;; + `:description' :: Description text for the current data. +;; - category :: option +;; - type :: string +;; +;; + `:email' :: Author's email. +;; - category :: option +;; - type :: string +;; +;; + `:exclude-tags' :: Tags for exclusion of subtrees from export +;; process. +;; - category :: option +;; - type :: list of strings +;; +;; + `:exported-data' :: Hash table used for memoizing +;; `org-export-data'. +;; - category :: tree +;; - type :: hash table +;; +;; + `:footnote-definition-alist' :: Alist between footnote labels and +;; their definition, as parsed data. Only non-inlined footnotes +;; are represented in this alist. Also, every definition isn't +;; guaranteed to be referenced in the parse tree. The purpose of +;; this property is to preserve definitions from oblivion +;; (i.e. when the parse tree comes from a part of the original +;; buffer), it isn't meant for direct use in a back-end. To +;; retrieve a definition relative to a reference, use +;; `org-export-get-footnote-definition' instead. +;; - category :: option +;; - type :: alist (STRING . LIST) +;; +;; + `:headline-levels' :: Maximum level being exported as an +;; headline. Comparison is done with the relative level of +;; headlines in the parse tree, not necessarily with their +;; actual level. +;; - category :: option +;; - type :: integer +;; +;; + `:headline-offset' :: Difference between relative and real level +;; of headlines in the parse tree. For example, a value of -1 +;; means a level 2 headline should be considered as level +;; 1 (cf. `org-export-get-relative-level'). +;; - category :: tree +;; - type :: integer +;; +;; + `:headline-numbering' :: Alist between headlines and their +;; numbering, as a list of numbers +;; (cf. `org-export-get-headline-number'). +;; - category :: tree +;; - type :: alist (INTEGER . LIST) +;; +;; + `:id-alist' :: Alist between ID strings and destination file's +;; path, relative to current directory. It is used by +;; `org-export-resolve-id-link' to resolve ID links targeting an +;; external file. +;; - category :: option +;; - type :: alist (STRING . STRING) +;; +;; + `:ignore-list' :: List of elements and objects that should be +;; ignored during export. +;; - category :: tree +;; - type :: list of elements and objects +;; +;; + `:input-file' :: Full path to input file, if any. +;; - category :: option +;; - type :: string or nil +;; +;; + `:keywords' :: List of keywords attached to data. +;; - category :: option +;; - type :: string +;; +;; + `:language' :: Default language used for translations. +;; - category :: option +;; - type :: string +;; +;; + `:parse-tree' :: Whole parse tree, available at any time during +;; transcoding. +;; - category :: option +;; - type :: list (as returned by `org-element-parse-buffer') +;; +;; + `:preserve-breaks' :: Non-nil means transcoding should preserve +;; all line breaks. +;; - category :: option +;; - type :: symbol (nil, t) +;; +;; + `:section-numbers' :: Non-nil means transcoding should add +;; section numbers to headlines. +;; - category :: option +;; - type :: symbol (nil, t) +;; +;; + `:select-tags' :: List of tags enforcing inclusion of sub-trees +;; in transcoding. When such a tag is present, subtrees without +;; it are de facto excluded from the process. See +;; `use-select-tags'. +;; - category :: option +;; - type :: list of strings +;; +;; + `:target-list' :: List of targets encountered in the parse tree. +;; This is used to partly resolve "fuzzy" links +;; (cf. `org-export-resolve-fuzzy-link'). +;; - category :: tree +;; - type :: list of strings +;; +;; + `:time-stamp-file' :: Non-nil means transcoding should insert +;; a time stamp in the output. +;; - category :: option +;; - type :: symbol (nil, t) +;; +;; + `:translate-alist' :: Alist between element and object types and +;; transcoding functions relative to the current back-end. +;; Special keys `template' and `plain-text' are also possible. +;; - category :: option +;; - type :: alist (SYMBOL . FUNCTION) +;; +;; + `:with-archived-trees' :: Non-nil when archived subtrees should +;; also be transcoded. If it is set to the `headline' symbol, +;; only the archived headline's name is retained. +;; - category :: option +;; - type :: symbol (nil, t, `headline') +;; +;; + `:with-author' :: Non-nil means author's name should be included +;; in the output. +;; - category :: option +;; - type :: symbol (nil, t) +;; +;; + `:with-clocks' :: Non-nild means clock keywords should be exported. +;; - category :: option +;; - type :: symbol (nil, t) +;; +;; + `:with-creator' :: Non-nild means a creation sentence should be +;; inserted at the end of the transcoded string. If the value +;; is `comment', it should be commented. +;; - category :: option +;; - type :: symbol (`comment', nil, t) +;; +;; + `:with-drawers' :: Non-nil means drawers should be exported. If +;; its value is a list of names, only drawers with such names +;; will be transcoded. +;; - category :: option +;; - type :: symbol (nil, t) or list of strings +;; +;; + `:with-email' :: Non-nil means output should contain author's +;; email. +;; - category :: option +;; - type :: symbol (nil, t) +;; +;; + `:with-emphasize' :: Non-nil means emphasized text should be +;; interpreted. +;; - category :: option +;; - type :: symbol (nil, t) +;; +;; + `:with-fixed-width' :: Non-nil if transcoder should interpret +;; strings starting with a colon as a fixed-with (verbatim) area. +;; - category :: option +;; - type :: symbol (nil, t) +;; +;; + `:with-footnotes' :: Non-nil if transcoder should interpret +;; footnotes. +;; - category :: option +;; - type :: symbol (nil, t) +;; +;; + `:with-plannings' :: Non-nil means transcoding should include +;; planning info. +;; - category :: option +;; - type :: symbol (nil, t) +;; +;; + `:with-priority' :: Non-nil means transcoding should include +;; priority cookies. +;; - category :: option +;; - type :: symbol (nil, t) +;; +;; + `:with-special-strings' :: Non-nil means transcoding should +;; interpret special strings in plain text. +;; - category :: option +;; - type :: symbol (nil, t) +;; +;; + `:with-sub-superscript' :: Non-nil means transcoding should +;; interpret subscript and superscript. With a value of "{}", +;; only interpret those using curly brackets. +;; - category :: option +;; - type :: symbol (nil, {}, t) +;; +;; + `:with-tables' :: Non-nil means transcoding should interpret +;; tables. +;; - category :: option +;; - type :: symbol (nil, t) +;; +;; + `:with-tags' :: Non-nil means transcoding should keep tags in +;; headlines. A `not-in-toc' value will remove them from the +;; table of contents, if any, nonetheless. +;; - category :: option +;; - type :: symbol (nil, t, `not-in-toc') +;; +;; + `:with-tasks' :: Non-nil means transcoding should include +;; headlines with a TODO keyword. A `todo' value will only +;; include headlines with a todo type keyword while a `done' +;; value will do the contrary. If a list of strings is provided, +;; only tasks with keywords belonging to that list will be kept. +;; - category :: option +;; - type :: symbol (t, todo, done, nil) or list of strings +;; +;; + `:with-timestamps' :: Non-nil means transcoding should include +;; time stamps. Special value `active' (resp. `inactive') ask to +;; export only active (resp. inactive) timestamps. Otherwise, +;; completely remove them. +;; - category :: option +;; - type :: symbol: (`active', `inactive', t, nil) +;; +;; + `:with-toc' :: Non-nil means that a table of contents has to be +;; added to the output. An integer value limits its depth. +;; - category :: option +;; - type :: symbol (nil, t or integer) +;; +;; + `:with-todo-keywords' :: Non-nil means transcoding should +;; include TODO keywords. +;; - category :: option +;; - type :: symbol (nil, t) + + +;;;; Environment Options +;; +;; Environment options encompass all parameters defined outside the +;; scope of the parsed data. They come from five sources, in +;; increasing precedence order: +;; +;; - Global variables, +;; - Buffer's attributes, +;; - Options keyword symbols, +;; - Buffer keywords, +;; - Subtree properties. +;; +;; The central internal function with regards to environment options +;; is `org-export-get-environment'. It updates global variables with +;; "#+BIND:" keywords, then retrieve and prioritize properties from +;; the different sources. +;; +;; The internal functions doing the retrieval are: +;; `org-export--get-global-options', +;; `org-export--get-buffer-attributes', +;; `org-export--parse-option-keyword', +;; `org-export--get-subtree-options' and +;; `org-export--get-inbuffer-options' +;; +;; Also, `org-export--confirm-letbind' and `org-export--install-letbind' +;; take care of the part relative to "#+BIND:" keywords. + +(defun org-export-get-environment (&optional backend subtreep ext-plist) + "Collect export options from the current buffer. + +Optional argument BACKEND is a symbol specifying which back-end +specific options to read, if any. + +When optional argument SUBTREEP is non-nil, assume the export is +done against the current sub-tree. + +Third optional argument EXT-PLIST is a property list with +external parameters overriding Org default settings, but still +inferior to file-local settings." + ;; First install #+BIND variables. + (org-export--install-letbind-maybe) + ;; Get and prioritize export options... + (org-combine-plists + ;; ... from global variables... + (org-export--get-global-options backend) + ;; ... from buffer's attributes... + (org-export--get-buffer-attributes) + ;; ... from an external property list... + ext-plist + ;; ... from in-buffer settings... + (org-export--get-inbuffer-options + backend + (and buffer-file-name (org-remove-double-quotes buffer-file-name))) + ;; ... and from subtree, when appropriate. + (and subtreep (org-export--get-subtree-options backend)) + ;; Eventually install back-end symbol and its translation table. + `(:back-end + ,backend + :translate-alist + ,(let ((trans-alist (intern (format "org-%s-translate-alist" backend)))) + (when (boundp trans-alist) (symbol-value trans-alist)))))) + +(defun org-export--parse-option-keyword (options &optional backend) + "Parse an OPTIONS line and return values as a plist. +Optional argument BACKEND is a symbol specifying which back-end +specific items to read, if any." + (let* ((all + (append org-export-options-alist + (and backend + (let ((var (intern + (format "org-%s-options-alist" backend)))) + (and (boundp var) (eval var)))))) + ;; Build an alist between #+OPTION: item and property-name. + (alist (delq nil + (mapcar (lambda (e) + (when (nth 2 e) (cons (regexp-quote (nth 2 e)) + (car e)))) + all))) + plist) + (mapc (lambda (e) + (when (string-match (concat "\\(\\`\\|[ \t]\\)" + (car e) + ":\\(([^)\n]+)\\|[^ \t\n\r;,.]*\\)") + options) + (setq plist (plist-put plist + (cdr e) + (car (read-from-string + (match-string 2 options))))))) + alist) + plist)) + +(defun org-export--get-subtree-options (&optional backend) + "Get export options in subtree at point. +Optional argument BACKEND is a symbol specifying back-end used +for export. Return options as a plist." + ;; For each buffer keyword, create an headline property setting the + ;; same property in communication channel. The name for the property + ;; is the keyword with "EXPORT_" appended to it. + (org-with-wide-buffer + (let (prop plist) + ;; Make sure point is at an heading. + (unless (org-at-heading-p) (org-back-to-heading t)) + ;; Take care of EXPORT_TITLE. If it isn't defined, use headline's + ;; title as its fallback value. + (when (setq prop (progn (looking-at org-todo-line-regexp) + (or (save-match-data + (org-entry-get (point) "EXPORT_TITLE")) + (org-match-string-no-properties 3)))) + (setq plist + (plist-put + plist :title + (org-element-parse-secondary-string + prop (org-element-restriction 'keyword))))) + ;; EXPORT_OPTIONS are parsed in a non-standard way. + (when (setq prop (org-entry-get (point) "EXPORT_OPTIONS")) + (setq plist + (nconc plist (org-export--parse-option-keyword prop backend)))) + ;; Handle other keywords. + (let ((seen '("TITLE"))) + (mapc + (lambda (option) + (let ((property (nth 1 option))) + (when (and property (not (member property seen))) + (let* ((subtree-prop (concat "EXPORT_" property)) + ;; Export properties are not case-sensitive. + (value (let ((case-fold-search t)) + (org-entry-get (point) subtree-prop)))) + (push property seen) + (when value + (setq plist + (plist-put + plist + (car option) + ;; Parse VALUE if required. + (if (member property org-element-parsed-keywords) + (org-element-parse-secondary-string + value (org-element-restriction 'keyword)) + value)))))))) + ;; Also look for both general keywords and back-end specific + ;; options if BACKEND is provided. + (append (and backend + (let ((var (intern + (format "org-%s-options-alist" backend)))) + (and (boundp var) (symbol-value var)))) + org-export-options-alist))) + ;; Return value. + plist))) + +(defun org-export--get-inbuffer-options (&optional backend files) + "Return current buffer export options, as a plist. + +Optional argument BACKEND, when non-nil, is a symbol specifying +which back-end specific options should also be read in the +process. + +Optional argument FILES is a list of setup files names read so +far, used to avoid circular dependencies. + +Assume buffer is in Org mode. Narrowing, if any, is ignored." + (org-with-wide-buffer + (goto-char (point-min)) + (let ((case-fold-search t) plist) + ;; 1. Special keywords, as in `org-export-special-keywords'. + (let ((special-re (org-make-options-regexp org-export-special-keywords))) + (while (re-search-forward special-re nil t) + (let ((element (org-element-at-point))) + (when (eq (org-element-type element) 'keyword) + (let* ((key (org-element-property :key element)) + (val (org-element-property :value element)) + (prop + (cond + ((string= key "SETUP_FILE") + (let ((file + (expand-file-name + (org-remove-double-quotes (org-trim val))))) + ;; Avoid circular dependencies. + (unless (member file files) + (with-temp-buffer + (insert (org-file-contents file 'noerror)) + (org-mode) + (org-export--get-inbuffer-options + backend (cons file files)))))) + ((string= key "OPTIONS") + (org-export--parse-option-keyword val backend)) + ((string= key "MACRO") + (when (string-match + "^\\([-a-zA-Z0-9_]+\\)\\(?:[ \t]+\\(.*?\\)[ \t]*$\\)?" + val) + (let ((key + (intern + (concat ":macro-" + (downcase (match-string 1 val))))) + (value (org-match-string-no-properties 2 val))) + (cond + ((not value) nil) + ;; Value will be evaled: do not parse it. + ((string-match "\\`(eval\\>" value) + (list key (list value))) + ;; Value has to be parsed for nested + ;; macros. + (t + (list + key + (let ((restr (org-element-restriction 'macro))) + (org-element-parse-secondary-string + ;; If user explicitly asks for + ;; a newline, be sure to preserve it + ;; from further filling with + ;; `hard-newline'. Also replace + ;; "\\n" with "\n", "\\\n" with "\\n" + ;; and so on... + (replace-regexp-in-string + "\\(\\\\\\\\\\)n" "\\\\" + (replace-regexp-in-string + "\\(?:^\\|[^\\\\]\\)\\(\\\\n\\)" + hard-newline value nil nil 1) + nil nil 1) + restr))))))))))) + (setq plist (org-combine-plists plist prop))))))) + ;; 2. Standard options, as in `org-export-options-alist'. + (let* ((all (append org-export-options-alist + ;; Also look for back-end specific options + ;; if BACKEND is defined. + (and backend + (let ((var + (intern + (format "org-%s-options-alist" backend)))) + (and (boundp var) (eval var)))))) + ;; Build alist between keyword name and property name. + (alist + (delq nil (mapcar + (lambda (e) (when (nth 1 e) (cons (nth 1 e) (car e)))) + all))) + ;; Build regexp matching all keywords associated to export + ;; options. Note: the search is case insensitive. + (opt-re (org-make-options-regexp + (delq nil (mapcar (lambda (e) (nth 1 e)) all))))) + (goto-char (point-min)) + (while (re-search-forward opt-re nil t) + (let ((element (org-element-at-point))) + (when (eq (org-element-type element) 'keyword) + (let* ((key (org-element-property :key element)) + (val (org-element-property :value element)) + (prop (cdr (assoc key alist))) + (behaviour (nth 4 (assq prop all)))) + (setq plist + (plist-put + plist prop + ;; Handle value depending on specified BEHAVIOUR. + (case behaviour + (space + (if (not (plist-get plist prop)) (org-trim val) + (concat (plist-get plist prop) " " (org-trim val)))) + (newline + (org-trim + (concat (plist-get plist prop) "\n" (org-trim val)))) + (split + `(,@(plist-get plist prop) ,@(org-split-string val))) + ('t val) + (otherwise (if (not (plist-member plist prop)) val + (plist-get plist prop)))))))))) + ;; Parse keywords specified in `org-element-parsed-keywords'. + (mapc + (lambda (key) + (let* ((prop (cdr (assoc key alist))) + (value (and prop (plist-get plist prop)))) + (when (stringp value) + (setq plist + (plist-put + plist prop + (org-element-parse-secondary-string + value (org-element-restriction 'keyword))))))) + org-element-parsed-keywords)) + ;; 3. Return final value. + plist))) + +(defun org-export--get-buffer-attributes () + "Return properties related to buffer attributes, as a plist." + (let ((visited-file (buffer-file-name (buffer-base-buffer)))) + (list + ;; Store full path of input file name, or nil. For internal use. + :input-file visited-file + :title (or (and visited-file + (file-name-sans-extension + (file-name-nondirectory visited-file))) + (buffer-name (buffer-base-buffer))) + :footnote-definition-alist + ;; Footnotes definitions must be collected in the original + ;; buffer, as there's no insurance that they will still be in the + ;; parse tree, due to possible narrowing. + (let (alist) + (org-with-wide-buffer + (goto-char (point-min)) + (while (re-search-forward org-footnote-definition-re nil t) + (let ((def (org-footnote-at-definition-p))) + (when def + (org-skip-whitespace) + (push (cons (car def) + (save-restriction + (narrow-to-region (point) (nth 2 def)) + ;; Like `org-element-parse-buffer', but + ;; makes sure the definition doesn't start + ;; with a section element. + (org-element--parse-elements + (point-min) (point-max) nil nil nil nil + (list 'org-data nil)))) + alist)))) + alist)) + :id-alist + ;; Collect id references. + (let (alist) + (org-with-wide-buffer + (goto-char (point-min)) + (while (re-search-forward + "\\[\\[id:\\(\\S-+?\\)\\]\\(?:\\[.*?\\]\\)?\\]" nil t) + (let* ((id (org-match-string-no-properties 1)) + (file (org-id-find-id-file id))) + (when file (push (cons id (file-relative-name file)) alist))))) + alist) + :macro-modification-time + (and visited-file + (file-exists-p visited-file) + (concat "(eval (format-time-string \"$1\" '" + (prin1-to-string (nth 5 (file-attributes visited-file))) + "))")) + ;; Store input file name as a macro. + :macro-input-file (and visited-file (file-name-nondirectory visited-file)) + ;; `:macro-date', `:macro-time' and `:macro-property' could as + ;; well be initialized as tree properties, since they don't + ;; depend on buffer properties. Though, it may be more logical + ;; to keep them close to other ":macro-" properties. + :macro-date "(eval (format-time-string \"$1\"))" + :macro-time "(eval (format-time-string \"$1\"))" + :macro-property "(eval (org-entry-get nil \"$1\" 'selective))"))) + +(defun org-export--get-global-options (&optional backend) + "Return global export options as a plist. + +Optional argument BACKEND, if non-nil, is a symbol specifying +which back-end specific export options should also be read in the +process." + (let ((all (append org-export-options-alist + (and backend + (let ((var (intern + (format "org-%s-options-alist" backend)))) + (and (boundp var) (symbol-value var)))))) + ;; Output value. + plist) + (mapc + (lambda (cell) + (setq plist + (plist-put + plist + (car cell) + ;; Eval default value provided. If keyword is a member + ;; of `org-element-parsed-keywords', parse it as + ;; a secondary string before storing it. + (let ((value (eval (nth 3 cell)))) + (if (not (stringp value)) value + (let ((keyword (nth 1 cell))) + (if (not (member keyword org-element-parsed-keywords)) value + (org-element-parse-secondary-string + value (org-element-restriction 'keyword))))))))) + all) + ;; Return value. + plist)) + +(defvar org-export--allow-BIND-local nil) +(defun org-export--confirm-letbind () + "Can we use #+BIND values during export? +By default this will ask for confirmation by the user, to divert +possible security risks." + (cond + ((not org-export-allow-BIND) nil) + ((eq org-export-allow-BIND t) t) + ((local-variable-p 'org-export--allow-BIND-local) + org-export--allow-BIND-local) + (t (org-set-local 'org-export--allow-BIND-local + (yes-or-no-p "Allow BIND values in this buffer? "))))) + +(defun org-export--install-letbind-maybe () + "Install the values from #+BIND lines as local variables. +Variables must be installed before in-buffer options are +retrieved." + (let (letbind pair) + (org-with-wide-buffer + (goto-char (point-min)) + (while (re-search-forward (org-make-options-regexp '("BIND")) nil t) + (when (org-export-confirm-letbind) + (push (read (concat "(" (org-match-string-no-properties 2) ")")) + letbind)))) + (while (setq pair (pop letbind)) + (org-set-local (car pair) (nth 1 pair))))) + + +;;;; Tree Properties +;; +;; Tree properties are infromation extracted from parse tree. They +;; are initialized at the beginning of the transcoding process by +;; `org-export-collect-tree-properties'. +;; +;; Dedicated functions focus on computing the value of specific tree +;; properties during initialization. Thus, +;; `org-export--populate-ignore-list' lists elements and objects that +;; should be skipped during export, `org-export--get-min-level' gets +;; the minimal exportable level, used as a basis to compute relative +;; level for headlines. Eventually +;; `org-export--collect-headline-numbering' builds an alist between +;; headlines and their numbering. + +(defun org-export-collect-tree-properties (data info) + "Extract tree properties from parse tree. + +DATA is the parse tree from which information is retrieved. INFO +is a list holding export options. + +Following tree properties are set or updated: + +`:exported-data' Hash table used to memoize results from + `org-export-data'. + +`:footnote-definition-alist' List of footnotes definitions in + original buffer and current parse tree. + +`:headline-offset' Offset between true level of headlines and + local level. An offset of -1 means an headline + of level 2 should be considered as a level + 1 headline in the context. + +`:headline-numbering' Alist of all headlines as key an the + associated numbering as value. + +`:ignore-list' List of elements that should be ignored during + export. + +`:target-list' List of all targets in the parse tree. + +Return updated plist." + ;; Install the parse tree in the communication channel, in order to + ;; use `org-export-get-genealogy' and al. + (setq info (plist-put info :parse-tree data)) + ;; Get the list of elements and objects to ignore, and put it into + ;; `:ignore-list'. Do not overwrite any user ignore that might have + ;; been done during parse tree filtering. + (setq info + (plist-put info + :ignore-list + (append (org-export--populate-ignore-list data info) + (plist-get info :ignore-list)))) + ;; Compute `:headline-offset' in order to be able to use + ;; `org-export-get-relative-level'. + (setq info + (plist-put info + :headline-offset + (- 1 (org-export--get-min-level data info)))) + ;; Update footnotes definitions list with definitions in parse tree. + ;; This is required since buffer expansion might have modified + ;; boundaries of footnote definitions contained in the parse tree. + ;; This way, definitions in `footnote-definition-alist' are bound to + ;; match those in the parse tree. + (let ((defs (plist-get info :footnote-definition-alist))) + (org-element-map + data 'footnote-definition + (lambda (fn) + (push (cons (org-element-property :label fn) + `(org-data nil ,@(org-element-contents fn))) + defs))) + (setq info (plist-put info :footnote-definition-alist defs))) + ;; Properties order doesn't matter: get the rest of the tree + ;; properties. + (nconc + `(:target-list + ,(org-element-map + data '(keyword target) + (lambda (blob) + (when (or (eq (org-element-type blob) 'target) + (string= (org-element-property :key blob) "TARGET")) + blob)) info) + :headline-numbering ,(org-export--collect-headline-numbering data info) + :exported-data ,(make-hash-table :test 'eq :size 4001)) + info)) + +(defun org-export--get-min-level (data options) + "Return minimum exportable headline's level in DATA. +DATA is parsed tree as returned by `org-element-parse-buffer'. +OPTIONS is a plist holding export options." + (catch 'exit + (let ((min-level 10000)) + (mapc + (lambda (blob) + (when (and (eq (org-element-type blob) 'headline) + (not (memq blob (plist-get options :ignore-list)))) + (setq min-level + (min (org-element-property :level blob) min-level))) + (when (= min-level 1) (throw 'exit 1))) + (org-element-contents data)) + ;; If no headline was found, for the sake of consistency, set + ;; minimum level to 1 nonetheless. + (if (= min-level 10000) 1 min-level)))) + +(defun org-export--collect-headline-numbering (data options) + "Return numbering of all exportable headlines in a parse tree. + +DATA is the parse tree. OPTIONS is the plist holding export +options. + +Return an alist whose key is an headline and value is its +associated numbering \(in the shape of a list of numbers\)." + (let ((numbering (make-vector org-export-max-depth 0))) + (org-element-map + data + 'headline + (lambda (headline) + (let ((relative-level + (1- (org-export-get-relative-level headline options)))) + (cons + headline + (loop for n across numbering + for idx from 0 to org-export-max-depth + when (< idx relative-level) collect n + when (= idx relative-level) collect (aset numbering idx (1+ n)) + when (> idx relative-level) do (aset numbering idx 0))))) + options))) + +(defun org-export--populate-ignore-list (data options) + "Return list of elements and objects to ignore during export. +DATA is the parse tree to traverse. OPTIONS is the plist holding +export options." + (let* (ignore + walk-data ; for byte-compiler. + (walk-data + (function + (lambda (data options selected) + ;; Collect ignored elements or objects into IGNORE-LIST. + (mapc + (lambda (el) + (if (org-export--skip-p el options selected) (push el ignore) + (let ((type (org-element-type el))) + (if (and (eq (plist-get options :with-archived-trees) + 'headline) + (eq (org-element-type el) 'headline) + (org-element-property :archivedp el)) + ;; If headline is archived but tree below has + ;; to be skipped, add it to ignore list. + (mapc (lambda (e) (push e ignore)) + (org-element-contents el)) + ;; Move into recursive objects/elements. + (when (org-element-contents el) + (funcall walk-data el options selected)))))) + (org-element-contents data)))))) + ;; Main call. First find trees containing a select tag, if any. + (funcall walk-data data options (org-export--selected-trees data options)) + ;; Return value. + ignore)) + +(defun org-export--selected-trees (data info) + "Return list of headlines containing a select tag in their tree. +DATA is parsed data as returned by `org-element-parse-buffer'. +INFO is a plist holding export options." + (let* (selected-trees + walk-data ; for byte-compiler. + (walk-data + (function + (lambda (data genealogy) + (case (org-element-type data) + (org-data (mapc (lambda (el) (funcall walk-data el genealogy)) + (org-element-contents data))) + (headline + (let ((tags (org-element-property :tags data))) + (if (loop for tag in (plist-get info :select-tags) + thereis (member tag tags)) + ;; When a select tag is found, mark full + ;; genealogy and every headline within the tree + ;; as acceptable. + (setq selected-trees + (append + genealogy + (org-element-map data 'headline 'identity) + selected-trees)) + ;; Else, continue searching in tree, recursively. + (mapc + (lambda (el) (funcall walk-data el (cons data genealogy))) + (org-element-contents data)))))))))) + (funcall walk-data data nil) selected-trees)) + +(defun org-export--skip-p (blob options selected) + "Non-nil when element or object BLOB should be skipped during export. +OPTIONS is the plist holding export options. SELECTED, when +non-nil, is a list of headlines belonging to a tree with a select +tag." + (case (org-element-type blob) + ;; Check headline. + (headline + (let ((with-tasks (plist-get options :with-tasks)) + (todo (org-element-property :todo-keyword blob)) + (todo-type (org-element-property :todo-type blob)) + (archived (plist-get options :with-archived-trees)) + (tags (org-element-property :tags blob))) + (or + ;; Ignore subtrees with an exclude tag. + (loop for k in (plist-get options :exclude-tags) + thereis (member k tags)) + ;; When a select tag is present in the buffer, ignore any tree + ;; without it. + (and selected (not (memq blob selected))) + ;; Ignore commented sub-trees. + (org-element-property :commentedp blob) + ;; Ignore archived subtrees if `:with-archived-trees' is nil. + (and (not archived) (org-element-property :archivedp blob)) + ;; Ignore tasks, if specified by `:with-tasks' property. + (and todo + (or (not with-tasks) + (and (memq with-tasks '(todo done)) + (not (eq todo-type with-tasks))) + (and (consp with-tasks) (not (member todo with-tasks)))))))) + ;; Check inlinetask. + (inlinetask (not (plist-get options :with-inlinetasks))) + ;; Check timestamp. + (timestamp + (case (plist-get options :with-timestamps) + ;; No timestamp allowed. + ('nil t) + ;; Only active timestamps allowed and the current one isn't + ;; active. + (active + (not (memq (org-element-property :type blob) + '(active active-range)))) + ;; Only inactive timestamps allowed and the current one isn't + ;; inactive. + (inactive + (not (memq (org-element-property :type blob) + '(inactive inactive-range)))))) + ;; Check drawer. + (drawer + (or (not (plist-get options :with-drawers)) + (and (consp (plist-get options :with-drawers)) + (not (member (org-element-property :drawer-name blob) + (plist-get options :with-drawers)))))) + ;; Check table-row. + (table-row (org-export-table-row-is-special-p blob options)) + ;; Check table-cell. + (table-cell + (and (org-export-table-has-special-column-p + (org-export-get-parent-table blob)) + (not (org-export-get-previous-element blob options)))) + ;; Check clock. + (clock (not (plist-get options :with-clocks))) + ;; Check planning. + (planning (not (plist-get options :with-plannings))))) + + + +;;; The Transcoder +;; +;; `org-export-data' reads a parse tree (obtained with, i.e. +;; `org-element-parse-buffer') and transcodes it into a specified +;; back-end output. It takes care of filtering out elements or +;; objects according to export options and organizing the output blank +;; lines and white space are preserved. The function memoizes its +;; results, so it is cheap to call it within translators. +;; +;; Internally, three functions handle the filtering of objects and +;; elements during the export. In particular, +;; `org-export-ignore-element' marks an element or object so future +;; parse tree traversals skip it, `org-export--interpret-p' tells which +;; elements or objects should be seen as real Org syntax and +;; `org-export-expand' transforms the others back into their original +;; shape +;; +;; `org-export-transcoder' is an accessor returning appropriate +;; translator function for a given element or object. + +(defun org-export-transcoder (blob info) + "Return appropriate transcoder for BLOB. +INFO is a plist containing export directives." + (let ((type (org-element-type blob))) + ;; Return contents only for complete parse trees. + (if (eq type 'org-data) (lambda (blob contents info) contents) + (let ((transcoder (cdr (assq type (plist-get info :translate-alist))))) + (and (functionp transcoder) transcoder))))) + +(defun org-export-data (data info) + "Convert DATA into current back-end format. + +DATA is a parse tree, an element or an object or a secondary +string. INFO is a plist holding export options. + +Return transcoded string." + (let ((memo (gethash data (plist-get info :exported-data) 'no-memo))) + (if (not (eq memo 'no-memo)) memo + (let* ((type (org-element-type data)) + (results + (cond + ;; Ignored element/object. + ((memq data (plist-get info :ignore-list)) nil) + ;; Plain text. + ((eq type 'plain-text) + (org-export-filter-apply-functions + (plist-get info :filter-plain-text) + (let ((transcoder (org-export-transcoder data info))) + (if transcoder (funcall transcoder data info) data)) + info)) + ;; Uninterpreted element/object: change it back to Org + ;; syntax and export again resulting raw string. + ((not (org-export--interpret-p data info)) + (org-export-data + (org-export-expand + data + (mapconcat (lambda (blob) (org-export-data blob info)) + (org-element-contents data) + "")) + info)) + ;; Secondary string. + ((not type) + (mapconcat (lambda (obj) (org-export-data obj info)) data "")) + ;; Element/Object without contents or, as a special case, + ;; headline with archive tag and archived trees restricted + ;; to title only. + ((or (not (org-element-contents data)) + (and (eq type 'headline) + (eq (plist-get info :with-archived-trees) 'headline) + (org-element-property :archivedp data))) + (let ((transcoder (org-export-transcoder data info))) + (and (functionp transcoder) + (funcall transcoder data nil info)))) + ;; Element/Object with contents. + (t + (let ((transcoder (org-export-transcoder data info))) + (when transcoder + (let* ((greaterp (memq type org-element-greater-elements)) + (objectp + (and (not greaterp) + (memq type org-element-recursive-objects))) + (contents + (mapconcat + (lambda (element) (org-export-data element info)) + (org-element-contents + (if (or greaterp objectp) data + ;; Elements directly containing objects + ;; must have their indentation normalized + ;; first. + (org-element-normalize-contents + data + ;; When normalizing contents of the first + ;; paragraph in an item or a footnote + ;; definition, ignore first line's + ;; indentation: there is none and it + ;; might be misleading. + (when (eq type 'paragraph) + (let ((parent (org-export-get-parent data))) + (and + (eq (car (org-element-contents parent)) + data) + (memq (org-element-type parent) + '(footnote-definition item)))))))) + ""))) + (funcall transcoder data + (if (not greaterp) contents + (org-element-normalize-string contents)) + info)))))))) + ;; Final result will be memoized before being returned. + (puthash + data + (cond + ((not results) nil) + ((memq type '(org-data plain-text nil)) results) + ;; Append the same white space between elements or objects as in + ;; the original buffer, and call appropriate filters. + (t + (let ((results + (org-export-filter-apply-functions + (plist-get info (intern (format ":filter-%s" type))) + (let ((post-blank (or (org-element-property :post-blank data) + 0))) + (if (memq type org-element-all-elements) + (concat (org-element-normalize-string results) + (make-string post-blank ?\n)) + (concat results (make-string post-blank ? )))) + info))) + results))) + (plist-get info :exported-data)))))) + +(defun org-export--interpret-p (blob info) + "Non-nil if element or object BLOB should be interpreted as Org syntax. +Check is done according to export options INFO, stored as +a plist." + (case (org-element-type blob) + ;; ... entities... + (entity (plist-get info :with-entities)) + ;; ... emphasis... + (emphasis (plist-get info :with-emphasize)) + ;; ... fixed-width areas. + (fixed-width (plist-get info :with-fixed-width)) + ;; ... footnotes... + ((footnote-definition footnote-reference) + (plist-get info :with-footnotes)) + ;; ... sub/superscripts... + ((subscript superscript) + (let ((sub/super-p (plist-get info :with-sub-superscript))) + (if (eq sub/super-p '{}) + (org-element-property :use-brackets-p blob) + sub/super-p))) + ;; ... tables... + (table (plist-get info :with-tables)) + (otherwise t))) + +(defun org-export-expand (blob contents) + "Expand a parsed element or object to its original state. +BLOB is either an element or an object. CONTENTS is its +contents, as a string or nil." + (funcall + (intern (format "org-element-%s-interpreter" (org-element-type blob))) + blob contents)) + +(defun org-export-ignore-element (element info) + "Add ELEMENT to `:ignore-list' in INFO. + +Any element in `:ignore-list' will be skipped when using +`org-element-map'. INFO is modified by side effects." + (plist-put info :ignore-list (cons element (plist-get info :ignore-list)))) + + + +;;; The Filter System +;; +;; Filters allow end-users to tweak easily the transcoded output. +;; They are the functional counterpart of hooks, as every filter in +;; a set is applied to the return value of the previous one. +;; +;; Every set is back-end agnostic. Although, a filter is always +;; called, in addition to the string it applies to, with the back-end +;; used as argument, so it's easy for the end-user to add back-end +;; specific filters in the set. The communication channel, as +;; a plist, is required as the third argument. +;; +;; From the developer side, filters sets can be installed in the +;; process with the help of `org-export-define-backend', which +;; internally sets `org-BACKEND-filters-alist' variable. Each +;; association has a key among the following symbols and a function or +;; a list of functions as value. +;; +;; - `:filter-parse-tree' applies directly on the complete parsed +;; tree. It's the only filters set that doesn't apply to a string. +;; Users can set it through `org-export-filter-parse-tree-functions' +;; variable. +;; +;; - `:filter-final-output' applies to the final transcoded string. +;; Users can set it with `org-export-filter-final-output-functions' +;; variable +;; +;; - `:filter-plain-text' applies to any string not recognized as Org +;; syntax. `org-export-filter-plain-text-functions' allows users to +;; configure it. +;; +;; - `:filter-TYPE' applies on the string returned after an element or +;; object of type TYPE has been transcoded. An user can modify +;; `org-export-filter-TYPE-functions' +;; +;; All filters sets are applied with +;; `org-export-filter-apply-functions' function. Filters in a set are +;; applied in a LIFO fashion. It allows developers to be sure that +;; their filters will be applied first. +;; +;; Filters properties are installed in communication channel with +;; `org-export-install-filters' function. +;; +;; Eventually, a hook (`org-export-before-parsing-hook') is run just +;; before parsing to allow for heavy structure modifications. + + +;;;; Before Parsing Hook + +(defvar org-export-before-parsing-hook nil + "Hook run before parsing an export buffer. + +This is run after include keywords have been expanded and Babel +code executed, on a copy of original buffer's area being +exported. Visibility is the same as in the original one. Point +is left at the beginning of the new one. + +Every function in this hook will be called with one argument: the +back-end currently used, as a symbol.") + + +;;;; Special Filters + +(defvar org-export-filter-parse-tree-functions nil + "List of functions applied to the parsed tree. +Each filter is called with three arguments: the parse tree, as +returned by `org-element-parse-buffer', the back-end, as +a symbol, and the communication channel, as a plist. It must +return the modified parse tree to transcode.") + +(defvar org-export-filter-final-output-functions nil + "List of functions applied to the transcoded string. +Each filter is called with three arguments: the full transcoded +string, the back-end, as a symbol, and the communication channel, +as a plist. It must return a string that will be used as the +final export output.") + +(defvar org-export-filter-plain-text-functions nil + "List of functions applied to plain text. +Each filter is called with three arguments: a string which +contains no Org syntax, the back-end, as a symbol, and the +communication channel, as a plist. It must return a string or +nil.") + + +;;;; Elements Filters + +(defvar org-export-filter-center-block-functions nil + "List of functions applied to a transcoded center block. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-clock-functions nil + "List of functions applied to a transcoded clock. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-drawer-functions nil + "List of functions applied to a transcoded drawer. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-dynamic-block-functions nil + "List of functions applied to a transcoded dynamic-block. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-headline-functions nil + "List of functions applied to a transcoded headline. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-inlinetask-functions nil + "List of functions applied to a transcoded inlinetask. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-plain-list-functions nil + "List of functions applied to a transcoded plain-list. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-item-functions nil + "List of functions applied to a transcoded item. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-comment-functions nil + "List of functions applied to a transcoded comment. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-comment-block-functions nil + "List of functions applied to a transcoded comment-comment. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-example-block-functions nil + "List of functions applied to a transcoded example-block. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-export-block-functions nil + "List of functions applied to a transcoded export-block. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-fixed-width-functions nil + "List of functions applied to a transcoded fixed-width. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-footnote-definition-functions nil + "List of functions applied to a transcoded footnote-definition. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-horizontal-rule-functions nil + "List of functions applied to a transcoded horizontal-rule. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-keyword-functions nil + "List of functions applied to a transcoded keyword. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-latex-environment-functions nil + "List of functions applied to a transcoded latex-environment. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-babel-call-functions nil + "List of functions applied to a transcoded babel-call. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-paragraph-functions nil + "List of functions applied to a transcoded paragraph. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-planning-functions nil + "List of functions applied to a transcoded planning. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-property-drawer-functions nil + "List of functions applied to a transcoded property-drawer. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-quote-block-functions nil + "List of functions applied to a transcoded quote block. +Each filter is called with three arguments: the transcoded quote +data, as a string, the back-end, as a symbol, and the +communication channel, as a plist. It must return a string or +nil.") + +(defvar org-export-filter-quote-section-functions nil + "List of functions applied to a transcoded quote-section. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-section-functions nil + "List of functions applied to a transcoded section. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-special-block-functions nil + "List of functions applied to a transcoded special block. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-src-block-functions nil + "List of functions applied to a transcoded src-block. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-table-functions nil + "List of functions applied to a transcoded table. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-table-cell-functions nil + "List of functions applied to a transcoded table-cell. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-table-row-functions nil + "List of functions applied to a transcoded table-row. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-verse-block-functions nil + "List of functions applied to a transcoded verse block. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + + +;;;; Objects Filters + +(defvar org-export-filter-bold-functions nil + "List of functions applied to transcoded bold text. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-code-functions nil + "List of functions applied to transcoded code text. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-entity-functions nil + "List of functions applied to a transcoded entity. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-export-snippet-functions nil + "List of functions applied to a transcoded export-snippet. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-footnote-reference-functions nil + "List of functions applied to a transcoded footnote-reference. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-inline-babel-call-functions nil + "List of functions applied to a transcoded inline-babel-call. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-inline-src-block-functions nil + "List of functions applied to a transcoded inline-src-block. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-italic-functions nil + "List of functions applied to transcoded italic text. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-latex-fragment-functions nil + "List of functions applied to a transcoded latex-fragment. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-line-break-functions nil + "List of functions applied to a transcoded line-break. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-link-functions nil + "List of functions applied to a transcoded link. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-macro-functions nil + "List of functions applied to a transcoded macro. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-radio-target-functions nil + "List of functions applied to a transcoded radio-target. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-statistics-cookie-functions nil + "List of functions applied to a transcoded statistics-cookie. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-strike-through-functions nil + "List of functions applied to transcoded strike-through text. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-subscript-functions nil + "List of functions applied to a transcoded subscript. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-superscript-functions nil + "List of functions applied to a transcoded superscript. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-target-functions nil + "List of functions applied to a transcoded target. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-timestamp-functions nil + "List of functions applied to a transcoded timestamp. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-underline-functions nil + "List of functions applied to transcoded underline text. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-verbatim-functions nil + "List of functions applied to transcoded verbatim text. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + + +;;;; Filters Tools +;; +;; Internal function `org-export-install-filters' installs filters +;; hard-coded in back-ends (developer filters) and filters from global +;; variables (user filters) in the communication channel. +;; +;; Internal function `org-export-filter-apply-functions' takes care +;; about applying each filter in order to a given data. It ignores +;; filters returning a nil value but stops whenever a filter returns +;; an empty string. + +(defun org-export-filter-apply-functions (filters value info) + "Call every function in FILTERS. + +Functions are called with arguments VALUE, current export +back-end and INFO. A function returning a nil value will be +skipped. If it returns the empty string, the process ends and +VALUE is ignored. + +Call is done in a LIFO fashion, to be sure that developer +specified filters, if any, are called first." + (catch 'exit + (dolist (filter filters value) + (let ((result (funcall filter value (plist-get info :back-end) info))) + (cond ((not value)) + ((equal value "") (throw 'exit nil)) + (t (setq value result))))))) + +(defun org-export-install-filters (info) + "Install filters properties in communication channel. + +INFO is a plist containing the current communication channel. + +Return the updated communication channel." + (let (plist) + ;; Install user defined filters with `org-export-filters-alist'. + (mapc (lambda (p) + (setq plist (plist-put plist (car p) (eval (cdr p))))) + org-export-filters-alist) + ;; Prepend back-end specific filters to that list. + (let ((back-end-filters (intern (format "org-%s-filters-alist" + (plist-get info :back-end))))) + (when (boundp back-end-filters) + (mapc (lambda (p) + ;; Single values get consed, lists are prepended. + (let ((key (car p)) (value (cdr p))) + (when value + (setq plist + (plist-put + plist key + (if (atom value) (cons value (plist-get plist key)) + (append value (plist-get plist key)))))))) + (eval back-end-filters)))) + ;; Return new communication channel. + (org-combine-plists info plist))) + + + +;;; Core functions +;; +;; This is the room for the main function, `org-export-as', along with +;; its derivatives, `org-export-to-buffer' and `org-export-to-file'. +;; They differ only by the way they output the resulting code. +;; +;; `org-export-output-file-name' is an auxiliary function meant to be +;; used with `org-export-to-file'. With a given extension, it tries +;; to provide a canonical file name to write export output to. +;; +;; Note that `org-export-as' doesn't really parse the current buffer, +;; but a copy of it (with the same buffer-local variables and +;; visibility), where include keywords are expanded and Babel blocks +;; are executed, if appropriate. +;; `org-export-with-current-buffer-copy' macro prepares that copy. +;; +;; File inclusion is taken care of by +;; `org-export-expand-include-keyword' and +;; `org-export--prepare-file-contents'. Structure wise, including +;; a whole Org file in a buffer often makes little sense. For +;; example, if the file contains an headline and the include keyword +;; was within an item, the item should contain the headline. That's +;; why file inclusion should be done before any structure can be +;; associated to the file, that is before parsing. + +(defun org-export-as + (backend &optional subtreep visible-only body-only ext-plist noexpand) + "Transcode current Org buffer into BACKEND code. + +If narrowing is active in the current buffer, only transcode its +narrowed part. + +If a region is active, transcode that region. + +When optional argument SUBTREEP is non-nil, transcode the +sub-tree at point, extracting information from the headline +properties first. + +When optional argument VISIBLE-ONLY is non-nil, don't export +contents of hidden elements. + +When optional argument BODY-ONLY is non-nil, only return body +code, without preamble nor postamble. + +Optional argument EXT-PLIST, when provided, is a property list +with external parameters overriding Org default settings, but +still inferior to file-local settings. + +Optional argument NOEXPAND, when non-nil, prevents included files +to be expanded and Babel code to be executed. + +Return code as a string." + (save-excursion + (save-restriction + ;; Narrow buffer to an appropriate region or subtree for + ;; parsing. If parsing subtree, be sure to remove main headline + ;; too. + (cond ((org-region-active-p) + (narrow-to-region (region-beginning) (region-end))) + (subtreep + (org-narrow-to-subtree) + (goto-char (point-min)) + (forward-line) + (narrow-to-region (point) (point-max)))) + ;; 1. Get export environment from original buffer. Also install + ;; user's and developer's filters. + (let ((info (org-export-install-filters + (org-export-get-environment backend subtreep ext-plist))) + ;; 2. Get parse tree. Buffer isn't parsed directly. + ;; Instead, a temporary copy is created, where include + ;; keywords are expanded and code blocks are evaluated. + (tree (let ((buf (or (buffer-file-name (buffer-base-buffer)) + (current-buffer)))) + (org-export-with-current-buffer-copy + (unless noexpand + (org-export-expand-include-keyword) + ;; TODO: Setting `org-current-export-file' is + ;; required by Org Babel to properly resolve + ;; noweb references. Once "org-exp.el" is + ;; removed, modify + ;; `org-export-blocks-preprocess' so it accepts + ;; the value as an argument instead. + (let ((org-current-export-file buf)) + (org-export-blocks-preprocess))) + (goto-char (point-min)) + ;; Run hook + ;; `org-export-before-parsing-hook'. with current + ;; back-end as argument. + (run-hook-with-args + 'org-export-before-parsing-hook backend) + ;; Eventually parse buffer. + (org-element-parse-buffer nil visible-only))))) + ;; 3. Call parse-tree filters to get the final tree. + (setq tree + (org-export-filter-apply-functions + (plist-get info :filter-parse-tree) tree info)) + ;; 4. Now tree is complete, compute its properties and add + ;; them to communication channel. + (setq info + (org-combine-plists + info (org-export-collect-tree-properties tree info))) + ;; 5. Eventually transcode TREE. Wrap the resulting string + ;; into a template, if required. Eventually call + ;; final-output filter. + (let* ((body (org-element-normalize-string (org-export-data tree info))) + (template (cdr (assq 'template + (plist-get info :translate-alist)))) + (output (org-export-filter-apply-functions + (plist-get info :filter-final-output) + (if (or (not (functionp template)) body-only) body + (funcall template body info)) + info))) + ;; Maybe add final OUTPUT to kill ring, then return it. + (when org-export-copy-to-kill-ring (org-kill-new output)) + output))))) + +(defun org-export-to-buffer + (backend buffer &optional subtreep visible-only body-only ext-plist noexpand) + "Call `org-export-as' with output to a specified buffer. + +BACKEND is the back-end used for transcoding, as a symbol. + +BUFFER is the output buffer. If it already exists, it will be +erased first, otherwise, it will be created. + +Optional arguments SUBTREEP, VISIBLE-ONLY, BODY-ONLY, EXT-PLIST +and NOEXPAND are similar to those used in `org-export-as', which +see. + +Return buffer." + (let ((out (org-export-as + backend subtreep visible-only body-only ext-plist noexpand)) + (buffer (get-buffer-create buffer))) + (with-current-buffer buffer + (erase-buffer) + (insert out) + (goto-char (point-min))) + buffer)) + +(defun org-export-to-file + (backend file &optional subtreep visible-only body-only ext-plist noexpand) + "Call `org-export-as' with output to a specified file. + +BACKEND is the back-end used for transcoding, as a symbol. FILE +is the name of the output file, as a string. + +Optional arguments SUBTREEP, VISIBLE-ONLY, BODY-ONLY, EXT-PLIST +and NOEXPAND are similar to those used in `org-export-as', which +see. + +Return output file's name." + ;; Checks for FILE permissions. `write-file' would do the same, but + ;; we'd rather avoid needless transcoding of parse tree. + (unless (file-writable-p file) (error "Output file not writable")) + ;; Insert contents to a temporary buffer and write it to FILE. + (let ((out (org-export-as + backend subtreep visible-only body-only ext-plist noexpand))) + (with-temp-buffer + (insert out) + (let ((coding-system-for-write org-export-coding-system)) + (write-file file)))) + ;; Return full path. + file) + +(defun org-export-output-file-name (extension &optional subtreep pub-dir) + "Return output file's name according to buffer specifications. + +EXTENSION is a string representing the output file extension, +with the leading dot. + +With a non-nil optional argument SUBTREEP, try to determine +output file's name by looking for \"EXPORT_FILE_NAME\" property +of subtree at point. + +When optional argument PUB-DIR is set, use it as the publishing +directory. + +When optional argument VISIBLE-ONLY is non-nil, don't export +contents of hidden elements. + +Return file name as a string, or nil if it couldn't be +determined." + (let ((base-name + ;; File name may come from EXPORT_FILE_NAME subtree property, + ;; assuming point is at beginning of said sub-tree. + (file-name-sans-extension + (or (and subtreep + (org-entry-get + (save-excursion + (ignore-errors (org-back-to-heading) (point))) + "EXPORT_FILE_NAME" t)) + ;; File name may be extracted from buffer's associated + ;; file, if any. + (buffer-file-name (buffer-base-buffer)) + ;; Can't determine file name on our own: Ask user. + (let ((read-file-name-function + (and org-completion-use-ido 'ido-read-file-name))) + (read-file-name + "Output file: " pub-dir nil nil nil + (lambda (name) + (string= (file-name-extension name t) extension)))))))) + ;; Build file name. Enforce EXTENSION over whatever user may have + ;; come up with. PUB-DIR, if defined, always has precedence over + ;; any provided path. + (cond + (pub-dir + (concat (file-name-as-directory pub-dir) + (file-name-nondirectory base-name) + extension)) + ((string= (file-name-nondirectory base-name) base-name) + (concat (file-name-as-directory ".") base-name extension)) + (t (concat base-name extension))))) + +(defmacro org-export-with-current-buffer-copy (&rest body) + "Apply BODY in a copy of the current buffer. + +The copy preserves local variables and visibility of the original +buffer. + +Point is at buffer's beginning when BODY is applied." + (org-with-gensyms (original-buffer offset buffer-string overlays) + `(let ((,original-buffer (current-buffer)) + (,offset (1- (point-min))) + (,buffer-string (buffer-string)) + (,overlays (mapcar + 'copy-overlay (overlays-in (point-min) (point-max))))) + (with-temp-buffer + (let ((buffer-invisibility-spec nil)) + (org-clone-local-variables + ,original-buffer + "^\\(org-\\|orgtbl-\\|major-mode$\\|outline-\\(regexp\\|level\\)$\\)") + (insert ,buffer-string) + (mapc (lambda (ov) + (move-overlay + ov + (- (overlay-start ov) ,offset) + (- (overlay-end ov) ,offset) + (current-buffer))) + ,overlays) + (goto-char (point-min)) + (progn ,@body)))))) +(def-edebug-spec org-export-with-current-buffer-copy (body)) + +(defun org-export-expand-include-keyword (&optional included dir) + "Expand every include keyword in buffer. +Optional argument INCLUDED is a list of included file names along +with their line restriction, when appropriate. It is used to +avoid infinite recursion. Optional argument DIR is the current +working directory. It is used to properly resolve relative +paths." + (let ((case-fold-search t)) + (goto-char (point-min)) + (while (re-search-forward "^[ \t]*#\\+INCLUDE: \\(.*\\)" nil t) + (when (eq (org-element-type (save-match-data (org-element-at-point))) + 'keyword) + (beginning-of-line) + ;; Extract arguments from keyword's value. + (let* ((value (match-string 1)) + (ind (org-get-indentation)) + (file (and (string-match "^\"\\(\\S-+\\)\"" value) + (prog1 (expand-file-name (match-string 1 value) dir) + (setq value (replace-match "" nil nil value))))) + (lines + (and (string-match + ":lines +\"\\(\\(?:[0-9]+\\)?-\\(?:[0-9]+\\)?\\)\"" value) + (prog1 (match-string 1 value) + (setq value (replace-match "" nil nil value))))) + (env (cond ((string-match "\\" value) 'example) + ((string-match "\\ level limit) (- level limit)))))) + +(defun org-export-get-headline-number (headline info) + "Return HEADLINE numbering as a list of numbers. +INFO is a plist holding contextual information." + (cdr (assoc headline (plist-get info :headline-numbering)))) + +(defun org-export-numbered-headline-p (headline info) + "Return a non-nil value if HEADLINE element should be numbered. +INFO is a plist used as a communication channel." + (let ((sec-num (plist-get info :section-numbers)) + (level (org-export-get-relative-level headline info))) + (if (wholenump sec-num) (<= level sec-num) sec-num))) + +(defun org-export-number-to-roman (n) + "Convert integer N into a roman numeral." + (let ((roman '((1000 . "M") (900 . "CM") (500 . "D") (400 . "CD") + ( 100 . "C") ( 90 . "XC") ( 50 . "L") ( 40 . "XL") + ( 10 . "X") ( 9 . "IX") ( 5 . "V") ( 4 . "IV") + ( 1 . "I"))) + (res "")) + (if (<= n 0) + (number-to-string n) + (while roman + (if (>= n (caar roman)) + (setq n (- n (caar roman)) + res (concat res (cdar roman))) + (pop roman))) + res))) + +(defun org-export-get-tags (element info &optional tags) + "Return list of tags associated to ELEMENT. + +ELEMENT has either an `headline' or an `inlinetask' type. INFO +is a plist used as a communication channel. + +Select tags (see `org-export-select-tags') and exclude tags (see +`org-export-exclude-tags') are removed from the list. + +When non-nil, optional argument TAGS should be a list of strings. +Any tag belonging to this list will also be removed." + (org-remove-if (lambda (tag) (or (member tag (plist-get info :select-tags)) + (member tag (plist-get info :exclude-tags)) + (member tag tags))) + (org-element-property :tags element))) + +(defun org-export-first-sibling-p (headline info) + "Non-nil when HEADLINE is the first sibling in its sub-tree. +INFO is a plist used as a communication channel." + (not (eq (org-element-type (org-export-get-previous-element headline info)) + 'headline))) + +(defun org-export-last-sibling-p (headline info) + "Non-nil when HEADLINE is the last sibling in its sub-tree. +INFO is a plist used as a communication channel." + (not (org-export-get-next-element headline info))) + + +;;;; For Links +;; +;; `org-export-solidify-link-text' turns a string into a safer version +;; for links, replacing most non-standard characters with hyphens. +;; +;; `org-export-get-coderef-format' returns an appropriate format +;; string for coderefs. +;; +;; `org-export-inline-image-p' returns a non-nil value when the link +;; provided should be considered as an inline image. +;; +;; `org-export-resolve-fuzzy-link' searches destination of fuzzy links +;; (i.e. links with "fuzzy" as type) within the parsed tree, and +;; returns an appropriate unique identifier when found, or nil. +;; +;; `org-export-resolve-id-link' returns the first headline with +;; specified id or custom-id in parse tree, the path to the external +;; file with the id or nil when neither was found. +;; +;; `org-export-resolve-coderef' associates a reference to a line +;; number in the element it belongs, or returns the reference itself +;; when the element isn't numbered. + +(defun org-export-solidify-link-text (s) + "Take link text S and make a safe target out of it." + (save-match-data + (mapconcat 'identity (org-split-string s "[^a-zA-Z0-9_.-]+") "-"))) + +(defun org-export-get-coderef-format (path desc) + "Return format string for code reference link. +PATH is the link path. DESC is its description." + (save-match-data + (cond ((not desc) "%s") + ((string-match (regexp-quote (concat "(" path ")")) desc) + (replace-match "%s" t t desc)) + (t desc)))) + +(defun org-export-inline-image-p (link &optional rules) + "Non-nil if LINK object points to an inline image. + +Optional argument is a set of RULES defining inline images. It +is an alist where associations have the following shape: + + \(TYPE . REGEXP) + +Applying a rule means apply REGEXP against LINK's path when its +type is TYPE. The function will return a non-nil value if any of +the provided rules is non-nil. The default rule is +`org-export-default-inline-image-rule'. + +This only applies to links without a description." + (and (not (org-element-contents link)) + (let ((case-fold-search t) + (rules (or rules org-export-default-inline-image-rule))) + (catch 'exit + (mapc + (lambda (rule) + (and (string= (org-element-property :type link) (car rule)) + (string-match (cdr rule) + (org-element-property :path link)) + (throw 'exit t))) + rules) + ;; Return nil if no rule matched. + nil)))) + +(defun org-export-resolve-coderef (ref info) + "Resolve a code reference REF. + +INFO is a plist used as a communication channel. + +Return associated line number in source code, or REF itself, +depending on src-block or example element's switches." + (org-element-map + (plist-get info :parse-tree) '(example-block src-block) + (lambda (el) + (with-temp-buffer + (insert (org-trim (org-element-property :value el))) + (let* ((label-fmt (regexp-quote + (or (org-element-property :label-fmt el) + org-coderef-label-format))) + (ref-re + (format "^.*?\\S-.*?\\([ \t]*\\(%s\\)\\)[ \t]*$" + (replace-regexp-in-string "%s" ref label-fmt nil t)))) + ;; Element containing REF is found. Resolve it to either + ;; a label or a line number, as needed. + (when (re-search-backward ref-re nil t) + (cond + ((org-element-property :use-labels el) ref) + ((eq (org-element-property :number-lines el) 'continued) + (+ (org-export-get-loc el info) (line-number-at-pos))) + (t (line-number-at-pos))))))) + info 'first-match)) + +(defun org-export-resolve-fuzzy-link (link info) + "Return LINK destination. + +INFO is a plist holding contextual information. + +Return value can be an object, an element, or nil: + +- If LINK path matches a target object (i.e. <>) or + element (i.e. \"#+TARGET: path\"), return it. + +- If LINK path exactly matches the name affiliated keyword + \(i.e. #+NAME: path) of an element, return that element. + +- If LINK path exactly matches any headline name, return that + element. If more than one headline share that name, priority + will be given to the one with the closest common ancestor, if + any, or the first one in the parse tree otherwise. + +- Otherwise, return nil. + +Assume LINK type is \"fuzzy\"." + (let* ((path (org-element-property :path link)) + (match-title-p (eq (aref path 0) ?*))) + (cond + ;; First try to find a matching "<>" unless user specified + ;; he was looking for an headline (path starts with a * + ;; character). + ((and (not match-title-p) + (loop for target in (plist-get info :target-list) + when (string= (org-element-property :value target) path) + return target))) + ;; Then try to find an element with a matching "#+NAME: path" + ;; affiliated keyword. + ((and (not match-title-p) + (org-element-map + (plist-get info :parse-tree) org-element-all-elements + (lambda (el) + (when (string= (org-element-property :name el) path) el)) + info 'first-match))) + ;; Last case: link either points to an headline or to + ;; nothingness. Try to find the source, with priority given to + ;; headlines with the closest common ancestor. If such candidate + ;; is found, return it, otherwise return nil. + (t + (let ((find-headline + (function + ;; Return first headline whose `:raw-value' property + ;; is NAME in parse tree DATA, or nil. + (lambda (name data) + (org-element-map + data 'headline + (lambda (headline) + (when (string= + (org-element-property :raw-value headline) + name) + headline)) + info 'first-match))))) + ;; Search among headlines sharing an ancestor with link, + ;; from closest to farthest. + (or (catch 'exit + (mapc + (lambda (parent) + (when (eq (org-element-type parent) 'headline) + (let ((foundp (funcall find-headline path parent))) + (when foundp (throw 'exit foundp))))) + (org-export-get-genealogy link)) nil) + ;; No match with a common ancestor: try the full parse-tree. + (funcall find-headline + (if match-title-p (substring path 1) path) + (plist-get info :parse-tree)))))))) + +(defun org-export-resolve-id-link (link info) + "Return headline referenced as LINK destination. + +INFO is a plist used as a communication channel. + +Return value can be the headline element matched in current parse +tree, a file name or nil. Assume LINK type is either \"id\" or +\"custom-id\"." + (let ((id (org-element-property :path link))) + ;; First check if id is within the current parse tree. + (or (org-element-map + (plist-get info :parse-tree) 'headline + (lambda (headline) + (when (or (string= (org-element-property :id headline) id) + (string= (org-element-property :custom-id headline) id)) + headline)) + info 'first-match) + ;; Otherwise, look for external files. + (cdr (assoc id (plist-get info :id-alist)))))) + +(defun org-export-resolve-radio-link (link info) + "Return radio-target object referenced as LINK destination. + +INFO is a plist used as a communication channel. + +Return value can be a radio-target object or nil. Assume LINK +has type \"radio\"." + (let ((path (org-element-property :path link))) + (org-element-map + (plist-get info :parse-tree) 'radio-target + (lambda (radio) + (when (equal (org-element-property :value radio) path) radio)) + info 'first-match))) + + +;;;; For Macros +;; +;; `org-export-expand-macro' simply takes care of expanding macros. + +(defun org-export-expand-macro (macro info) + "Expand MACRO and return it as a string. +INFO is a plist holding export options." + (let* ((key (org-element-property :key macro)) + (args (org-element-property :args macro)) + ;; User's macros are stored in the communication channel with + ;; a ":macro-" prefix. Replace arguments in VALUE. Also + ;; expand recursively macros within. + (value (org-export-data + (mapcar + (lambda (obj) + (if (not (stringp obj)) (org-export-data obj info) + (replace-regexp-in-string + "\\$[0-9]+" + (lambda (arg) + (nth (1- (string-to-number (substring arg 1))) args)) + obj))) + (plist-get info (intern (format ":macro-%s" key)))) + info))) + ;; VALUE starts with "(eval": it is a s-exp, `eval' it. + (when (string-match "\\`(eval\\>" value) (setq value (eval (read value)))) + ;; Return string. + (format "%s" (or value "")))) + + +;;;; For References +;; +;; `org-export-get-ordinal' associates a sequence number to any object +;; or element. + +(defun org-export-get-ordinal (element info &optional types predicate) + "Return ordinal number of an element or object. + +ELEMENT is the element or object considered. INFO is the plist +used as a communication channel. + +Optional argument TYPES, when non-nil, is a list of element or +object types, as symbols, that should also be counted in. +Otherwise, only provided element's type is considered. + +Optional argument PREDICATE is a function returning a non-nil +value if the current element or object should be counted in. It +accepts two arguments: the element or object being considered and +the plist used as a communication channel. This allows to count +only a certain type of objects (i.e. inline images). + +Return value is a list of numbers if ELEMENT is an headline or an +item. It is nil for keywords. It represents the footnote number +for footnote definitions and footnote references. If ELEMENT is +a target, return the same value as if ELEMENT was the closest +table, item or headline containing the target. In any other +case, return the sequence number of ELEMENT among elements or +objects of the same type." + ;; A target keyword, representing an invisible target, never has + ;; a sequence number. + (unless (eq (org-element-type element) 'keyword) + ;; Ordinal of a target object refer to the ordinal of the closest + ;; table, item, or headline containing the object. + (when (eq (org-element-type element) 'target) + (setq element + (loop for parent in (org-export-get-genealogy element) + when + (memq + (org-element-type parent) + '(footnote-definition footnote-reference headline item + table)) + return parent))) + (case (org-element-type element) + ;; Special case 1: An headline returns its number as a list. + (headline (org-export-get-headline-number element info)) + ;; Special case 2: An item returns its number as a list. + (item (let ((struct (org-element-property :structure element))) + (org-list-get-item-number + (org-element-property :begin element) + struct + (org-list-prevs-alist struct) + (org-list-parents-alist struct)))) + ((footnote-definition footnote-reference) + (org-export-get-footnote-number element info)) + (otherwise + (let ((counter 0)) + ;; Increment counter until ELEMENT is found again. + (org-element-map + (plist-get info :parse-tree) (or types (org-element-type element)) + (lambda (el) + (cond + ((eq element el) (1+ counter)) + ((not predicate) (incf counter) nil) + ((funcall predicate el info) (incf counter) nil))) + info 'first-match)))))) + + +;;;; For Src-Blocks +;; +;; `org-export-get-loc' counts number of code lines accumulated in +;; src-block or example-block elements with a "+n" switch until +;; a given element, excluded. Note: "-n" switches reset that count. +;; +;; `org-export-unravel-code' extracts source code (along with a code +;; references alist) from an `element-block' or `src-block' type +;; element. +;; +;; `org-export-format-code' applies a formatting function to each line +;; of code, providing relative line number and code reference when +;; appropriate. Since it doesn't access the original element from +;; which the source code is coming, it expects from the code calling +;; it to know if lines should be numbered and if code references +;; should appear. +;; +;; Eventually, `org-export-format-code-default' is a higher-level +;; function (it makes use of the two previous functions) which handles +;; line numbering and code references inclusion, and returns source +;; code in a format suitable for plain text or verbatim output. + +(defun org-export-get-loc (element info) + "Return accumulated lines of code up to ELEMENT. + +INFO is the plist used as a communication channel. + +ELEMENT is excluded from count." + (let ((loc 0)) + (org-element-map + (plist-get info :parse-tree) + `(src-block example-block ,(org-element-type element)) + (lambda (el) + (cond + ;; ELEMENT is reached: Quit the loop. + ((eq el element)) + ;; Only count lines from src-block and example-block elements + ;; with a "+n" or "-n" switch. A "-n" switch resets counter. + ((not (memq (org-element-type el) '(src-block example-block))) nil) + ((let ((linums (org-element-property :number-lines el))) + (when linums + ;; Accumulate locs or reset them. + (let ((lines (org-count-lines + (org-trim (org-element-property :value el))))) + (setq loc (if (eq linums 'new) lines (+ loc lines)))))) + ;; Return nil to stay in the loop. + nil))) + info 'first-match) + ;; Return value. + loc)) + +(defun org-export-unravel-code (element) + "Clean source code and extract references out of it. + +ELEMENT has either a `src-block' an `example-block' type. + +Return a cons cell whose CAR is the source code, cleaned from any +reference and protective comma and CDR is an alist between +relative line number (integer) and name of code reference on that +line (string)." + (let* ((line 0) refs + ;; Get code and clean it. Remove blank lines at its + ;; beginning and end. Also remove protective commas. + (code (let ((c (replace-regexp-in-string + "\\`\\([ \t]*\n\\)+" "" + (replace-regexp-in-string + "\\(:?[ \t]*\n\\)*[ \t]*\\'" "\n" + (org-element-property :value element))))) + ;; If appropriate, remove global indentation. + (unless (or org-src-preserve-indentation + (org-element-property :preserve-indent element)) + (setq c (org-remove-indentation c))) + ;; Free up the protected lines. Note: Org blocks + ;; have commas at the beginning or every line. + (if (string= (org-element-property :language element) "org") + (replace-regexp-in-string "^," "" c) + (replace-regexp-in-string + "^\\(,\\)\\(:?\\*\\|[ \t]*#\\+\\)" "" c nil nil 1)))) + ;; Get format used for references. + (label-fmt (regexp-quote + (or (org-element-property :label-fmt element) + org-coderef-label-format))) + ;; Build a regexp matching a loc with a reference. + (with-ref-re + (format "^.*?\\S-.*?\\([ \t]*\\(%s\\)[ \t]*\\)$" + (replace-regexp-in-string + "%s" "\\([-a-zA-Z0-9_ ]+\\)" label-fmt nil t)))) + ;; Return value. + (cons + ;; Code with references removed. + (org-element-normalize-string + (mapconcat + (lambda (loc) + (incf line) + (if (not (string-match with-ref-re loc)) loc + ;; Ref line: remove ref, and signal its position in REFS. + (push (cons line (match-string 3 loc)) refs) + (replace-match "" nil nil loc 1))) + (org-split-string code "\n") "\n")) + ;; Reference alist. + refs))) + +(defun org-export-format-code (code fun &optional num-lines ref-alist) + "Format CODE by applying FUN line-wise and return it. + +CODE is a string representing the code to format. FUN is +a function. It must accept three arguments: a line of +code (string), the current line number (integer) or nil and the +reference associated to the current line (string) or nil. + +Optional argument NUM-LINES can be an integer representing the +number of code lines accumulated until the current code. Line +numbers passed to FUN will take it into account. If it is nil, +FUN's second argument will always be nil. This number can be +obtained with `org-export-get-loc' function. + +Optional argument REF-ALIST can be an alist between relative line +number (i.e. ignoring NUM-LINES) and the name of the code +reference on it. If it is nil, FUN's third argument will always +be nil. It can be obtained through the use of +`org-export-unravel-code' function." + (let ((--locs (org-split-string code "\n")) + (--line 0)) + (org-element-normalize-string + (mapconcat + (lambda (--loc) + (incf --line) + (let ((--ref (cdr (assq --line ref-alist)))) + (funcall fun --loc (and num-lines (+ num-lines --line)) --ref))) + --locs "\n")))) + +(defun org-export-format-code-default (element info) + "Return source code from ELEMENT, formatted in a standard way. + +ELEMENT is either a `src-block' or `example-block' element. INFO +is a plist used as a communication channel. + +This function takes care of line numbering and code references +inclusion. Line numbers, when applicable, appear at the +beginning of the line, separated from the code by two white +spaces. Code references, on the other hand, appear flushed to +the right, separated by six white spaces from the widest line of +code." + ;; Extract code and references. + (let* ((code-info (org-export-unravel-code element)) + (code (car code-info)) + (code-lines (org-split-string code "\n")) + (refs (and (org-element-property :retain-labels element) + (cdr code-info))) + ;; Handle line numbering. + (num-start (case (org-element-property :number-lines element) + (continued (org-export-get-loc element info)) + (new 0))) + (num-fmt + (and num-start + (format "%%%ds " + (length (number-to-string + (+ (length code-lines) num-start)))))) + ;; Prepare references display, if required. Any reference + ;; should start six columns after the widest line of code, + ;; wrapped with parenthesis. + (max-width + (+ (apply 'max (mapcar 'length code-lines)) + (if (not num-start) 0 (length (format num-fmt num-start)))))) + (org-export-format-code + code + (lambda (loc line-num ref) + (let ((number-str (and num-fmt (format num-fmt line-num)))) + (concat + number-str + loc + (and ref + (concat (make-string + (- (+ 6 max-width) + (+ (length loc) (length number-str))) ? ) + (format "(%s)" ref)))))) + num-start refs))) + + +;;;; For Tables +;; +;; `org-export-table-has-special-column-p' and and +;; `org-export-table-row-is-special-p' are predicates used to look for +;; meta-information about the table structure. +;; +;; `org-table-has-header-p' tells when the rows before the first rule +;; should be considered as table's header. +;; +;; `org-export-table-cell-width', `org-export-table-cell-alignment' +;; and `org-export-table-cell-borders' extract information from +;; a table-cell element. +;; +;; `org-export-table-dimensions' gives the number on rows and columns +;; in the table, ignoring horizontal rules and special columns. +;; `org-export-table-cell-address', given a table-cell object, returns +;; the absolute address of a cell. On the other hand, +;; `org-export-get-table-cell-at' does the contrary. +;; +;; `org-export-table-cell-starts-colgroup-p', +;; `org-export-table-cell-ends-colgroup-p', +;; `org-export-table-row-starts-rowgroup-p', +;; `org-export-table-row-ends-rowgroup-p', +;; `org-export-table-row-starts-header-p' and +;; `org-export-table-row-ends-header-p' indicate position of current +;; row or cell within the table. + +(defun org-export-table-has-special-column-p (table) + "Non-nil when TABLE has a special column. +All special columns will be ignored during export." + ;; The table has a special column when every first cell of every row + ;; has an empty value or contains a symbol among "/", "#", "!", "$", + ;; "*" "_" and "^". Though, do not consider a first row containing + ;; only empty cells as special. + (let ((special-column-p 'empty)) + (catch 'exit + (mapc + (lambda (row) + (when (eq (org-element-property :type row) 'standard) + (let ((value (org-element-contents + (car (org-element-contents row))))) + (cond ((member value '(("/") ("#") ("!") ("$") ("*") ("_") ("^"))) + (setq special-column-p 'special)) + ((not value)) + (t (throw 'exit nil)))))) + (org-element-contents table)) + (eq special-column-p 'special)))) + +(defun org-export-table-has-header-p (table info) + "Non-nil when TABLE has an header. + +INFO is a plist used as a communication channel. + +A table has an header when it contains at least two row groups." + (let ((rowgroup 1) row-flag) + (org-element-map + table 'table-row + (lambda (row) + (cond + ((> rowgroup 1) t) + ((and row-flag (eq (org-element-property :type row) 'rule)) + (incf rowgroup) (setq row-flag nil)) + ((and (not row-flag) (eq (org-element-property :type row) 'standard)) + (setq row-flag t) nil))) + info))) + +(defun org-export-table-row-is-special-p (table-row info) + "Non-nil if TABLE-ROW is considered special. + +INFO is a plist used as the communication channel. + +All special rows will be ignored during export." + (when (eq (org-element-property :type table-row) 'standard) + (let ((first-cell (org-element-contents + (car (org-element-contents table-row))))) + ;; A row is special either when... + (or + ;; ... it starts with a field only containing "/", + (equal first-cell '("/")) + ;; ... the table contains a special column and the row start + ;; with a marking character among, "^", "_", "$" or "!", + (and (org-export-table-has-special-column-p + (org-export-get-parent table-row)) + (member first-cell '(("^") ("_") ("$") ("!")))) + ;; ... it contains only alignment cookies and empty cells. + (let ((special-row-p 'empty)) + (catch 'exit + (mapc + (lambda (cell) + (let ((value (org-element-contents cell))) + ;; Since VALUE is a secondary string, the following + ;; checks avoid expanding it with `org-export-data'. + (cond ((not value)) + ((and (not (cdr value)) + (stringp (car value)) + (string-match "\\`<[lrc]?\\([0-9]+\\)?>\\'" + (car value))) + (setq special-row-p 'cookie)) + (t (throw 'exit nil))))) + (org-element-contents table-row)) + (eq special-row-p 'cookie))))))) + +(defun org-export-table-row-group (table-row info) + "Return TABLE-ROW's group. + +INFO is a plist used as the communication channel. + +Return value is the group number, as an integer, or nil special +rows and table rules. Group 1 is also table's header." + (unless (or (eq (org-element-property :type table-row) 'rule) + (org-export-table-row-is-special-p table-row info)) + (let ((group 0) row-flag) + (catch 'found + (mapc + (lambda (row) + (cond + ((and (eq (org-element-property :type row) 'standard) + (not (org-export-table-row-is-special-p row info))) + (unless row-flag (incf group) (setq row-flag t))) + ((eq (org-element-property :type row) 'rule) + (setq row-flag nil))) + (when (eq table-row row) (throw 'found group))) + (org-element-contents (org-export-get-parent table-row))))))) + +(defun org-export-table-cell-width (table-cell info) + "Return TABLE-CELL contents width. + +INFO is a plist used as the communication channel. + +Return value is the width given by the last width cookie in the +same column as TABLE-CELL, or nil." + (let* ((row (org-export-get-parent table-cell)) + (column (let ((cells (org-element-contents row))) + (- (length cells) (length (memq table-cell cells))))) + (table (org-export-get-parent-table table-cell)) + cookie-width) + (mapc + (lambda (row) + (cond + ;; In a special row, try to find a width cookie at COLUMN. + ((org-export-table-row-is-special-p row info) + (let ((value (org-element-contents + (elt (org-element-contents row) column)))) + ;; The following checks avoid expanding unnecessarily the + ;; cell with `org-export-data' + (when (and value + (not (cdr value)) + (stringp (car value)) + (string-match "\\`<[lrc]?\\([0-9]+\\)?>\\'" (car value)) + (match-string 1 (car value))) + (setq cookie-width + (string-to-number (match-string 1 (car value))))))) + ;; Ignore table rules. + ((eq (org-element-property :type row) 'rule)))) + (org-element-contents table)) + ;; Return value. + cookie-width)) + +(defun org-export-table-cell-alignment (table-cell info) + "Return TABLE-CELL contents alignment. + +INFO is a plist used as the communication channel. + +Return alignment as specified by the last alignment cookie in the +same column as TABLE-CELL. If no such cookie is found, a default +alignment value will be deduced from fraction of numbers in the +column (see `org-table-number-fraction' for more information). +Possible values are `left', `right' and `center'." + (let* ((row (org-export-get-parent table-cell)) + (column (let ((cells (org-element-contents row))) + (- (length cells) (length (memq table-cell cells))))) + (table (org-export-get-parent-table table-cell)) + (number-cells 0) + (total-cells 0) + cookie-align) + (mapc + (lambda (row) + (cond + ;; In a special row, try to find an alignment cookie at + ;; COLUMN. + ((org-export-table-row-is-special-p row info) + (let ((value (org-element-contents + (elt (org-element-contents row) column)))) + ;; Since VALUE is a secondary string, the following checks + ;; avoid useless expansion through `org-export-data'. + (when (and value + (not (cdr value)) + (stringp (car value)) + (string-match "\\`<\\([lrc]\\)?\\([0-9]+\\)?>\\'" + (car value)) + (match-string 1 (car value))) + (setq cookie-align (match-string 1 (car value)))))) + ;; Ignore table rules. + ((eq (org-element-property :type row) 'rule)) + ;; In a standard row, check if cell's contents are expressing + ;; some kind of number. Increase NUMBER-CELLS accordingly. + ;; Though, don't bother if an alignment cookie has already + ;; defined cell's alignment. + ((not cookie-align) + (let ((value (org-export-data + (org-element-contents + (elt (org-element-contents row) column)) + info))) + (incf total-cells) + (when (string-match org-table-number-regexp value) + (incf number-cells)))))) + (org-element-contents table)) + ;; Return value. Alignment specified by cookies has precedence + ;; over alignment deduced from cells contents. + (cond ((equal cookie-align "l") 'left) + ((equal cookie-align "r") 'right) + ((equal cookie-align "c") 'center) + ((>= (/ (float number-cells) total-cells) org-table-number-fraction) + 'right) + (t 'left)))) + +(defun org-export-table-cell-borders (table-cell info) + "Return TABLE-CELL borders. + +INFO is a plist used as a communication channel. + +Return value is a list of symbols, or nil. Possible values are: +`top', `bottom', `above', `below', `left' and `right'. Note: +`top' (resp. `bottom') only happen for a cell in the first +row (resp. last row) of the table, ignoring table rules, if any. + +Returned borders ignore special rows." + (let* ((row (org-export-get-parent table-cell)) + (table (org-export-get-parent-table table-cell)) + borders) + ;; Top/above border? TABLE-CELL has a border above when a rule + ;; used to demarcate row groups can be found above. Hence, + ;; finding a rule isn't sufficient to push `above' in BORDERS: + ;; another regular row has to be found above that rule. + (let (rule-flag) + (catch 'exit + (mapc (lambda (row) + (cond ((eq (org-element-property :type row) 'rule) + (setq rule-flag t)) + ((not (org-export-table-row-is-special-p row info)) + (if rule-flag (throw 'exit (push 'above borders)) + (throw 'exit nil))))) + ;; Look at every row before the current one. + (cdr (memq row (reverse (org-element-contents table))))) + ;; No rule above, or rule found starts the table (ignoring any + ;; special row): TABLE-CELL is at the top of the table. + (when rule-flag (push 'above borders)) + (push 'top borders))) + ;; Bottom/below border? TABLE-CELL has a border below when next + ;; non-regular row below is a rule. + (let (rule-flag) + (catch 'exit + (mapc (lambda (row) + (cond ((eq (org-element-property :type row) 'rule) + (setq rule-flag t)) + ((not (org-export-table-row-is-special-p row info)) + (if rule-flag (throw 'exit (push 'below borders)) + (throw 'exit nil))))) + ;; Look at every row after the current one. + (cdr (memq row (org-element-contents table)))) + ;; No rule below, or rule found ends the table (modulo some + ;; special row): TABLE-CELL is at the bottom of the table. + (when rule-flag (push 'below borders)) + (push 'bottom borders))) + ;; Right/left borders? They can only be specified by column + ;; groups. Column groups are defined in a row starting with "/". + ;; Also a column groups row only contains "<", "<>", ">" or blank + ;; cells. + (catch 'exit + (let ((column (let ((cells (org-element-contents row))) + (- (length cells) (length (memq table-cell cells)))))) + (mapc + (lambda (row) + (unless (eq (org-element-property :type row) 'rule) + (when (equal (org-element-contents + (car (org-element-contents row))) + '("/")) + (let ((column-groups + (mapcar + (lambda (cell) + (let ((value (org-element-contents cell))) + (when (member value '(("<") ("<>") (">") nil)) + (car value)))) + (org-element-contents row)))) + ;; There's a left border when previous cell, if + ;; any, ends a group, or current one starts one. + (when (or (and (not (zerop column)) + (member (elt column-groups (1- column)) + '(">" "<>"))) + (member (elt column-groups column) '("<" "<>"))) + (push 'left borders)) + ;; There's a right border when next cell, if any, + ;; starts a group, or current one ends one. + (when (or (and (/= (1+ column) (length column-groups)) + (member (elt column-groups (1+ column)) + '("<" "<>"))) + (member (elt column-groups column) '(">" "<>"))) + (push 'right borders)) + (throw 'exit nil))))) + ;; Table rows are read in reverse order so last column groups + ;; row has precedence over any previous one. + (reverse (org-element-contents table))))) + ;; Return value. + borders)) + +(defun org-export-table-cell-starts-colgroup-p (table-cell info) + "Non-nil when TABLE-CELL is at the beginning of a row group. +INFO is a plist used as a communication channel." + ;; A cell starts a column group either when it is at the beginning + ;; of a row (or after the special column, if any) or when it has + ;; a left border. + (or (eq (org-element-map + (org-export-get-parent table-cell) + 'table-cell 'identity info 'first-match) + table-cell) + (memq 'left (org-export-table-cell-borders table-cell info)))) + +(defun org-export-table-cell-ends-colgroup-p (table-cell info) + "Non-nil when TABLE-CELL is at the end of a row group. +INFO is a plist used as a communication channel." + ;; A cell ends a column group either when it is at the end of a row + ;; or when it has a right border. + (or (eq (car (last (org-element-contents + (org-export-get-parent table-cell)))) + table-cell) + (memq 'right (org-export-table-cell-borders table-cell info)))) + +(defun org-export-table-row-starts-rowgroup-p (table-row info) + "Non-nil when TABLE-ROW is at the beginning of a column group. +INFO is a plist used as a communication channel." + (unless (or (eq (org-element-property :type table-row) 'rule) + (org-export-table-row-is-special-p table-row info)) + (let ((borders (org-export-table-cell-borders + (car (org-element-contents table-row)) info))) + (or (memq 'top borders) (memq 'above borders))))) + +(defun org-export-table-row-ends-rowgroup-p (table-row info) + "Non-nil when TABLE-ROW is at the end of a column group. +INFO is a plist used as a communication channel." + (unless (or (eq (org-element-property :type table-row) 'rule) + (org-export-table-row-is-special-p table-row info)) + (let ((borders (org-export-table-cell-borders + (car (org-element-contents table-row)) info))) + (or (memq 'bottom borders) (memq 'below borders))))) + +(defun org-export-table-row-starts-header-p (table-row info) + "Non-nil when TABLE-ROW is the first table header's row. +INFO is a plist used as a communication channel." + (and (org-export-table-has-header-p + (org-export-get-parent-table table-row) info) + (org-export-table-row-starts-rowgroup-p table-row info) + (= (org-export-table-row-group table-row info) 1))) + +(defun org-export-table-row-ends-header-p (table-row info) + "Non-nil when TABLE-ROW is the last table header's row. +INFO is a plist used as a communication channel." + (and (org-export-table-has-header-p + (org-export-get-parent-table table-row) info) + (org-export-table-row-ends-rowgroup-p table-row info) + (= (org-export-table-row-group table-row info) 1))) + +(defun org-export-table-dimensions (table info) + "Return TABLE dimensions. + +INFO is a plist used as a communication channel. + +Return value is a CONS like (ROWS . COLUMNS) where +ROWS (resp. COLUMNS) is the number of exportable +rows (resp. columns)." + (let (first-row (columns 0) (rows 0)) + ;; Set number of rows, and extract first one. + (org-element-map + table 'table-row + (lambda (row) + (when (eq (org-element-property :type row) 'standard) + (incf rows) + (unless first-row (setq first-row row)))) info) + ;; Set number of columns. + (org-element-map first-row 'table-cell (lambda (cell) (incf columns)) info) + ;; Return value. + (cons rows columns))) + +(defun org-export-table-cell-address (table-cell info) + "Return address of a regular TABLE-CELL object. + +TABLE-CELL is the cell considered. INFO is a plist used as +a communication channel. + +Address is a CONS cell (ROW . COLUMN), where ROW and COLUMN are +zero-based index. Only exportable cells are considered. The +function returns nil for other cells." + (let* ((table-row (org-export-get-parent table-cell)) + (table (org-export-get-parent-table table-cell))) + ;; Ignore cells in special rows or in special column. + (unless (or (org-export-table-row-is-special-p table-row info) + (and (org-export-table-has-special-column-p table) + (eq (car (org-element-contents table-row)) table-cell))) + (cons + ;; Row number. + (let ((row-count 0)) + (org-element-map + table 'table-row + (lambda (row) + (cond ((eq (org-element-property :type row) 'rule) nil) + ((eq row table-row) row-count) + (t (incf row-count) nil))) + info 'first-match)) + ;; Column number. + (let ((col-count 0)) + (org-element-map + table-row 'table-cell + (lambda (cell) + (if (eq cell table-cell) col-count (incf col-count) nil)) + info 'first-match)))))) + +(defun org-export-get-table-cell-at (address table info) + "Return regular table-cell object at ADDRESS in TABLE. + +Address is a CONS cell (ROW . COLUMN), where ROW and COLUMN are +zero-based index. TABLE is a table type element. INFO is +a plist used as a communication channel. + +If no table-cell, among exportable cells, is found at ADDRESS, +return nil." + (let ((column-pos (cdr address)) (column-count 0)) + (org-element-map + ;; Row at (car address) or nil. + (let ((row-pos (car address)) (row-count 0)) + (org-element-map + table 'table-row + (lambda (row) + (cond ((eq (org-element-property :type row) 'rule) nil) + ((= row-count row-pos) row) + (t (incf row-count) nil))) + info 'first-match)) + 'table-cell + (lambda (cell) + (if (= column-count column-pos) cell + (incf column-count) nil)) + info 'first-match))) + + +;;;; For Tables Of Contents +;; +;; `org-export-collect-headlines' builds a list of all exportable +;; headline elements, maybe limited to a certain depth. One can then +;; easily parse it and transcode it. +;; +;; Building lists of tables, figures or listings is quite similar. +;; Once the generic function `org-export-collect-elements' is defined, +;; `org-export-collect-tables', `org-export-collect-figures' and +;; `org-export-collect-listings' can be derived from it. + +(defun org-export-collect-headlines (info &optional n) + "Collect headlines in order to build a table of contents. + +INFO is a plist used as a communication channel. + +When optional argument N is an integer, it specifies the depth of +the table of contents. Otherwise, it is set to the value of the +last headline level. See `org-export-headline-levels' for more +information. + +Return a list of all exportable headlines as parsed elements." + (unless (wholenump n) (setq n (plist-get info :headline-levels))) + (org-element-map + (plist-get info :parse-tree) + 'headline + (lambda (headline) + ;; Strip contents from HEADLINE. + (let ((relative-level (org-export-get-relative-level headline info))) + (unless (> relative-level n) headline))) + info)) + +(defun org-export-collect-elements (type info &optional predicate) + "Collect referenceable elements of a determined type. + +TYPE can be a symbol or a list of symbols specifying element +types to search. Only elements with a caption are collected. + +INFO is a plist used as a communication channel. + +When non-nil, optional argument PREDICATE is a function accepting +one argument, an element of type TYPE. It returns a non-nil +value when that element should be collected. + +Return a list of all elements found, in order of appearance." + (org-element-map + (plist-get info :parse-tree) type + (lambda (element) + (and (org-element-property :caption element) + (or (not predicate) (funcall predicate element)) + element)) + info)) + +(defun org-export-collect-tables (info) + "Build a list of tables. +INFO is a plist used as a communication channel. + +Return a list of table elements with a caption." + (org-export-collect-elements 'table info)) + +(defun org-export-collect-figures (info predicate) + "Build a list of figures. + +INFO is a plist used as a communication channel. PREDICATE is +a function which accepts one argument: a paragraph element and +whose return value is non-nil when that element should be +collected. + +A figure is a paragraph type element, with a caption, verifying +PREDICATE. The latter has to be provided since a \"figure\" is +a vague concept that may depend on back-end. + +Return a list of elements recognized as figures." + (org-export-collect-elements 'paragraph info predicate)) + +(defun org-export-collect-listings (info) + "Build a list of src blocks. + +INFO is a plist used as a communication channel. + +Return a list of src-block elements with a caption." + (org-export-collect-elements 'src-block info)) + + +;;;; Topology +;; +;; Here are various functions to retrieve information about the +;; neighbourhood of a given element or object. Neighbours of interest +;; are direct parent (`org-export-get-parent'), parent headline +;; (`org-export-get-parent-headline'), first element containing an +;; object, (`org-export-get-parent-element'), parent table +;; (`org-export-get-parent-table'), previous element or object +;; (`org-export-get-previous-element') and next element or object +;; (`org-export-get-next-element'). +;; +;; `org-export-get-genealogy' returns the full genealogy of a given +;; element or object, from closest parent to full parse tree. + +(defun org-export-get-parent (blob) + "Return BLOB parent or nil. +BLOB is the element or object considered." + (org-element-property :parent blob)) + +(defun org-export-get-genealogy (blob) + "Return full genealogy relative to a given element or object. + +BLOB is the element or object being considered. + +Ancestors are returned from closest to farthest, the last one +being the full parse tree." + (let (genealogy (parent blob)) + (while (setq parent (org-element-property :parent parent)) + (push parent genealogy)) + (nreverse genealogy))) + +(defun org-export-get-parent-headline (blob) + "Return BLOB parent headline or nil. +BLOB is the element or object being considered." + (let ((parent blob)) + (while (and (setq parent (org-element-property :parent parent)) + (not (eq (org-element-type parent) 'headline)))) + parent)) + +(defun org-export-get-parent-element (object) + "Return first element containing OBJECT or nil. +OBJECT is the object to consider." + (let ((parent object)) + (while (and (setq parent (org-element-property :parent parent)) + (memq (org-element-type parent) org-element-all-objects))) + parent)) + +(defun org-export-get-parent-table (object) + "Return OBJECT parent table or nil. +OBJECT is either a `table-cell' or `table-element' type object." + (let ((parent object)) + (while (and (setq parent (org-element-property :parent parent)) + (not (eq (org-element-type parent) 'table)))) + parent)) + +(defun org-export-get-previous-element (blob info) + "Return previous element or object. +BLOB is an element or object. INFO is a plist used as +a communication channel. Return previous exportable element or +object, a string, or nil." + (let (prev) + (catch 'exit + (mapc (lambda (obj) + (cond ((eq obj blob) (throw 'exit prev)) + ((memq obj (plist-get info :ignore-list))) + (t (setq prev obj)))) + (org-element-contents (org-export-get-parent blob)))))) + +(defun org-export-get-next-element (blob info) + "Return next element or object. +BLOB is an element or object. INFO is a plist used as +a communication channel. Return next exportable element or +object, a string, or nil." + (catch 'found + (mapc (lambda (obj) + (unless (memq obj (plist-get info :ignore-list)) + (throw 'found obj))) + (cdr (memq blob (org-element-contents (org-export-get-parent blob))))) + nil)) + + +;;;; Translation +;; +;; `org-export-translate' translates a string according to language +;; specified by LANGUAGE keyword or `org-export-language-setup' +;; variable and a specified charset. `org-export-dictionary' contains +;; the dictionary used for the translation. + +(defconst org-export-dictionary + '(("Author" + ("fr" + :ascii "Auteur" + :latin1 "Auteur" + :utf-8 "Auteur")) + ("Date" + ("fr" + :ascii "Date" + :latin1 "Date" + :utf-8 "Date")) + ("Equation") + ("Figure") + ("Footnotes" + ("fr" + :ascii "Notes de bas de page" + :latin1 "Notes de bas de page" + :utf-8 "Notes de bas de page")) + ("List of Listings" + ("fr" + :ascii "Liste des programmes" + :latin1 "Liste des programmes" + :utf-8 "Liste des programmes")) + ("List of Tables" + ("fr" + :ascii "Liste des tableaux" + :latin1 "Liste des tableaux" + :utf-8 "Liste des tableaux")) + ("Listing %d:" + ("fr" + :ascii "Programme %d :" + :latin1 "Programme %d :" + :utf-8 "Programme nº %d :")) + ("Listing %d: %s" + ("fr" + :ascii "Programme %d : %s" + :latin1 "Programme %d : %s" + :utf-8 "Programme nº %d : %s")) + ("See section %s" + ("fr" + :ascii "cf. section %s" + :latin1 "cf. section %s" + :utf-8 "cf. section %s")) + ("Table %d:" + ("fr" + :ascii "Tableau %d :" + :latin1 "Tableau %d :" + :utf-8 "Tableau nº %d :")) + ("Table %d: %s" + ("fr" + :ascii "Tableau %d : %s" + :latin1 "Tableau %d : %s" + :utf-8 "Tableau nº %d : %s")) + ("Table of Contents" + ("fr" + :ascii "Sommaire" + :latin1 "Table des matières" + :utf-8 "Table des matières")) + ("Unknown reference" + ("fr" + :ascii "Destination inconnue" + :latin1 "Référence inconnue" + :utf-8 "Référence inconnue"))) + "Dictionary for export engine. + +Alist whose CAR is the string to translate and CDR is an alist +whose CAR is the language string and CDR is a plist whose +properties are possible charsets and values translated terms. + +It is used as a database for `org-export-translate'. Since this +function returns the string as-is if no translation was found, +the variable only needs to record values different from the +entry.") + +(defun org-export-translate (s encoding info) + "Translate string S according to language specification. + +ENCODING is a symbol among `:ascii', `:html', `:latex', `:latin1' +and `:utf-8'. INFO is a plist used as a communication channel. + +Translation depends on `:language' property. Return the +translated string. If no translation is found return S." + (let ((lang (plist-get info :language)) + (translations (cdr (assoc s org-export-dictionary)))) + (or (plist-get (cdr (assoc lang translations)) encoding) s))) + + + +;;; The Dispatcher +;; +;; `org-export-dispatch' is the standard interactive way to start an +;; export process. It uses `org-export-dispatch-ui' as a subroutine +;; for its interface. Most commons back-ends should have an entry in +;; it. + +;;;###autoload +(defun org-export-dispatch () + "Export dispatcher for Org mode. + +It provides an access to common export related tasks in a buffer. +Its interface comes in two flavours: standard and expert. While +both share the same set of bindings, only the former displays the +valid keys associations. Set `org-export-dispatch-use-expert-ui' +to switch to one or the other. + +Return an error if key pressed has no associated command." + (interactive) + (let* ((input (org-export-dispatch-ui + (if (listp org-export-initial-scope) org-export-initial-scope + (list org-export-initial-scope)) + org-export-dispatch-use-expert-ui)) + (raw-key (car input)) + (optns (cdr input))) + ;; Translate "C-a", "C-b"... into "a", "b"... Then take action + ;; depending on user's key pressed. + (case (if (< raw-key 27) (+ raw-key 96) raw-key) + ;; Allow to quit with "q" key. + (?q nil) + ;; Export with `e-ascii' back-end. + ((?A ?N ?U) + (org-e-ascii-export-as-ascii + (memq 'subtree optns) (memq 'visible optns) (memq 'body optns) + `(:ascii-charset ,(case raw-key (?A 'ascii) (?N 'latin1) (t 'utf-8))))) + ((?a ?n ?u) + (org-e-ascii-export-to-ascii + (memq 'subtree optns) (memq 'visible optns) (memq 'body optns) + `(:ascii-charset ,(case raw-key (?a 'ascii) (?n 'latin1) (t 'utf-8))))) + ;; Export with `e-latex' back-end. + (?L (org-e-latex-export-as-latex + (memq 'subtree optns) (memq 'visible optns) (memq 'body optns))) + (?l + (org-e-latex-export-to-latex + (memq 'subtree optns) (memq 'visible optns) (memq 'body optns))) + (?p + (org-e-latex-export-to-pdf + (memq 'subtree optns) (memq 'visible optns) (memq 'body optns))) + (?d + (org-open-file + (org-e-latex-export-to-pdf + (memq 'subtree optns) (memq 'visible optns) (memq 'body optns)))) + ;; Export with `e-html' back-end. + (?H + (org-e-html-export-as-html + (memq 'subtree optns) (memq 'visible optns) (memq 'body optns))) + (?h + (org-e-html-export-to-html + (memq 'subtree optns) (memq 'visible optns) (memq 'body optns))) + (?b + (org-open-file + (org-e-html-export-to-html + (memq 'subtree optns) (memq 'visible optns) (memq 'body optns)))) + ;; Export with `e-odt' back-end. + (?o + (org-e-odt-export-to-odt + (memq 'subtree optns) (memq 'visible optns) (memq 'body optns))) + (?O + (org-open-file + (org-e-odt-export-to-odt + (memq 'subtree optns) (memq 'visible optns) (memq 'body optns)))) + ;; Publishing facilities + (?F + (org-e-publish-current-file (memq 'force optns))) + (?P + (org-e-publish-current-project (memq 'force optns))) + (?X + (let ((project + (assoc (org-icompleting-read + "Publish project: " org-e-publish-project-alist nil t) + org-e-publish-project-alist))) + (org-e-publish project (memq 'force optns)))) + (?E + (org-e-publish-all (memq 'force optns))) + ;; Undefined command. + (t (error "No command associated with key %s" + (char-to-string raw-key)))))) + +(defun org-export-dispatch-ui (options expertp) + "Handle interface for `org-export-dispatch'. + +OPTIONS is a list containing current interactive options set for +export. It can contain any of the following symbols: +`body' toggles a body-only export +`subtree' restricts export to current subtree +`visible' restricts export to visible part of buffer. +`force' force publishing files. + +EXPERTP, when non-nil, triggers expert UI. In that case, no help +buffer is provided, but indications about currently active +options are given in the prompt. Moreover, \[?] allows to switch +back to standard interface. + +Return value is a list with key pressed as CAR and a list of +final interactive export options as CDR." + (let ((help + (format "---- (Options) ------------------------------------------- + +\[1] Body only: %s [2] Export scope: %s +\[3] Visible only: %s [4] Force publishing: %s + + +--- (ASCII/Latin-1/UTF-8 Export) ------------------------- + +\[a/n/u] to TXT file [A/N/U] to temporary buffer + +--- (HTML Export) ---------------------------------------- + +\[h] to HTML file [b] ... and open it +\[H] to temporary buffer + +--- (LaTeX Export) --------------------------------------- + +\[l] to TEX file [L] to temporary buffer +\[p] to PDF file [d] ... and open it + +--- (ODF Export) ----------------------------------------- + +\[o] to ODT file [O] ... and open it + +--- (Publish) -------------------------------------------- + +\[F] current file [P] current project +\[X] a project [E] every project" + (if (memq 'body options) "On " "Off") + (if (memq 'subtree options) "Subtree" "Buffer ") + (if (memq 'visible options) "On " "Off") + (if (memq 'force options) "On " "Off"))) + (standard-prompt "Export command: ") + (expert-prompt (format "Export command (%s%s%s%s): " + (if (memq 'body options) "b" "-") + (if (memq 'subtree options) "s" "-") + (if (memq 'visible options) "v" "-") + (if (memq 'force options) "f" "-"))) + (handle-keypress + (function + ;; Read a character from command input, toggling interactive + ;; options when applicable. PROMPT is the displayed prompt, + ;; as a string. + (lambda (prompt) + (let ((key (read-char-exclusive prompt))) + (cond + ;; Ignore non-standard characters (i.e. "M-a"). + ((not (characterp key)) (org-export-dispatch-ui options expertp)) + ;; Help key: Switch back to standard interface if + ;; expert UI was active. + ((eq key ??) (org-export-dispatch-ui options nil)) + ;; Toggle export options. + ((memq key '(?1 ?2 ?3 ?4)) + (org-export-dispatch-ui + (let ((option (case key (?1 'body) (?2 'subtree) (?3 'visible) + (?4 'force)))) + (if (memq option options) (remq option options) + (cons option options))) + expertp)) + ;; Action selected: Send key and options back to + ;; `org-export-dispatch'. + (t (cons key options)))))))) + ;; With expert UI, just read key with a fancy prompt. In standard + ;; UI, display an intrusive help buffer. + (if expertp (funcall handle-keypress expert-prompt) + (save-window-excursion + (delete-other-windows) + (with-output-to-temp-buffer "*Org Export/Publishing Help*" (princ help)) + (org-fit-window-to-buffer + (get-buffer-window "*Org Export/Publishing Help*")) + (funcall handle-keypress standard-prompt))))) + + +(provide 'org-export) +;;; org-export.el ends here diff --git a/contrib/lisp/org-git-link.el b/contrib/lisp/org-git-link.el new file mode 100644 index 0000000..8223712 --- /dev/null +++ b/contrib/lisp/org-git-link.el @@ -0,0 +1,220 @@ +;;; org-git-link.el --- Provide org links to specific file version + +;; Copyright (C) 2009-2012 Reimar Finken + +;; Author: Reimar Finken +;; Keywords: files, calendar, hypermedia + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distaributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; `org-git-link.el' defines two new link types. The `git' link +;; type is meant to be used in the typical scenario and mimics the +;; `file' link syntax as closely as possible. The `gitbare' link +;; type exists mostly for debugging reasons, but also allows e.g. +;; linking to files in a bare git repository for the experts. + +;; * User friendy form +;; [[git:/path/to/file::searchstring]] + +;; This form is the familiar from normal org file links +;; including search options. However, its use is +;; restricted to files in a working directory and does not +;; handle bare repositories on purpose (see the bare form for +;; that). + +;; The search string references a commit (a tree-ish in Git +;; terminology). The two most useful types of search strings are + +;; - A symbolic ref name, usually a branch or tag name (e.g. +;; master or nobelprize). +;; - A ref followed by the suffix @ with a date specification +;; enclosed in a brace pair (e.g. {yesterday}, {1 month 2 +;; weeks 3 days 1 hour 1 second ago} or {1979-02-26 18:30:00}) +;; to specify the value of the ref at a prior point in time +;; +;; * Bare git form +;; [[gitbare:$GIT_DIR::$OBJECT]] +;; +;; This is the more bare metal version, which gives the user most +;; control. It directly translates to the git command +;; git --no-pager --git-dir=$GIT_DIR show $OBJECT +;; Using this version one can also view files from a bare git +;; repository. For detailed information on how to specify an +;; object, see the man page of `git-rev-parse' (section +;; SPECIFYING REVISIONS). A specific blob (file) can be +;; specified by a suffix clolon (:) followed by a path. + +;;; Code: + +(require 'org) +(defcustom org-git-program "git" + "Name of the git executable used to follow git links." + :type '(string) + :group 'org) + +;; org link functions +;; bare git link +(org-add-link-type "gitbare" 'org-gitbare-open) + +(defun org-gitbare-open (str) + (let* ((strlist (org-git-split-string str)) + (gitdir (first strlist)) + (object (second strlist))) + (org-git-open-file-internal gitdir object))) + + +(defun org-git-open-file-internal (gitdir object) + (let* ((sha (org-git-blob-sha gitdir object)) + (tmpdir (concat temporary-file-directory "org-git-" sha)) + (filename (org-git-link-filename object)) + (tmpfile (expand-file-name filename tmpdir))) + (unless (file-readable-p tmpfile) + (make-directory tmpdir) + (with-temp-file tmpfile + (org-git-show gitdir object (current-buffer)))) + (org-open-file tmpfile) + (set-buffer (get-file-buffer tmpfile)) + (setq buffer-read-only t))) + +;; user friendly link +(org-add-link-type "git" 'org-git-open) + +(defun org-git-open (str) + (let* ((strlist (org-git-split-string str)) + (filepath (first strlist)) + (commit (second strlist)) + (dirlist (org-git-find-gitdir (file-truename filepath))) + (gitdir (first dirlist)) + (relpath (second dirlist))) + (org-git-open-file-internal gitdir (concat commit ":" relpath)))) + + +;; Utility functions (file names etc) + +(defun org-git-split-dirpath (dirpath) + "Given a directory name, return '(dirname basname)" + (let ((dirname (file-name-directory (directory-file-name dirpath))) + (basename (file-name-nondirectory (directory-file-name dirpath)))) + (list dirname basename))) + +;; finding the git directory +(defun org-git-find-gitdir (path) + "Given a file (not necessarily existing) file path, return the + a pair (gitdir relpath), where gitdir is the path to the first + .git subdirectory found updstream and relpath is the rest of + the path. Example: (org-git-find-gitdir + \"~/gitrepos/foo/bar.txt\") returns + '(\"/home/user/gitrepos/.git\" \"foo/bar.txt\"). When not in a git repository, return nil." + (let ((dir (file-name-directory path)) + (relpath (file-name-nondirectory path))) + (catch 'toplevel + (while (not (file-exists-p (expand-file-name ".git" dir))) + (let ((dirlist (org-git-split-dirpath dir))) + (when (string= (second dirlist) "") ; at top level + (throw 'toplevel nil)) + (setq dir (first dirlist) + relpath (concat (file-name-as-directory (second dirlist)) relpath)))) + (list (expand-file-name ".git" dir) relpath)))) + + +(if (featurep 'xemacs) + (defalias 'org-git-gitrepos-p 'org-git-find-gitdir) + (defalias 'org-git-gitrepos-p 'org-git-find-gitdir + "Return non-nil if path is in git repository")) + +;; splitting the link string + +;; Both link open functions are called with a string of +;; consisting of two parts separated by a double colon (::). +(defun org-git-split-string (str) + "Given a string of the form \"str1::str2\", return a list of + two substrings \'(\"str1\" \"str2\"). If the double colon is mising, take str2 to be the empty string." + (let ((strlist (split-string str "::"))) + (cond ((= 1 (length strlist)) + (list (car strlist) "")) + ((= 2 (length strlist)) + strlist) + (t (error "org-git-split-string: only one :: allowed: %s" str))))) + +;; finding the file name part of a commit +(defun org-git-link-filename (str) + "Given an object description (see the man page of + git-rev-parse), return the nondirectory part of the referenced + filename, if it can be extracted. Otherwise, return a valid + filename." + (let* ((match (and (string-match "[^:]+$" str) + (match-string 0 str))) + (filename (and match (file-name-nondirectory match)))) ;extract the final part without slash + filename)) + +;; creating a link +(defun org-git-create-searchstring (branch timestring) + (concat branch "@{" timestring "}")) + + +(defun org-git-create-git-link (file) + "Create git link part to file at specific time" + (interactive "FFile: ") + (let* ((gitdir (first (org-git-find-gitdir (file-truename file)))) + (branchname (org-git-get-current-branch gitdir)) + (timestring (format-time-string "%Y-%m-%d" (current-time)))) + (contact "git:" file "::" (org-git-create-searchstring branchname timestring)))) + +(defun org-git-store-link () + "Store git link to current file." + (when (buffer-file-name) + (let ((file (abbreviate-file-name (buffer-file-name)))) + (when (org-git-gitrepos-p file) + (org-store-link-props + :type "git" + :link (org-git-create-git-link file)))))) + +(add-hook 'org-store-link-functions 'org-git-store-link) + +(defun org-git-insert-link-interactively (file searchstring &optional description) + (interactive "FFile: \nsSearch string: \nsDescription: ") + (insert (org-make-link-string (concat "git:" file "::" searchstring) description))) + +;; Calling git +(defun org-git-show (gitdir object buffer) + "Show the output of git --git-dir=gitdir show object in buffer." + (unless + (zerop (call-process org-git-program nil buffer nil + "--no-pager" (concat "--git-dir=" gitdir) "show" object)) + (error "git error: %s " (save-excursion (set-buffer buffer) + (buffer-string))))) + +(defun org-git-blob-sha (gitdir object) + "Return sha of the referenced object" + (with-temp-buffer + (if (zerop (call-process org-git-program nil t nil + "--no-pager" (concat "--git-dir=" gitdir) "rev-parse" object)) + (buffer-substring (point-min) (1- (point-max))) ; to strip off final newline + (error "git error: %s " (buffer-string))))) + +(defun org-git-get-current-branch (gitdir) + "Return the name of the current branch." + (with-temp-buffer + (if (not (zerop (call-process org-git-program nil t nil + "--no-pager" (concat "--git-dir=" gitdir) "symbolic-ref" "-q" "HEAD"))) + (error "git error: %s " (buffer-string)) + (goto-char (point-min)) + (if (looking-at "^refs/heads/") ; 11 characters + (buffer-substring 12 (1- (point-max))))))) ; to strip off final newline + +(provide 'org-git-link) + +;;; org-git-link.el ends here diff --git a/contrib/lisp/org-interactive-query.el b/contrib/lisp/org-interactive-query.el new file mode 100644 index 0000000..ab6669b --- /dev/null +++ b/contrib/lisp/org-interactive-query.el @@ -0,0 +1,312 @@ +;;; org-interactive-query.el --- Interactive modification of agenda query +;; +;; Copyright 2007-2012 Free Software Foundation, Inc. +;; +;; Author: Christopher League +;; Version: 1.0 +;; Keywords: org, wp +;; +;; This file is not part of GNU Emacs. +;; +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, write to the Free Software +;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +;; +;;; Commentary: +;; + +;; This library implements interactive modification of a tags/todo query +;; in the org-agenda. It adds 4 keys to the agenda +;; +;; / add a keyword as a positive selection criterion +;; \ add a keyword as a newgative selection criterion +;; = clear a keyword from the selection string +;; ; + +(require 'org) + +(org-defkey org-agenda-mode-map "=" 'org-agenda-query-clear-cmd) +(org-defkey org-agenda-mode-map "/" 'org-agenda-query-and-cmd) +(org-defkey org-agenda-mode-map ";" 'org-agenda-query-or-cmd) +(org-defkey org-agenda-mode-map "\\" 'org-agenda-query-not-cmd) + +;;; Agenda interactive query manipulation + +(defcustom org-agenda-query-selection-single-key t + "Non-nil means query manipulation exits after first change. +When nil, you have to press RET to exit it. +During query selection, you can toggle this flag with `C-c'. +This variable can also have the value `expert'. In this case, the window +displaying the tags menu is not even shown, until you press C-c again." + :group 'org-agenda + :type '(choice + (const :tag "No" nil) + (const :tag "Yes" t) + (const :tag "Expert" expert))) + +(defun org-agenda-query-selection (current op table &optional todo-table) + "Fast query manipulation with single keys. +CURRENT is the current query string, OP is the initial +operator (one of \"+|-=\"), TABLE is an alist of tags and +corresponding keys, possibly with grouping information. +TODO-TABLE is a similar table with TODO keywords, should these +have keys assigned to them. If the keys are nil, a-z are +automatically assigned. Returns the new query string, or nil to +not change the current one." + (let* ((fulltable (append table todo-table)) + (maxlen (apply 'max (mapcar + (lambda (x) + (if (stringp (car x)) (string-width (car x)) 0)) + fulltable))) + (fwidth (+ maxlen 3 1 3)) + (ncol (/ (- (window-width) 4) fwidth)) + (expert (eq org-agenda-query-selection-single-key 'expert)) + (exit-after-next org-agenda-query-selection-single-key) + (done-keywords org-done-keywords) + tbl char cnt e groups ingroup + tg c2 c c1 ntable rtn) + (save-window-excursion + (if expert + (set-buffer (get-buffer-create " *Org tags*")) + (delete-other-windows) + (split-window-vertically) + (org-switch-to-buffer-other-window (get-buffer-create " *Org tags*"))) + (erase-buffer) + (org-set-local 'org-done-keywords done-keywords) + (insert "Query: " current "\n") + (org-agenda-query-op-line op) + (insert "\n\n") + (org-fast-tag-show-exit exit-after-next) + (setq tbl fulltable char ?a cnt 0) + (while (setq e (pop tbl)) + (cond + ((equal e '(:startgroup)) + (push '() groups) (setq ingroup t) + (when (not (= cnt 0)) + (setq cnt 0) + (insert "\n")) + (insert "{ ")) + ((equal e '(:endgroup)) + (setq ingroup nil cnt 0) + (insert "}\n")) + (t + (setq tg (car e) c2 nil) + (if (cdr e) + (setq c (cdr e)) + ;; automatically assign a character. + (setq c1 (string-to-char + (downcase (substring + tg (if (= (string-to-char tg) ?@) 1 0))))) + (if (or (rassoc c1 ntable) (rassoc c1 table)) + (while (or (rassoc char ntable) (rassoc char table)) + (setq char (1+ char))) + (setq c2 c1)) + (setq c (or c2 char))) + (if ingroup (push tg (car groups))) + (setq tg (org-add-props tg nil 'face + (cond + ((not (assoc tg table)) + (org-get-todo-face tg)) + (t nil)))) + (if (and (= cnt 0) (not ingroup)) (insert " ")) + (insert "[" c "] " tg (make-string + (- fwidth 4 (length tg)) ?\ )) + (push (cons tg c) ntable) + (when (= (setq cnt (1+ cnt)) ncol) + (insert "\n") + (if ingroup (insert " ")) + (setq cnt 0))))) + (setq ntable (nreverse ntable)) + (insert "\n") + (goto-char (point-min)) + (if (and (not expert) (fboundp 'fit-window-to-buffer)) + (fit-window-to-buffer)) + (setq rtn + (catch 'exit + (while t + (message "[a-z..]:Toggle [SPC]:clear [RET]:accept [TAB]:free%s%s" + (if groups " [!] no groups" " [!]groups") + (if expert " [C-c]:window" (if exit-after-next " [C-c]:single" " [C-c]:multi"))) + (setq c (let ((inhibit-quit t)) (read-char-exclusive))) + (cond + ((= c ?\r) (throw 'exit t)) + ((= c ?!) + (setq groups (not groups)) + (goto-char (point-min)) + (while (re-search-forward "[{}]" nil t) (replace-match " "))) + ((= c ?\C-c) + (if (not expert) + (org-fast-tag-show-exit + (setq exit-after-next (not exit-after-next))) + (setq expert nil) + (delete-other-windows) + (split-window-vertically) + (org-switch-to-buffer-other-window " *Org tags*") + (and (fboundp 'fit-window-to-buffer) + (fit-window-to-buffer)))) + ((or (= c ?\C-g) + (and (= c ?q) (not (rassoc c ntable)))) + (setq quit-flag t)) + ((= c ?\ ) + (setq current "") + (if exit-after-next (setq exit-after-next 'now))) + ((= c ?\[) ; clear left + (org-agenda-query-decompose current) + (setq current (concat "/" (match-string 2 current))) + (if exit-after-next (setq exit-after-next 'now))) + ((= c ?\]) ; clear right + (org-agenda-query-decompose current) + (setq current (match-string 1 current)) + (if exit-after-next (setq exit-after-next 'now))) + ((= c ?\t) + (condition-case nil + (setq current (read-string "Query: " current)) + (quit)) + (if exit-after-next (setq exit-after-next 'now))) + ;; operators + ((or (= c ?/) (= c ?+)) (setq op "+")) + ((or (= c ?\;) (= c ?|)) (setq op "|")) + ((or (= c ?\\) (= c ?-)) (setq op "-")) + ((= c ?=) (setq op "=")) + ;; todos + ((setq e (rassoc c todo-table) tg (car e)) + (setq current (org-agenda-query-manip + current op groups 'todo tg)) + (if exit-after-next (setq exit-after-next 'now))) + ;; tags + ((setq e (rassoc c ntable) tg (car e)) + (setq current (org-agenda-query-manip + current op groups 'tag tg)) + (if exit-after-next (setq exit-after-next 'now)))) + (if (eq exit-after-next 'now) (throw 'exit t)) + (goto-char (point-min)) + (beginning-of-line 1) + (delete-region (point) (point-at-eol)) + (insert "Query: " current) + (beginning-of-line 2) + (delete-region (point) (point-at-eol)) + (org-agenda-query-op-line op) + (goto-char (point-min))))) + (if rtn current nil)))) + +(defun org-agenda-query-op-line (op) + (insert "Operator: " + (org-agenda-query-op-entry (equal op "+") "/+" "and") + (org-agenda-query-op-entry (equal op "|") ";|" "or") + (org-agenda-query-op-entry (equal op "-") "\\-" "not") + (org-agenda-query-op-entry (equal op "=") "=" "clear"))) + +(defun org-agenda-query-op-entry (matchp chars str) + (if matchp + (org-add-props (format "[%s %s] " chars (upcase str)) + nil 'face 'org-todo) + (format "[%s]%s " chars str))) + +(defun org-agenda-query-decompose (current) + (string-match "\\([^/]*\\)/?\\(.*\\)" current)) + +(defun org-agenda-query-clear (current prefix tag) + (if (string-match (concat prefix "\\b" (regexp-quote tag) "\\b") current) + (replace-match "" t t current) + current)) + +(defun org-agenda-query-manip (current op groups kind tag) + "Apply an operator to a query string and a tag. +CURRENT is the current query string, OP is the operator, GROUPS is a +list of lists of tags that are mutually exclusive. KIND is 'tag for a +regular tag, or 'todo for a TODO keyword, and TAG is the tag or +keyword string." + ;; If this tag is already in query string, remove it. + (setq current (org-agenda-query-clear current "[-\\+&|]?" tag)) + (if (equal op "=") current + ;; When using AND, also remove mutually exclusive tags. + (if (equal op "+") + (loop for g in groups do + (if (member tag g) + (mapc (lambda (x) + (setq current + (org-agenda-query-clear current "\\+" x))) + g)))) + ;; Decompose current query into q1 (tags) and q2 (TODOs). + (org-agenda-query-decompose current) + (let* ((q1 (match-string 1 current)) + (q2 (match-string 2 current))) + (cond + ((eq kind 'tag) + (concat q1 op tag "/" q2)) + ;; It's a TODO; when using AND, drop all other TODOs. + ((equal op "+") + (concat q1 "/+" tag)) + (t + (concat q1 "/" q2 op tag)))))) + +(defun org-agenda-query-global-todo-keys (&optional files) + "Return alist of all TODO keywords and their fast keys, in all FILES." + (let (alist) + (unless (and files (car files)) + (setq files (org-agenda-files))) + (save-excursion + (loop for f in files do + (set-buffer (find-file-noselect f)) + (loop for k in org-todo-key-alist do + (setq alist (org-agenda-query-merge-todo-key + alist k))))) + alist)) + +(defun org-agenda-query-merge-todo-key (alist entry) + (let (e) + (cond + ;; if this is not a keyword (:startgroup, etc), ignore it + ((not (stringp (car entry)))) + ;; if keyword already exists, replace char if it's null + ((setq e (assoc (car entry) alist)) + (when (null (cdr e)) (setcdr e (cdr entry)))) + ;; if char already exists, prepend keyword but drop char + ((rassoc (cdr entry) alist) + (message "TRACE POSITION 2") + (setq alist (cons (cons (car entry) nil) alist))) + ;; else, prepend COPY of entry + (t + (setq alist (cons (cons (car entry) (cdr entry)) alist))))) + alist) + +(defun org-agenda-query-generic-cmd (op) + "Activate query manipulation with OP as initial operator." + (let ((q (org-agenda-query-selection org-agenda-query-string op + org-tag-alist + (org-agenda-query-global-todo-keys)))) + (when q + (setq org-agenda-query-string q) + (org-agenda-redo)))) + +(defun org-agenda-query-clear-cmd () + "Activate query manipulation, to clear a tag from the string." + (interactive) + (org-agenda-query-generic-cmd "=")) + +(defun org-agenda-query-and-cmd () + "Activate query manipulation, initially using the AND (+) operator." + (interactive) + (org-agenda-query-generic-cmd "+")) + +(defun org-agenda-query-or-cmd () + "Activate query manipulation, initially using the OR (|) operator." + (interactive) + (org-agenda-query-generic-cmd "|")) + +(defun org-agenda-query-not-cmd () + "Activate query manipulation, initially using the NOT (-) operator." + (interactive) + (org-agenda-query-generic-cmd "-")) + +(provide 'org-interactive-query) diff --git a/contrib/lisp/org-invoice.el b/contrib/lisp/org-invoice.el new file mode 100644 index 0000000..c951d4e --- /dev/null +++ b/contrib/lisp/org-invoice.el @@ -0,0 +1,401 @@ +;;; org-invoice.el --- Help manage client invoices in OrgMode +;; +;; Copyright (C) 2008-2012 pmade inc. (Peter Jones pjones@pmade.com) +;; +;; This file is not part of GNU Emacs. +;; +;; Permission is hereby granted, free of charge, to any person obtaining +;; a copy of this software and associated documentation files (the +;; "Software"), to deal in the Software without restriction, including +;; without limitation the rights to use, copy, modify, merge, publish, +;; distribute, sublicense, and/or sell copies of the Software, and to +;; permit persons to whom the Software is furnished to do so, subject to +;; the following conditions: +;; +;; The above copyright notice and this permission notice shall be +;; included in all copies or substantial portions of the Software. +;; +;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +;; +;; Commentary: +;; +;; Building on top of the terrific OrgMode, org-invoice tries to +;; provide functionality for managing invoices. Currently, it does +;; this by implementing an OrgMode dynamic block where invoice +;; information is aggregated so that it can be exported. +;; +;; It also provides a library of functions that can be used to collect +;; this invoice information and use it in other ways, such as +;; submitting it to on-line invoicing tools. +;; +;; I'm already working on an elisp package to submit this invoice data +;; to the FreshBooks on-line accounting tool. +;; +;; Usage: +;; +;; In your ~/.emacs: +;; (autoload 'org-invoice-report "org-invoice") +;; (autoload 'org-dblock-write:invoice "org-invoice") +;; +;; See the documentation in the following functions: +;; +;; `org-invoice-report' +;; `org-dblock-write:invoice' +;; +;; Latest version: +;; +;; git clone git://pmade.com/elisp +(eval-when-compile + (require 'cl) + (require 'org)) + +(defgroup org-invoice nil + "OrgMode Invoice Helper" + :tag "Org-Invoice" :group 'org) + +(defcustom org-invoice-long-date-format "%A, %B %d, %Y" + "The format string for long dates." + :type 'string :group 'org-invoice) + +(defcustom org-invoice-strip-ts t + "Remove org timestamps that appear in headings." + :type 'boolean :group 'org-invoice) + +(defcustom org-invoice-default-level 2 + "The heading level at which a new invoice starts. This value +is used if you don't specify a scope option to the invoice block, +and when other invoice helpers are trying to find the heading +that starts an invoice. + +The default is 2, assuming that you structure your invoices so +that they fall under a single heading like below: + +* Invoices +** This is invoice number 1... +** This is invoice number 2... + +If you don't structure your invoices using those conventions, +change this setting to the number that corresponds to the heading +at which an invoice begins." + :type 'integer :group 'org-invoice) + +(defcustom org-invoice-start-hook nil + "Hook called when org-invoice is about to collect data from an +invoice heading. When this hook is called, point will be on the +heading where the invoice begins. + +When called, `org-invoice-current-invoice' will be set to the +alist that represents the info for this invoice." + :type 'hook :group 'org-invoice) + + (defcustom org-invoice-heading-hook nil + "Hook called when org-invoice is collecting data from a +heading. You can use this hook to add additional information to +the alist that represents the heading. + +When this hook is called, point will be on the current heading +being processed, and `org-invoice-current-item' will contain the +alist for the current heading. + +This hook is called repeatedly for each invoice item processed." + :type 'hook :group 'org-invoice) + +(defvar org-invoice-current-invoice nil + "Information about the current invoice.") + +(defvar org-invoice-current-item nil + "Information about the current invoice item.") + +(defvar org-invoice-table-params nil + "The table parameters currently being used.") + +(defvar org-invoice-total-time nil + "The total invoice time for the summary line.") + +(defvar org-invoice-total-price nil + "The total invoice price for the summary line.") + +(defconst org-invoice-version "1.0.0" + "The org-invoice version number.") + +(defun org-invoice-goto-tree (&optional tree) + "Move point to the heading that represents the head of the +current invoice. The heading level will be taken from +`org-invoice-default-level' unless tree is set to a string that +looks like tree2, where the level is 2." + (let ((level org-invoice-default-level)) + (save-match-data + (when (and tree (string-match "^tree\\([0-9]+\\)$" tree)) + (setq level (string-to-number (match-string 1 tree))))) + (org-back-to-heading) + (while (and (> (org-reduced-level (org-outline-level)) level) + (org-up-heading-safe))))) + +(defun org-invoice-heading-info () + "Return invoice information from the current heading." + (let ((title (org-no-properties (org-get-heading t))) + (date (org-entry-get nil "TIMESTAMP" 'selective)) + (work (org-entry-get nil "WORK" nil)) + (rate (or (org-entry-get nil "RATE" t) "0")) + (level (org-outline-level)) + raw-date long-date) + (unless date (setq date (org-entry-get nil "TIMESTAMP_IA" 'selective))) + (unless date (setq date (org-entry-get nil "TIMESTAMP" t))) + (unless date (setq date (org-entry-get nil "TIMESTAMP_IA" t))) + (unless work (setq work (org-entry-get nil "CLOCKSUM" nil))) + (unless work (setq work "00:00")) + (when date + (setq raw-date (apply 'encode-time (org-parse-time-string date))) + (setq long-date (format-time-string org-invoice-long-date-format raw-date))) + (when (and org-invoice-strip-ts (string-match org-ts-regexp-both title)) + (setq title (replace-match "" nil nil title))) + (when (string-match "^[ \t]+" title) + (setq title (replace-match "" nil nil title))) + (when (string-match "[ \t]+$" title) + (setq title (replace-match "" nil nil title))) + (setq work (org-hh:mm-string-to-minutes work)) + (setq rate (string-to-number rate)) + (setq org-invoice-current-item (list (cons 'title title) + (cons 'date date) + (cons 'raw-date raw-date) + (cons 'long-date long-date) + (cons 'work work) + (cons 'rate rate) + (cons 'level level) + (cons 'price (* rate (/ work 60.0))))) + (run-hook-with-args 'org-invoice-heading-hook) + org-invoice-current-item)) + +(defun org-invoice-level-min-max (ls) + "Return a list where the car is the min level, and the cdr the max." + (let ((max 0) min level) + (dolist (info ls) + (when (cdr (assoc 'date info)) + (setq level (cdr (assoc 'level info))) + (when (or (not min) (< level min)) (setq min level)) + (when (> level max) (setq max level)))) + (cons (or min 0) max))) + +(defun org-invoice-collapse-list (ls) + "Reorganize the given list by dates." + (let ((min-max (org-invoice-level-min-max ls)) new) + (dolist (info ls) + (let* ((date (cdr (assoc 'date info))) + (work (cdr (assoc 'work info))) + (price (cdr (assoc 'price info))) + (long-date (cdr (assoc 'long-date info))) + (level (cdr (assoc 'level info))) + (bucket (cdr (assoc date new)))) + (if (and (/= (car min-max) (cdr min-max)) + (= (car min-max) level) + (= work 0) (not bucket) date) + (progn + (setq info (assq-delete-all 'work info)) + (push (cons 'total-work 0) info) + (push (cons date (list info)) new) + (setq bucket (cdr (assoc date new)))) + (when (and date (not bucket)) + (setq bucket (list (list (cons 'date date) + (cons 'title long-date) + (cons 'total-work 0) + (cons 'price 0)))) + (push (cons date bucket) new) + (setq bucket (cdr (assoc date new)))) + (when (and date bucket) + (setcdr (assoc 'total-work (car bucket)) + (+ work (cdr (assoc 'total-work (car bucket))))) + (setcdr (assoc 'price (car bucket)) + (+ price (cdr (assoc 'price (car bucket))))) + (nconc bucket (list info)))))) + (nreverse new))) + +(defun org-invoice-info-to-table (info) + "Create a single org table row from the given info alist." + (let ((title (cdr (assoc 'title info))) + (total (cdr (assoc 'total-work info))) + (work (cdr (assoc 'work info))) + (price (cdr (assoc 'price info))) + (with-price (plist-get org-invoice-table-params :price))) + (unless total + (setq + org-invoice-total-time (+ org-invoice-total-time work) + org-invoice-total-price (+ org-invoice-total-price price))) + (setq total (and total (org-minutes-to-hh:mm-string total))) + (setq work (and work (org-minutes-to-hh:mm-string work))) + (insert-before-markers + (concat "|" title + (cond + (total (concat "|" total)) + (work (concat "|" work))) + (and with-price price (concat "|" (format "%.2f" price))) + "|" "\n")))) + +(defun org-invoice-list-to-table (ls) + "Convert a list of heading info to an org table" + (let ((with-price (plist-get org-invoice-table-params :price)) + (with-summary (plist-get org-invoice-table-params :summary)) + (with-header (plist-get org-invoice-table-params :headers)) + (org-invoice-total-time 0) + (org-invoice-total-price 0)) + (insert-before-markers + (concat "| Task / Date | Time" (and with-price "| Price") "|\n")) + (dolist (info ls) + (insert-before-markers "|-\n") + (mapc 'org-invoice-info-to-table (if with-header (cdr info) (cdr (cdr info))))) + (when with-summary + (insert-before-markers + (concat "|-\n|Total:|" + (org-minutes-to-hh:mm-string org-invoice-total-time) + (and with-price (concat "|" (format "%.2f" org-invoice-total-price))) + "|\n"))))) + +(defun org-invoice-collect-invoice-data () + "Collect all the invoice data from the current OrgMode tree and +return it. Before you call this function, move point to the +heading that begins the invoice data, usually using the +`org-invoice-goto-tree' function." + (let ((org-invoice-current-invoice + (list (cons 'point (point)) (cons 'buffer (current-buffer)))) + (org-invoice-current-item nil)) + (save-restriction + (org-narrow-to-subtree) + (org-clock-sum) + (run-hook-with-args 'org-invoice-start-hook) + (cons org-invoice-current-invoice + (org-invoice-collapse-list + (org-map-entries 'org-invoice-heading-info t 'tree 'archive)))))) + +(defun org-dblock-write:invoice (params) + "Function called by OrgMode to write the invoice dblock. To +create an invoice dblock you can use the `org-invoice-report' +function. + +The following parameters can be given to the invoice block (for +information about dblock parameters, please see the Org manual): + +:scope Allows you to override the `org-invoice-default-level' + variable. The only supported values right now are ones + that look like :tree1, :tree2, etc. + +:prices Set to nil to turn off the price column. + +:headers Set to nil to turn off the group headers. + +:summary Set to nil to turn off the final summary line." + (let ((scope (plist-get params :scope)) + (org-invoice-table-params params) + (zone (move-marker (make-marker) (point))) + table) + (unless scope (setq scope 'default)) + (unless (plist-member params :price) (plist-put params :price t)) + (unless (plist-member params :summary) (plist-put params :summary t)) + (unless (plist-member params :headers) (plist-put params :headers t)) + (save-excursion + (cond + ((eq scope 'tree) (org-invoice-goto-tree "tree1")) + ((eq scope 'default) (org-invoice-goto-tree)) + ((symbolp scope) (org-invoice-goto-tree (symbol-name scope)))) + (setq table (org-invoice-collect-invoice-data)) + (goto-char zone) + (org-invoice-list-to-table (cdr table)) + (goto-char zone) + (org-table-align) + (move-marker zone nil)))) + +(defun org-invoice-in-report-p () + "Check to see if point is inside an invoice report." + (let ((pos (point)) start) + (save-excursion + (end-of-line 1) + (and (re-search-backward "^#\\+BEGIN:[ \t]+invoice" nil t) + (setq start (match-beginning 0)) + (re-search-forward "^#\\+END:.*" nil t) + (>= (match-end 0) pos) + start)))) + +(defun org-invoice-report (&optional jump) + "Create or update an invoice dblock report. If point is inside +an existing invoice report, the report is updated. If point +isn't inside an invoice report, a new report is created. + +When called with a prefix argument, move to the first invoice +report after point and update it. + +For information about various settings for the invoice report, +see the `org-dblock-write:invoice' function documentation. + +An invoice report is created by reading a heading tree and +collecting information from various properties. It is assumed +that all invoices start at a second level heading, but this can +be configured using the `org-invoice-default-level' variable. + +Here is an example, where all invoices fall under the first-level +heading Invoices: + +* Invoices +** Client Foo (Jan 01 - Jan 15) +*** [2008-01-01 Tue] Built New Server for Production +*** [2008-01-02 Wed] Meeting with Team to Design New System +** Client Bar (Jan 01 - Jan 15) +*** [2008-01-01 Tue] Searched for Widgets on Google +*** [2008-01-02 Wed] Billed You for Taking a Nap + +In this layout, invoices begin at level two, and invoice +items (tasks) are at level three. You'll notice that each level +three heading starts with an inactive timestamp. The timestamp +can actually go anywhere you want, either in the heading, or in +the text under the heading. But you must have a timestamp +somewhere so that the invoice report can group your items by +date. + +Properties are used to collect various bits of information for +the invoice. All properties can be set on the invoice item +headings, or anywhere in the tree. The invoice report will scan +up the tree looking for each of the properties. + +Properties used: + +CLOCKSUM: You can use the Org clock-in and clock-out commands to + create a CLOCKSUM property. Also see WORK. + +WORK: An alternative to the CLOCKSUM property. This property + should contain the amount of work that went into this + invoice item formatted as HH:MM (e.g. 01:30). + +RATE: Used to calculate the total price for an invoice item. + Should be the price per hour that you charge (e.g. 45.00). + It might make more sense to place this property higher in + the hierarchy than on the invoice item headings. + +Using this information, a report is generated that details the +items grouped by days. For each day you will be able to see the +total number of hours worked, the total price, and the items +worked on. + +You can place the invoice report anywhere in the tree you want. +I place mine under a third-level heading like so: + +* Invoices +** An Invoice Header +*** [2008-11-25 Tue] An Invoice Item +*** Invoice Report +#+BEGIN: invoice +#+END:" + (interactive "P") + (let ((report (org-invoice-in-report-p))) + (when (and (not report) jump) + (when (re-search-forward "^#\\+BEGIN:[ \t]+invoice" nil t) + (org-show-entry) + (beginning-of-line) + (setq report (point)))) + (if report (goto-char report) + (org-create-dblock (list :name "invoice"))) + (org-update-dblock))) + +(provide 'org-invoice) diff --git a/contrib/lisp/org-jira.el b/contrib/lisp/org-jira.el new file mode 100644 index 0000000..2037029 --- /dev/null +++ b/contrib/lisp/org-jira.el @@ -0,0 +1,65 @@ +;;; org-jira.el --- add a jira:ticket protocol to Org +(defconst org-jira-version "0.1") +;; Copyright (C) 2008-2012 Jonathan Arkell. +;; Author: Jonathan Arkell + +;; This file is not part of GNU Emacs. + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation version 2. + +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; For a copy of the GNU General Public License, search the Internet, +;; or write to the Free Software Foundation, Inc., 59 Temple Place, +;; Suite 330, Boston, MA 02111-1307 USA + +;;; Commentary: +;; This adds a jira protocol to org mode. + +;;; Commands: +;; +;; Below are complete command list: +;; +;; +;;; Customizable Options: +;; +;; Below are customizable option list: +;; + +;; I had initially planned on adding bi-directional linking, so you +;; could store links from a jira ticket. I also wanted to import +;; tickets assigned to you as a task. However, I am no longer working +;; with JIRA, so this is now abandonware. + +;;; Installation: +;; Put org-jira.el somewhere in your load-path. +;; (Use M-x show-variable RET load-path to see what your load path is.) +;; Add this to your emacs init file, preferably after you load org mode. +;(require 'org-jira) + +;;; TODO: +;; - bi-directional links +;; - deeper importing, like tasks...? + +;;; CHANGELOG: +;; v 0.2 - ran through checkdoc +;; - Abandoned. +;; v 0.1 - Initial release + +(require 'jira) + +(org-add-link-type "jira" 'org-jira-open) + +(defun org-jira-open (path) + "Open a Jira Link from PATH." + (jira-show-issue path)) + + +(provide 'org-jira) + +;;; org-jira.el ends here diff --git a/contrib/lisp/org-learn.el b/contrib/lisp/org-learn.el new file mode 100644 index 0000000..0d5752b --- /dev/null +++ b/contrib/lisp/org-learn.el @@ -0,0 +1,177 @@ +;;; org-learn.el --- Implements SuperMemo's incremental learning algorithm + +;; Copyright (C) 2009-2012 Free Software Foundation, Inc. + +;; Author: John Wiegley +;; Keywords: outlines, hypermedia, calendar, wp +;; Homepage: http://orgmode.org +;; Version: 6.32trans +;; +;; This file is not part of GNU Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: + +;; The file implements the learning algorithm described at +;; http://supermemo.com/english/ol/sm5.htm, which is a system for reading +;; material according to "spaced repetition". See +;; http://en.wikipedia.org/wiki/Spaced_repetition for more details. +;; +;; To use, turn on state logging and schedule some piece of information you +;; want to read. Then in the agenda buffer type + +(require 'org) +(eval-when-compile + (require 'cl)) + +(defgroup org-learn nil + "Options concerning the learning code in Org-mode." + :tag "Org Learn" + :group 'org-progress) + +(defcustom org-learn-always-reschedule nil + "If non-nil, always reschedule items, even if retention was \"perfect\"." + :type 'boolean + :group 'org-learn) + +(defcustom org-learn-fraction 0.5 + "Controls the rate at which EF is increased or decreased. +Must be a number between 0 and 1 (the greater it is the faster +the changes of the OF matrix)." + :type 'float + :group 'org-learn) + +(defun initial-optimal-factor (n ef) + (if (= 1 n) + 4 + ef)) + +(defun get-optimal-factor (n ef of-matrix) + (let ((factors (assoc n of-matrix))) + (or (and factors + (let ((ef-of (assoc ef (cdr factors)))) + (and ef-of (cdr ef-of)))) + (initial-optimal-factor n ef)))) + +(defun set-optimal-factor (n ef of-matrix of) + (let ((factors (assoc n of-matrix))) + (if factors + (let ((ef-of (assoc ef (cdr factors)))) + (if ef-of + (setcdr ef-of of) + (push (cons ef of) (cdr factors)))) + (push (cons n (list (cons ef of))) of-matrix))) + of-matrix) + +(defun inter-repetition-interval (n ef &optional of-matrix) + (let ((of (get-optimal-factor n ef of-matrix))) + (if (= 1 n) + of + (* of (inter-repetition-interval (1- n) ef of-matrix))))) + +(defun modify-e-factor (ef quality) + (if (< ef 1.3) + 1.3 + (+ ef (- 0.1 (* (- 5 quality) (+ 0.08 (* (- 5 quality) 0.02))))))) + +(defun modify-of (of q fraction) + (let ((temp (* of (+ 0.72 (* q 0.07))))) + (+ (* (- 1 fraction) of) (* fraction temp)))) + +(defun calculate-new-optimal-factor (interval-used quality used-of + old-of fraction) + "This implements the SM-5 learning algorithm in Lisp. +INTERVAL-USED is the last interval used for the item in question. +QUALITY is the quality of the repetition response. +USED-OF is the optimal factor used in calculation of the last +interval used for the item in question. +OLD-OF is the previous value of the OF entry corresponding to the +relevant repetition number and the E-Factor of the item. +FRACTION is a number belonging to the range (0,1) determining the +rate of modifications (the greater it is the faster the changes +of the OF matrix). + +Returns the newly calculated value of the considered entry of the +OF matrix." + (let (;; the value proposed for the modifier in case of q=5 + (mod5 (/ (1+ interval-used) interval-used)) + ;; the value proposed for the modifier in case of q=2 + (mod2 (/ (1- interval-used) interval-used)) + ;; the number determining how many times the OF value will + ;; increase or decrease + modifier) + (if (< mod5 1.05) + (setq mod5 1.05)) + (if (< mod2 0.75) + (setq mod5 0.75)) + (if (> quality 4) + (setq modifier (1+ (* (- mod5 1) (- quality 4)))) + (setq modifier (- 1 (* (/ (- 1 mod2) 2) (- 4 quality))))) + (if (< modifier 0.05) + (setq modifier 0.05)) + (setq new-of (* used-of modifier)) + (if (> quality 4) + (if (< new-of old-of) + (setq new-of old-of))) + (if (< quality 4) + (if (> new-of old-of) + (setq new-of old-of))) + (setq new-of (+ (* new-of fraction) (* old-of (- 1 fraction)))) + (if (< new-of 1.2) + (setq new-of 1.2) + new-of))) + +(defvar initial-repetition-state '(-1 1 2.5 nil)) + +(defun determine-next-interval (n ef quality of-matrix) + (assert (> n 0)) + (assert (and (>= quality 0) (<= quality 5))) + (if (< quality 3) + (list (inter-repetition-interval n ef) (1+ n) ef nil) + (let ((next-ef (modify-e-factor ef quality))) + (setq of-matrix + (set-optimal-factor n next-ef of-matrix + (modify-of (get-optimal-factor n ef of-matrix) + quality org-learn-fraction)) + ef next-ef) + ;; For a zero-based quality of 4 or 5, don't repeat + (if (and (>= quality 4) + (not org-learn-always-reschedule)) + (list 0 (1+ n) ef of-matrix) + (list (inter-repetition-interval n ef of-matrix) (1+ n) + ef of-matrix))))) + +(defun org-smart-reschedule (quality) + (interactive "nHow well did you remember the information (on a scale of 0-5)? ") + (let* ((learn-str (org-entry-get (point) "LEARN_DATA")) + (learn-data (or (and learn-str + (read learn-str)) + (copy-list initial-repetition-state))) + closed-dates) + (setq learn-data + (determine-next-interval (nth 1 learn-data) + (nth 2 learn-data) + quality + (nth 3 learn-data))) + (org-entry-put (point) "LEARN_DATA" (prin1-to-string learn-data)) + (if (= 0 (nth 0 learn-data)) + (org-schedule t) + (org-schedule nil (time-add (current-time) + (days-to-time (nth 0 learn-data))))))) + +(provide 'org-learn) + +;;; org-learn.el ends here diff --git a/contrib/lisp/org-mac-iCal.el b/contrib/lisp/org-mac-iCal.el new file mode 100644 index 0000000..0fdc95f --- /dev/null +++ b/contrib/lisp/org-mac-iCal.el @@ -0,0 +1,251 @@ +;;; org-mac-iCal.el --- Imports events from iCal.app to the Emacs diary + +;; Copyright (C) 2009-2012 Christopher Suckling + +;; Author: Christopher Suckling + +;; This file is Free Software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. + +;; It is distributed in the hope that it will be useful, but WITHOUT +;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY +;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public +;; License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;; Version: 0.1057.104 +;; Keywords: outlines, calendar + +;;; Commentary: +;; +;; This file provides the import of events from Mac OS X 10.5 iCal.app +;; into the Emacs diary (it is not compatible with OS X < 10.5). The +;; function org-mac-iCal will import events in all checked iCal.app +;; calendars for the date range org-mac-iCal-range months, centered +;; around the current date. +;; +;; CAVEAT: This function is destructive; it will overwrite the current +;; contents of the Emacs diary. +;; +;; Installation: add (require 'org-mac-iCal) to your .emacs. +;; +;; If you view Emacs diary entries in org-agenda, the following hook +;; will ensure that all-day events are not orphaned below TODO items +;; and that any supplementary fields to events (e.g. Location) are +;; grouped with their parent event +;; +;; (add-hook 'org-agenda-cleanup-fancy-diary-hook +;; (lambda () +;; (goto-char (point-min)) +;; (save-excursion +;; (while (re-search-forward "^[a-z]" nil t) +;; (goto-char (match-beginning 0)) +;; (insert "0:00-24:00 "))) +;; (while (re-search-forward "^ [a-z]" nil t) +;; (goto-char (match-beginning 0)) +;; (save-excursion +;; (re-search-backward "^[0-9]+:[0-9]+-[0-9]+:[0-9]+ " nil t)) +;; (insert (match-string 0))))) + +;;; Code: + +(defcustom org-mac-iCal-range 2 + "The range in months to import iCal.app entries into the Emacs +diary. The import is centered around today's date; thus a value +of 2 imports entries for one month before and one month after +today's date" + :group 'org-time + :type 'integer) + +(defun org-mac-iCal () + "Selects checked calendars in iCal.app and imports them into +the the Emacs diary" + (interactive) + + ;; kill diary buffers then empty diary files to avoid duplicates + (setq currentBuffer (buffer-name)) + (setq openBuffers (mapcar (function buffer-name) (buffer-list))) + (omi-kill-diary-buffer openBuffers) + (with-temp-buffer + (insert-file-contents diary-file) + (delete-region (point-min) (point-max)) + (write-region (point-min) (point-max) diary-file)) + + ;; determine available calendars + (setq caldav-folders (directory-files "~/Library/Calendars" 1 ".*caldav$")) + (setq caldav-calendars nil) + (mapc + (lambda (x) + (setq caldav-calendars (nconc caldav-calendars (directory-files x 1 ".*calendar$")))) + caldav-folders) + + (setq local-calendars nil) + (setq local-calendars (directory-files "~/Library/Calendars" 1 ".*calendar$")) + + (setq all-calendars (append caldav-calendars local-calendars)) + + ;; parse each calendar's Info.plist to see if calendar is checked in iCal + (setq all-calendars (delq 'nil (mapcar + (lambda (x) + (omi-checked x)) + all-calendars))) + + ;; for each calendar, concatenate individual events into a single ics file + (with-temp-buffer + (shell-command "sw_vers" (current-buffer)) + (when (re-search-backward "10\\.[567]" nil t) + (omi-concat-leopard-ics all-calendars))) + + ;; move all caldav ics files to the same place as local ics files + (mapc + (lambda (x) + (mapc + (lambda (y) + (rename-file (concat x "/" y); + (concat "~/Library/Calendars/" y))) + (directory-files x nil ".*ics$"))) + caldav-folders) + + ;; check calendar has contents and import + (setq import-calendars (directory-files "~/Library/Calendars" 1 ".*ics$")) + (mapc + (lambda (x) + (when (/= (nth 7 (file-attributes x 'string)) 0) + (omi-import-ics x))) + import-calendars) + + ;; tidy up intermediate files and buffers + (setq usedCalendarsBuffers (mapcar (function buffer-name) (buffer-list))) + (omi-kill-ics-buffer usedCalendarsBuffers) + (setq usedCalendarsFiles (directory-files "~/Library/Calendars" 1 ".*ics$")) + (omi-delete-ics-file usedCalendarsFiles) + + (org-pop-to-buffer-same-window currentBuffer)) + +(defun omi-concat-leopard-ics (list) + "Leopard stores each iCal.app event in a separate ics file. +Whilst useful for Spotlight indexing, this is less helpful for +icalendar-import-file. omi-concat-leopard-ics concatenates these +individual event files into a single ics file" + (mapc + (lambda (x) + (setq omi-leopard-events (directory-files (concat x "/Events") 1 ".*ics$")) + (with-temp-buffer + (mapc + (lambda (y) + (insert-file-contents (expand-file-name y))) + omi-leopard-events) + (write-region (point-min) (point-max) (concat (expand-file-name x) ".ics")))) + list)) + +(defun omi-import-ics (string) + "Imports an ics file into the Emacs diary. First tidies up the +ics file so that it is suitable for import and selects a sensible +date range so that Emacs calendar view doesn't grind to a halt" + (with-temp-buffer + (insert-file-contents string) + (goto-char (point-min)) + (while + (re-search-forward "^BEGIN:VCALENDAR$" nil t) + (setq startEntry (match-beginning 0)) + (re-search-forward "^END:VCALENDAR$" nil t) + (setq endEntry (match-end 0)) + (save-restriction + (narrow-to-region startEntry endEntry) + (goto-char (point-min)) + (re-search-forward "\\(^DTSTART;.*:\\)\\([0-9][0-9][0-9][0-9]\\)\\([0-9][0-9]\\)" nil t) + (if (or (eq (match-string 2) nil) (eq (match-string 3) nil)) + (progn + (setq yearEntry 1) + (setq monthEntry 1)) + (setq yearEntry (string-to-number (match-string 2))) + (setq monthEntry (string-to-number (match-string 3)))) + (setq year (string-to-number (format-time-string "%Y"))) + (setq month (string-to-number (format-time-string "%m"))) + (setq now (list month 1 year)) + (setq entryDate (list monthEntry 1 yearEntry)) + ;; Check to see if this is a repeating event + (goto-char (point-min)) + (setq isRepeating (re-search-forward "^RRULE:" nil t)) + ;; Delete if outside range and not repeating + (when (and + (not isRepeating) + (> (abs (- (calendar-absolute-from-gregorian now) + (calendar-absolute-from-gregorian entryDate))) + (* (/ org-mac-iCal-range 2) 30)) + (delete-region startEntry endEntry))) + (goto-char (point-max)))) + (while + (re-search-forward "^END:VEVENT$" nil t) + (delete-blank-lines)) + (goto-line 1) + (insert "BEGIN:VCALENDAR\n\n") + (goto-line 2) + (while + (re-search-forward "^BEGIN:VCALENDAR$" nil t) + (replace-match "\n")) + (goto-line 2) + (while + (re-search-forward "^END:VCALENDAR$" nil t) + (replace-match "\n")) + (insert "END:VCALENDAR") + (goto-line 1) + (delete-blank-lines) + (while + (re-search-forward "^END:VEVENT$" nil t) + (delete-blank-lines)) + (goto-line 1) + (while + (re-search-forward "^ORG.*" nil t) + (replace-match "\n")) + (goto-line 1) + (write-region (point-min) (point-max) string)) + + (icalendar-import-file string diary-file)) + +(defun omi-kill-diary-buffer (list) + (mapc + (lambda (x) + (if (string-match "^diary" x) + (kill-buffer x))) + list)) + +(defun omi-kill-ics-buffer (list) + (mapc + (lambda (x) + (if (string-match "ics$" x) + (kill-buffer x))) + list)) + +(defun omi-delete-ics-file (list) + (mapc + (lambda (x) + (delete-file x)) + list)) + +(defun omi-checked (directory) + "Parse Info.plist in iCal.app calendar folder and determine +whether Checked key is 1. If Checked key is not 1, remove +calendar from list of calendars for import" + (let* ((root (xml-parse-file (car (directory-files directory 1 "Info.plist")))) + (plist (car root)) + (dict (car (xml-get-children plist 'dict))) + (keys (cdr (xml-node-children dict))) + (keys (mapcar + (lambda (x) + (cond ((listp x) + x))) + keys)) + (keys (delq 'nil keys))) + (when (equal "1" (car (cddr (lax-plist-get keys '(key nil "Checked"))))) + directory))) + +(provide 'org-mac-iCal) + +;;; org-mac-iCal.el ends here diff --git a/contrib/lisp/org-mac-link-grabber.el b/contrib/lisp/org-mac-link-grabber.el new file mode 100644 index 0000000..b422bfb --- /dev/null +++ b/contrib/lisp/org-mac-link-grabber.el @@ -0,0 +1,467 @@ +;;; org-mac-link-grabber.el --- Grab links and url from various mac +;;; application and insert them as links into org-mode documents +;; +;; Copyright (c) 2010-2012 Free Software Foundation, Inc. +;; +;; Author: Anthony Lander +;; Version: 1.0.1 +;; Keywords: org, mac, hyperlink +;; +;; This file is not part of GNU Emacs. +;; +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, write to the Free Software +;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +;; +;;; Commentary: +;; +;; This code allows you to grab either the current selected items, or +;; the frontmost url in various mac appliations, and insert them as +;; hyperlinks into the current org-mode document at point. +;; +;; This code is heavily based on, and indeed requires, +;; org-mac-message.el written by John Weigley and Christopher +;; Suckling. +;; +;; Detailed comments for each application interface are inlined with +;; the code. Here is a brief overview of how the code interacts with +;; each application: +;; +;; Finder.app - grab links to the selected files in the frontmost window +;; Mail.app - grab links to the selected messages in the message list +;; AddressBook.app - Grab links to the selected addressbook Cards +;; Firefox.app - Grab the url of the frontmost tab in the frontmost window +;; Vimperator/Firefox.app - Grab the url of the frontmost tab in the frontmost window +;; Safari.app - Grab the url of the frontmost tab in the frontmost window +;; Google Chrome.app - Grab the url of the frontmost tab in the frontmost window +;; Together.app - Grab links to the selected items in the library list +;; +;; +;; Installation: +;; +;; add (require 'org-mac-link-grabber) to your .emacs, and optionally +;; bind a key to activate the link grabber menu, like this: +;; +;; (add-hook 'org-mode-hook (lambda () +;; (define-key org-mode-map (kbd "C-c g") 'omlg-grab-link))) +;; +;; +;; Usage: +;; +;; Type C-c g (or whatever key you defined, as above), or type M-x +;; omlg-grab-link RET to activate the link grabber. This will present +;; you with a menu to choose an application from which to grab a link +;; to insert at point. You may also type C-g to abort. +;; +;; Customizing: +;; +;; You may customize which applications appear in the grab menu by +;; customizing the group org-mac-link-grabber. Changes take effect +;; immediately. +;; +;; +;;; Code: + +(require 'org) +(require 'org-mac-message) + +(defgroup org-mac-link-grabber nil + "Options concerning grabbing links from external Mac +applications and inserting them in org documents" + :tag "Org Mac link grabber" + :group 'org-link) + +(defcustom org-mac-grab-Finder-app-p t + "Enable menu option [F]inder to grab links from the Finder" + :tag "Grab Finder.app links" + :group 'org-mac-link-grabber + :type 'boolean) + +(defcustom org-mac-grab-Mail-app-p t + "Enable menu option [m]ail to grab links from Mail.app" + :tag "Grab Mail.app links" + :group 'org-mac-link-grabber + :type 'boolean) + +(defcustom org-mac-grab-Addressbook-app-p t + "Enable menu option [a]ddressbook to grab links from AddressBook.app" + :tag "Grab AddressBook.app links" + :group 'org-mac-link-grabber + :type 'boolean) + +(defcustom org-mac-grab-Safari-app-p t + "Enable menu option [s]afari to grab links from Safari.app" + :tag "Grab Safari.app links" + :group 'org-mac-link-grabber + :type 'boolean) + +(defcustom org-mac-grab-Firefox-app-p t + "Enable menu option [f]irefox to grab links from Firefox.app" + :tag "Grab Firefox.app links" + :group 'org-mac-link-grabber + :type 'boolean) + +(defcustom org-mac-grab-Firefox+Vimperator-p nil + "Enable menu option [v]imperator to grab links from Firefox.app running the Vimperator plugin" + :tag "Grab Vimperator/Firefox.app links" + :group 'org-mac-link-grabber + :type 'boolean) + +(defcustom org-mac-grab-Chrome-app-p t + "Enable menu option [f]irefox to grab links from Google Chrome.app" + :tag "Grab Google Chrome.app links" + :group 'org-mac-link-grabber + :type 'boolean) + +(defcustom org-mac-grab-Together-app-p nil + "Enable menu option [t]ogether to grab links from Together.app" + :tag "Grab Together.app links" + :group 'org-mac-link-grabber + :type 'boolean) + + +(defun omlg-grab-link () + "Prompt the user for an application to grab a link from, then go grab the link, and insert it at point" + (interactive) + (let* ((descriptors `(("F" "inder" org-mac-finder-insert-selected ,org-mac-grab-Finder-app-p) + ("m" "ail" org-mac-message-insert-selected ,org-mac-grab-Mail-app-p) + ("a" "ddressbook" org-mac-addressbook-insert-selected ,org-mac-grab-Addressbook-app-p) + ("s" "afari" org-mac-safari-insert-frontmost-url ,org-mac-grab-Safari-app-p) + ("f" "irefox" org-mac-firefox-insert-frontmost-url ,org-mac-grab-Firefox-app-p) + ("v" "imperator" org-mac-vimperator-insert-frontmost-url ,org-mac-grab-Firefox+Vimperator-p) + ("c" "hrome" org-mac-chrome-insert-frontmost-url ,org-mac-grab-Chrome-app-p) + ("t" "ogether" org-mac-together-insert-selected ,org-mac-grab-Together-app-p))) + (menu-string (make-string 0 ?x)) + input) + + ;; Create the menu string for the keymap + (mapc '(lambda (descriptor) + (when (elt descriptor 3) + (setf menu-string (concat menu-string "[" (elt descriptor 0) "]" (elt descriptor 1) " ")))) + descriptors) + (setf (elt menu-string (- (length menu-string) 1)) ?:) + + ;; Prompt the user, and grab the link + (message menu-string) + (setq input (read-char-exclusive)) + (mapc '(lambda (descriptor) + (let ((key (elt (elt descriptor 0) 0)) + (active (elt descriptor 3)) + (grab-function (elt descriptor 2))) + (when (and active (eq input key)) + (call-interactively grab-function)))) + descriptors))) + +(defalias 'omgl-grab-link 'omlg-grab-link + "Renamed, and this alias will be obsolete next revision.") + +(defun org-mac-paste-applescript-links (as-link-list) + "Paste in a list of links from an applescript handler. The + links are of the form ::split::" + (let* ((link-list + (mapcar + (lambda (x) (if (string-match "\\`\"\\(.*\\)\"\\'" x) (setq x (match-string 1 x))) x) + (split-string as-link-list "[\r\n]+"))) + split-link URL description orglink orglink-insert rtn orglink-list) + (while link-list + (setq split-link (split-string (pop link-list) "::split::")) + (setq URL (car split-link)) + (setq description (cadr split-link)) + (when (not (string= URL "")) + (setq orglink (org-make-link-string URL description)) + (push orglink orglink-list))) + (setq rtn (mapconcat 'identity orglink-list "\n")) + (kill-new rtn) + rtn)) + + + +;; Handle links from Firefox.app +;; +;; This code allows you to grab the current active url from the main +;; Firefox.app window, and insert it as a link into an org-mode +;; document. Unfortunately, firefox does not expose an applescript +;; dictionary, so this is necessarily introduces some limitations. +;; +;; The applescript to grab the url from Firefox.app uses the System +;; Events application to give focus to the firefox application, select +;; the contents of the url bar, and copy it. It then uses the title of +;; the window as the text of the link. There is no way to grab links +;; from other open tabs, and further, if there is more than one window +;; open, it is not clear which one will be used (though emperically it +;; seems that it is always the last active window). + +(defun as-mac-firefox-get-frontmost-url () + (let ((result (do-applescript + (concat + "set oldClipboard to the clipboard\n" + "set frontmostApplication to path to frontmost application\n" + "tell application \"Firefox\"\n" + " activate\n" + " delay 0.15\n" + " tell application \"System Events\"\n" + " keystroke \"l\" using command down\n" + " keystroke \"c\" using command down\n" + " end tell\n" + " delay 0.15\n" + " set theUrl to the clipboard\n" + " set the clipboard to oldClipboard\n" + " set theResult to (get theUrl) & \"::split::\" & (get name of window 1)\n" + "end tell\n" + "activate application (frontmostApplication as text)\n" + "set links to {}\n" + "copy theResult to the end of links\n" + "return links as string\n")))) + (car (split-string result "[\r\n]+" t)))) + +(defun org-mac-firefox-get-frontmost-url () + (interactive) + (message "Applescript: Getting Firefox url...") + (let* ((url-and-title (as-mac-firefox-get-frontmost-url)) + (split-link (split-string url-and-title "::split::")) + (URL (car split-link)) + (description (cadr split-link)) + (org-link)) + (when (not (string= URL "")) + (setq org-link (org-make-link-string URL description))) + (kill-new org-link) + org-link)) + +(defun org-mac-firefox-insert-frontmost-url () + (interactive) + (insert (org-mac-firefox-get-frontmost-url))) + + +;; Handle links from Google Firefox.app running the Vimperator extension +;; Grab the frontmost url from Firefox+Vimperator. Same limitations are +;; Firefox + +(defun as-mac-vimperator-get-frontmost-url () + (let ((result (do-applescript + (concat + "set oldClipboard to the clipboard\n" + "set frontmostApplication to path to frontmost application\n" + "tell application \"Firefox\"\n" + " activate\n" + " delay 0.15\n" + " tell application \"System Events\"\n" + " keystroke \"y\"\n" + " end tell\n" + " delay 0.15\n" + " set theUrl to the clipboard\n" + " set the clipboard to oldClipboard\n" + " set theResult to (get theUrl) & \"::split::\" & (get name of window 1)\n" + "end tell\n" + "activate application (frontmostApplication as text)\n" + "set links to {}\n" + "copy theResult to the end of links\n" + "return links as string\n")))) + (replace-regexp-in-string "\s+-\s+Vimperator" "" (car (split-string result "[\r\n]+" t))))) + + +(defun org-mac-vimperator-get-frontmost-url () + (interactive) + (message "Applescript: Getting Vimperator url...") + (let* ((url-and-title (as-mac-vimperator-get-frontmost-url)) + (split-link (split-string url-and-title "::split::")) + (URL (car split-link)) + (description (cadr split-link)) + (org-link)) + (when (not (string= URL "")) + (setq org-link (org-make-link-string URL description))) + (kill-new org-link) + org-link)) + +(defun org-mac-vimperator-insert-frontmost-url () + (interactive) + (insert (org-mac-vimperator-get-frontmost-url))) + + +;; Handle links from Google Chrome.app +;; Grab the frontmost url from Google Chrome. Same limitations are +;; Firefox because Chrome doesn't publish an Applescript dictionary + +(defun as-mac-chrome-get-frontmost-url () + (let ((result (do-applescript + (concat + "set oldClipboard to the clipboard\n" + "set frontmostApplication to path to frontmost application\n" + "tell application \"Google Chrome\"\n" + " activate\n" + " delay 0.15\n" + " tell application \"System Events\"\n" + " keystroke \"l\" using command down\n" + " keystroke \"c\" using command down\n" + " end tell\n" + " delay 0.15\n" + " set theUrl to the clipboard\n" + " set the clipboard to oldClipboard\n" + " set theResult to (get theUrl) & \"::split::\" & (get name of window 1)\n" + "end tell\n" + "activate application (frontmostApplication as text)\n" + "set links to {}\n" + "copy theResult to the end of links\n" + "return links as string\n")))) + (car (split-string result "[\r\n]+" t)))) + +(defun org-mac-chrome-get-frontmost-url () + (interactive) + (message "Applescript: Getting Chrome url...") + (let* ((url-and-title (as-mac-chrome-get-frontmost-url)) + (split-link (split-string url-and-title "::split::")) + (URL (car split-link)) + (description (cadr split-link)) + (org-link)) + (when (not (string= URL "")) + (setq org-link (org-make-link-string URL description))) + (kill-new org-link) + org-link)) + +(defun org-mac-chrome-insert-frontmost-url () + (interactive) + (insert (org-mac-chrome-get-frontmost-url))) + + +;; Handle links from Safari.app +;; Grab the frontmost url from Safari. + +(defun as-mac-safari-get-frontmost-url () + (let ((result (do-applescript + (concat + "tell application \"Safari\"\n" + " set theUrl to URL of document 1\n" + " set theName to the name of the document 1\n" + " return theUrl & \"::split::\" & theName & \"\n\"\n" + "end tell\n")))) + (car (split-string result "[\r\n]+" t)))) + +(defun org-mac-safari-get-frontmost-url () + (interactive) + (message "Applescript: Getting Safari url...") + (let* ((url-and-title (as-mac-safari-get-frontmost-url)) + (split-link (split-string url-and-title "::split::")) + (URL (car split-link)) + (description (cadr split-link)) + (org-link)) + (when (not (string= URL "")) + (setq org-link (org-make-link-string URL description))) + (kill-new org-link) + org-link)) + +(defun org-mac-safari-insert-frontmost-url () + (interactive) + (insert (org-mac-safari-get-frontmost-url))) + + +;; +;; +;; Handle links from together.app +;; +;; + +(org-add-link-type "x-together-item" 'org-mac-together-item-open) + +(defun org-mac-together-item-open (uid) + "Open the given uid, which is a reference to an item in Together" + (shell-command (concat "open -a Together \"x-together-item:" uid "\""))) + +(defun as-get-selected-together-items () + (do-applescript + (concat + "tell application \"Together\"\n" + " set theLinkList to {}\n" + " set theSelection to selected items\n" + " repeat with theItem in theSelection\n" + " set theLink to (get item link of theItem) & \"::split::\" & (get name of theItem) & \"\n\"\n" + " copy theLink to end of theLinkList\n" + " end repeat\n" + " return theLinkList as string\n" + "end tell"))) + +(defun org-mac-together-get-selected () + (interactive) + (message "Applescript: Getting Togther items...") + (org-mac-paste-applescript-links (as-get-selected-together-items))) + +(defun org-mac-together-insert-selected () + (interactive) + (insert (org-mac-together-get-selected))) + + +;; +;; +;; Handle links from Finder.app +;; +;; + +(defun as-get-selected-finder-items () + (do-applescript +(concat +"tell application \"Finder\"\n" +" set theSelection to the selection\n" +" set links to {}\n" +" repeat with theItem in theSelection\n" +" set theLink to \"file://\" & (POSIX path of (theItem as string)) & \"::split::\" & (get the name of theItem) & \"\n\"\n" +" copy theLink to the end of links\n" +" end repeat\n" +" return links as string\n" +"end tell\n"))) + +(defun org-mac-finder-item-get-selected () + (interactive) + (message "Applescript: Getting Finder items...") + (org-mac-paste-applescript-links (as-get-selected-finder-items))) + +(defun org-mac-finder-insert-selected () + (interactive) + (insert (org-mac-finder-item-get-selected))) + + +;; +;; +;; Handle links from AddressBook.app +;; +;; + +(org-add-link-type "addressbook" 'org-mac-addressbook-item-open) + +(defun org-mac-addressbook-item-open (uid) + "Open the given uid, which is a reference to an item in Together" + (shell-command (concat "open \"addressbook:" uid "\""))) + +(defun as-get-selected-addressbook-items () + (do-applescript + (concat + "tell application \"Address Book\"\n" + " set theSelection to the selection\n" + " set links to {}\n" + " repeat with theItem in theSelection\n" + " set theLink to \"addressbook://\" & (the id of theItem) & \"::split::\" & (the name of theItem) & \"\n\"\n" + " copy theLink to the end of links\n" + " end repeat\n" + " return links as string\n" + "end tell\n"))) + +(defun org-mac-addressbook-item-get-selected () + (interactive) + (message "Applescript: Getting Address Book items...") + (org-mac-paste-applescript-links (as-get-selected-addressbook-items))) + +(defun org-mac-addressbook-insert-selected () + (interactive) + (insert (org-mac-addressbook-item-get-selected))) + + +(provide 'org-mac-link-grabber) + +;;; org-mac-link-grabber.el ends here diff --git a/contrib/lisp/org-mairix.el b/contrib/lisp/org-mairix.el new file mode 100644 index 0000000..367a866 --- /dev/null +++ b/contrib/lisp/org-mairix.el @@ -0,0 +1,332 @@ +;;; org-mairix.el - Support for hooking mairix search into Org for different MUAs +;; +;; Copyright (C) 2007-2012 Georg C. F. Greve +;; mutt support by Adam Spiers +;; +;; Author: Georg C. F. Greve +;; Keywords: outlines, hypermedia, calendar, wp, email, mairix +;; Purpose: Integrate mairix email searching into Org mode +;; See http://orgmode.org and http://www.rpcurnow.force9.co.uk/mairix/ +;; Version: 0.5 +;; +;; This file is Free Software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. + +;; It is distributed in the hope that it will be useful, but WITHOUT +;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY +;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public +;; License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; USAGE NOTE +;; +;; You will need to configure mairix first, which involves setting up your +;; .mairixrc in your home directory. Once it is working, you should set up +;; your way to display results in your favorite way -- usually a MUA. +;; Currently gnus and mutt are supported. +;; +;; After both steps are done, all you should need to hook mairix, org +;; and your MUA together is to do (require 'org-mairix) in your +;; startup file. Everything can then be configured normally through +;; Emacs customisation. +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(require 'org) + +;;; The custom variables + +(defgroup org-mairix nil + "Mairix support/integration in org." + :tag "Org Mairix" + :group 'org) + +(defcustom org-mairix-threaded-links t + "Should new links be created as threaded links? +If t, links will be stored as threaded searches. +If nil, links will be stored as non-threaded searches." + :group 'org-mairix + :type 'boolean) + +(defcustom org-mairix-augmented-links nil + "Should new links be created as augmenting searches? +If t, links will be stored as augmenting searches. +If nil, links will be stored as normal searches. + +Attention: When activating this option, you will need +to remove old articles from your mairix results group +in some other way, mairix will not do it for you." + :group 'org-mairix + :type 'boolean) + +(defcustom org-mairix-display-hook 'org-mairix-gnus-display-results + "Hook to call to display the results of a successful mairix search. +Defaults to Gnus, feel free to add your own MUAs or methods." + :group 'org-mairix + :type 'hook) + +(defcustom org-mairix-open-command "mairix %args% '%search%'" + "The mairix command-line to use. If your paths are set up +correctly, you should not need to change this. + +'%search%' will get substituted with the search expression, and +'%args%' with any additional arguments." + :group 'org-mairix + :type 'string) + +;;; The hooks to integrate mairix into org + +(org-add-link-type "mairix" 'org-mairix-open) +(add-hook 'org-store-link-functions 'org-mairix-store-gnus-link) + +;;; Generic org-mairix functions + +(defun org-mairix-construct-link (message-id) + "Construct a mairix: hyperlink based on message-id." + (concat "mairix:" + (if org-mairix-threaded-links "t:") + (if org-mairix-augmented-links "a:") + "@@" + (org-remove-angle-brackets message-id))) + +(defun org-store-mairix-link-props (&rest plist) + "Take a property list describing a mail, and add mairix link +and description properties so that org can build a mairix link to +it." + ;; We have to call `org-store-link-props' twice: + ;; + ;; - It extracts 'fromname'/'fromaddress' from 'from' property, + ;; and stores the updated plist to `org-store-link-plist'. + ;; + ;; - `org-email-link-description' uses these new properties to + ;; build a description from the previously stored plist. I + ;; wrote a tiny patch to `org-email-link-description' so it + ;; could take a non-stored plist as an optional 2nd argument, + ;; but the plist provided still needs 'fromname'/'fromaddress'. + ;; + ;; - Ideally we would decouple the storing bit of + ;; `org-store-link-props' from the extraction bit, but lots of + ;; stuff in `org-store-link' which calls it would need to be + ;; changed. Maybe just factor out the extraction so it can be + ;; reused separately? + (let ((mid (plist-get plist :message-id))) + (apply 'org-store-link-props + (append plist + (list :type "mairix" + :link (org-mairix-construct-link mid)))) + (apply 'org-store-link-props + (append org-store-link-plist + (list :description (org-email-link-description)))))) + +(defun org-mairix-message-send-and-exit-with-link () + "Function that can be assigned as an alternative sending function, +it sends the message and then stores a mairix link to it before burying +the buffer just like 'message-send-and-exit' does." + (interactive) + (message-send) + (let* ((message-id (message-fetch-field "Message-Id")) + (subject (message-fetch-field "Subject")) + (link (org-mairix-construct-link message-id)) + (desc (concat "Email: '" subject "'"))) + (setq org-stored-links + (cons (list link desc) org-stored-links))) + (message-bury (current-buffer))) + +(defun org-mairix-open (search) + "Function to open mairix link. + +We first need to split it into its individual parts, and then +extract the message-id to be passed on to the display function +before call mairix, evaluate the number of matches returned, and +make sure to only call display of mairix succeeded in matching." + (let* ((args "")) + (if (equal (substring search 0 2) "t:" ) + (progn (setq search (substring search 2 nil)) + (setq args (concat args " --threads")))) + (if (equal (substring search 0 2) "a:") + (progn (setq search (substring search 2 nil)) + (setq args (concat args " --augment")))) + (let ((cmdline (org-mairix-command-substitution + org-mairix-open-command search args))) + (print cmdline) + (setq retval (shell-command-to-string cmdline)) + (string-match "\[0-9\]+" retval) + (setq matches (string-to-number (match-string 0 retval))) + (if (eq matches 0) (message "Link failed: no matches, sorry") + (message "Link returned %d matches" matches) + (run-hook-with-args 'org-mairix-display-hook search args))))) + +(defun org-mairix-command-substitution (cmd search args) + "Substitute '%search%' and '%args% in mairix search command." + (while (string-match "%search%" cmd) + (setq cmd (replace-match search 'fixedcase 'literal cmd))) + (while (string-match "%args%" cmd) + (setq cmd (replace-match args 'fixedcase 'literal cmd))) + cmd) + +;;; Functions necessary for integration of external MUAs. + +;; Of course we cannot call `org-store-link' from within an external +;; MUA, so we need some other way of storing a link for later +;; retrieval by org-mode and/or remember-mode. To do this we use a +;; temporary file as a kind of dedicated clipboard. + +(defcustom org-mairix-link-clipboard "~/.org-mairix-link" + "Pseudo-clipboard file where mairix URLs get copied to by external +applications in order to mimic `org-store-link'. Used by +`org-mairix-insert-link'." + :group 'org-mairix + :type 'string) + +;; When we resolve some of the issues with `org-store-link' detailed +;; at , +;; we might not need org-mairix-insert-link. + +(defun org-mairix-insert-link () + "Insert link from file defined by `org-mairix-link-clipboard'." + (interactive) + (let ((bytes (cadr (insert-file-contents + (expand-file-name org-mairix-link-clipboard))))) + (forward-char bytes) + (save-excursion + (forward-char -1) + (if (looking-at "\n") + (delete-char 1))))) + +;;; Functions necessary for mutt integration + +(defgroup org-mairix-mutt nil + "Use mutt for mairix support in org." + :tag "Org Mairix Mutt" + :group 'org-mairix) + +(defcustom org-mairix-mutt-display-command + "xterm -title 'mairix search: %search%' -e 'unset COLUMNS; mutt -f +~/mail/mairix -e \"push \"' &" + "Command to execute to display mairix search results via mutt within +an xterm. + +'%search%' will get substituted with the search expression, and +'%args%' with any additional arguments used in the search." + :group 'org-mairix-mutt + :type 'string) + +(defun org-mairix-mutt-display-results (search args) + "Display results of mairix search in mutt, using the command line +defined in `org-mairix-mutt-display-command'." + ;; By default, async `shell-command' invocations display the temp + ;; buffer, which is annoying here. We choose a deterministic + ;; buffer name so we can hide it again immediately. + ;; Note: `call-process' is synchronous so not useful here. + (let ((cmd (org-mairix-command-substitution + org-mairix-mutt-display-command search args)) + (tmpbufname (generate-new-buffer-name " *mairix-view*"))) + (shell-command cmd tmpbufname) + (delete-windows-on (get-buffer tmpbufname)))) + +;;; Functions necessary for gnus integration + +(defgroup org-mairix-gnus nil + "Use gnus for mairix support in org." + :tag "Org Mairix Gnus" + :group 'org-mairix) + +(defcustom org-mairix-gnus-results-group "nnmaildir:mairix" + "The group that is configured to hold the mairix search results, +which needs to be setup independently of the org-mairix integration, +along with general mairix configuration." + :group 'org-mairix-gnus + :type 'string) + +(defcustom org-mairix-gnus-select-display-group-function +'org-mairix-gnus-select-display-group-function-gg + "Hook to call to select the group that contains the matching articles. +We should not need this, it is owed to a problem of gnus that people were +not yet able to figure out, see + http://article.gmane.org/gmane.emacs.gnus.general/65248 + http://article.gmane.org/gmane.emacs.gnus.general/65265 + http://article.gmane.org/gmane.emacs.gnus.user/9596 +for reference. + +It seems gnus needs a 'forget/ignore everything you think you +know about that group' function. Volunteers?" + :group 'org-mairix-gnus + :type 'hook) + +(defun org-mairix-store-gnus-link () + "Store a link to the current gnus message as a Mairix search for its +Message ID." + + ;; gnus integration + (when (memq major-mode '(gnus-summary-mode gnus-article-mode)) + (and (eq major-mode 'gnus-article-mode) (gnus-article-show-summary)) + (let* ((article (gnus-summary-article-number)) + (header (gnus-summary-article-header article)) + (from (mail-header-from header)) + (message-id (mail-header-id header)) + (subject (gnus-summary-subject-string))) + (org-store-mairix-link-props :from from + :subject subject + :message-id message-id)))) + +(defun org-mairix-gnus-display-results (search args) + "Display results of mairix search in Gnus. + +Note: This does not work as cleanly as I would like it to. The +problem being that Gnus should simply reread the group cleanly, +without remembering anything. At the moment it seems to be unable +to do that -- so you're likely to see zombies floating around. + +If you can improve this, please do!" + (if (not (equal (substring search 0 2) "m:" )) + (error "org-mairix-gnus-display-results: display of search other than +message-id not implemented yet")) + (setq message-id (substring search 2 nil)) + (require 'gnus) + (require 'gnus-sum) + ;; FIXME: (bzg/gg) We might need to make sure gnus is running here, + ;; and to start it in case it isn't running already. Does + ;; anyone know a function to do that? It seems main org mode + ;; does not do this, either. + (funcall (cdr (assq 'gnus org-link-frame-setup))) + (if gnus-other-frame-object (select-frame gnus-other-frame-object)) + + ;; FIXME: This is horribly broken. Please see + ;; http://article.gmane.org/gmane.emacs.gnus.general/65248 + ;; http://article.gmane.org/gmane.emacs.gnus.general/65265 + ;; http://article.gmane.org/gmane.emacs.gnus.user/9596 + ;; for reference. + ;; + ;; It seems gnus needs a "forget/ignore everything you think you + ;; know about that group" function. Volunteers? + ;; + ;; For now different methods seem to work differently well for + ;; different people. So we're playing hook-selection here to make + ;; it easy to play around until we found a proper solution. + (run-hook-with-args 'org-mairix-gnus-select-display-group-function) + (gnus-summary-select-article + nil t t (car (gnus-find-matching-articles "message-id" message-id)))) + +(defun org-mairix-gnus-select-display-group-function-gg () + "Georg's hack to select a group that gnus (falsely) believes to be +empty to then call rebuilding of the summary. It leaves zombies of +old searches around, though." + (gnus-group-quick-select-group 0 org-mairix-gnus-results-group) + (gnus-group-clear-data) + (gnus-summary-reselect-current-group t t)) + +(defun org-mairix-gnus-select-display-group-function-bzg () + "This is the classic way the org mode is using, and it seems to be +using better for Bastien, so it may work for you." + (gnus-group-clear-data org-mairix-gnus-results-group) + (gnus-group-read-group t nil org-mairix-gnus-results-group)) + +(provide 'org-mairix) + +;;; org-mairix.el ends here diff --git a/contrib/lisp/org-man.el b/contrib/lisp/org-man.el new file mode 100644 index 0000000..27e8cca --- /dev/null +++ b/contrib/lisp/org-man.el @@ -0,0 +1,64 @@ +;;; org-man.el - Support for links to manpages in Org-mode +;; +;; Author: Carsten Dominik +;; Keywords: outlines, hypermedia, calendar, wp +;; Homepage: http://orgmode.org +;; Version: 1.0 +;; +;; This file is not yet part of GNU Emacs. +;; +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: + +(require 'org) + +(org-add-link-type "man" 'org-man-open) +(add-hook 'org-store-link-functions 'org-man-store-link) + +(defcustom org-man-command 'man + "The Emacs command to be used to display a man page." + :group 'org-link + :type '(choice (const man) (const woman))) + +(defun org-man-open (path) + "Visit the manpage on PATH. +PATH should be a topic that can be thrown at the man command." + (funcall org-man-command path)) + +(defun org-man-store-link () + "Store a link to a README file." + (when (memq major-mode '(Man-mode woman-mode)) + ;; This is a man page, we do make this link + (let* ((page (org-man-get-page-name)) + (link (concat "man:" page)) + (description (format "Manpage for %s" page))) + (org-store-link-props + :type "man" + :link link + :description description)))) + +(defun org-man-get-page-name () + "Extract the page name from the buffer name." + ;; This works for both `Man-mode' and `woman-mode'. + (if (string-match " \\(\\S-+\\)\\*" (buffer-name)) + (match-string 1 (buffer-name)) + (error "Cannot create link to this man page"))) + +(provide 'org-man) + +;;; org-man.el ends here diff --git a/contrib/lisp/org-md.el b/contrib/lisp/org-md.el new file mode 100644 index 0000000..4579ca3 --- /dev/null +++ b/contrib/lisp/org-md.el @@ -0,0 +1,461 @@ +;;; org-md.el --- Markdown Back-End for Org Export Engine + +;; Copyright (C) 2012 Free Software Foundation, Inc. + +;; Author: Nicolas Goaziou +;; Keywords: org, wp, tex + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; This library implements a Markdown back-end (vanilla flavour) for +;; Org exporter, based on `e-html'. +;; +;; It provides two commands for export, depending on the desired +;; output: `org-md-export-as-markdown' (temporary buffer) and +;; `org-md-export-to-markdown' ("md" file). + +;;; Code: + +(require 'org-e-html) + + + +;;; User-Configurable Variables + +(defgroup org-export-md nil + "Options specific to Markdown export back-end." + :tag "Org Markdown" + :group 'org-export + :version "24.2") + +(defcustom org-md-headline-style 'atx + "Style used to format headlines. +This variable can be set to either `atx' or `setext'." + :group 'org-export-md + :type '(choice + (const :tag "Use \"atx\" style" atx) + (const :tag "Use \"Setext\" style" setext))) + + + +;;; Define Back-End + +(org-export-define-derived-backend md e-html + :export-block ("MD" "MARKDOWN") + :filters-alist ((:filter-parse-tree . org-md-separate-elements)) + :translate-alist ((bold . org-md-bold) + (code . org-md-verbatim) + (example-block . org-md-example-block) + (footnote-definition . ignore) + (footnote-reference . ignore) + (headline . org-md-headline) + (horizontal-rule . org-md-horizontal-rule) + (inline-src-block . org-md-verbatim) + (italic . org-md-italic) + (item . org-md-item) + (line-break . org-md-line-break) + (link . org-md-link) + (paragraph . org-md-paragraph) + (plain-list . org-md-plain-list) + (plain-text . org-md-plain-text) + (quote-block . org-md-quote-block) + (quote-section . org-md-example-block) + (section . org-md-section) + (src-block . org-md-example-block) + (template . org-md-template) + (verbatim . org-md-verbatim))) + + + +;;; Filters + +(defun org-md-separate-elements (tree backend info) + "Make sure elements are separated by at least one blank line. + +TREE is the parse tree being exported. BACKEND is the export +back-end used. INFO is a plist used as a communication channel. + +Assume BACKEND is `md'." + (org-element-map + tree org-element-all-elements + (lambda (elem) + (unless (eq (org-element-type elem) 'org-data) + (org-element-put-property + elem :post-blank + (let ((post-blank (org-element-property :post-blank elem))) + (if (not post-blank) 1 (max 1 post-blank))))))) + ;; Return updated tree. + tree) + + + +;;; Transcode Functions + +;;;; Bold + +(defun org-md-bold (bold contents info) + "Transcode BOLD object into Markdown format. +CONTENTS is the text within bold markup. INFO is a plist used as +a communication channel." + (format "**%s**" contents)) + + +;;;; Code and Verbatim + +(defun org-md-verbatim (verbatim contents info) + "Transcode VERBATIM object into Markdown format. +CONTENTS is nil. INFO is a plist used as a communication +channel." + (let ((value (org-element-property :value verbatim))) + (format (cond ((not (string-match "`" value)) "`%s`") + ((or (string-match "\\``" value) + (string-match "`\\'" value)) + "`` %s ``") + (t "``%s``")) + value))) + + +;;;; Example Block and Src Block + +(defun org-md-example-block (example-block contents info) + "Transcode EXAMPLE-BLOCK element into Markdown format. +CONTENTS is nil. INFO is a plist used as a communication +channel." + (replace-regexp-in-string + "^" " " + (org-remove-indentation + (org-element-property :value example-block)))) + + +;;;; Headline + +(defun org-md-headline (headline contents info) + "Transcode HEADLINE element into Markdown format. +CONTENTS is the headline contents. INFO is a plist used as +a communication channel." + (unless (org-element-property :footnote-section-p headline) + (let* ((level (org-export-get-relative-level headline info)) + (title (org-export-data (org-element-property :title headline) info)) + (todo (and (plist-get info :with-todo-keywords) + (let ((todo (org-element-property :todo-keyword + headline))) + (and todo (concat (org-export-data todo info) " "))))) + (tags (and (plist-get info :with-tags) + (let ((tag-list (org-export-get-tags headline info))) + (and tag-list + (format " :%s:" + (mapconcat 'identity tag-list ":")))))) + (priority + (and (plist-get info :with-priority) + (let ((char (org-element-property :priority headline))) + (and char (format "[#%c] " char))))) + ;; Headline text without tags. + (heading (concat todo priority title))) + (cond + ;; Cannot create an headline. Fall-back to a list. + ((or (org-export-low-level-p headline info) + (not (memq org-md-headline-style '(atx setext))) + (and (eq org-md-headline-style 'atx) (> level 6)) + (and (eq org-md-headline-style 'setext) (> level 2))) + (let ((bullet + (if (not (org-export-numbered-headline-p headline info)) "-" + (concat (number-to-string + (car (last (org-export-get-headline-number + headline info)))) + ".")))) + (concat bullet (make-string (- 4 (length bullet)) ? ) heading tags + "\n\n" + (and contents + (replace-regexp-in-string "^" " " contents))))) + ;; Use "Setext" style. + ((eq org-md-headline-style 'setext) + (concat heading tags "\n" + (make-string (length heading) (if (= level 1) ?= ?-)) + "\n\n" + contents)) + ;; Use "atx" style. + (t (concat (make-string level ?#) " " heading tags "\n\n" contents)))))) + + +;;;; Horizontal Rule + +(defun org-md-horizontal-rule (horizontal-rule contents info) + "Transcode HORIZONTAL-RULE element into Markdown format. +CONTENTS is the horizontal rule contents. INFO is a plist used +as a communication channel." + "---") + + +;;;; Italic + +(defun org-md-italic (italic contents info) + "Transcode ITALIC object into Markdown format. +CONTENTS is the text within italic markup. INFO is a plist used +as a communication channel." + (format "*%s*" contents)) + + +;;;; Item + +(defun org-md-item (item contents info) + "Transcode ITEM element into Markdown format. +CONTENTS is the item contents. INFO is a plist used as +a communication channel." + (let* ((type (org-element-property :type (org-export-get-parent item))) + (struct (org-element-property :structure item)) + (bullet (if (not (eq type 'ordered)) "-" + (concat (number-to-string + (car (last (org-list-get-item-number + (org-element-property :begin item) + struct + (org-list-prevs-alist struct) + (org-list-parents-alist struct))))) + ".")))) + (concat bullet + (make-string (- 4 (length bullet)) ? ) + (case (org-element-property :checkbox item) + (on "[X] ") + (trans "[-] ") + (off "[ ] ")) + (let ((tag (org-element-property :tag item))) + (and tag (format "**%s:** "(org-export-data tag info)))) + (org-trim (replace-regexp-in-string "^" " " contents))))) + + +;;;; Line Break + +(defun org-md-line-break (line-break contents info) + "Transcode LINE-BREAK object into Markdown format. +CONTENTS is nil. INFO is a plist used as a communication +channel." + " ") + + +;;;; Link + +(defun org-md-link (link contents info) + "Transcode LINE-BREAK object into Markdown format. +CONTENTS is the link's description. INFO is a plist used as +a communication channel." + (let ((--link-org-files-as-html-maybe + (function + (lambda (raw-path info) + ;; Treat links to `file.org' as links to `file.html', if + ;; needed. See `org-e-html-link-org-files-as-html'. + (cond + ((and org-e-html-link-org-files-as-html + (string= ".org" + (downcase (file-name-extension raw-path ".")))) + (concat (file-name-sans-extension raw-path) "." + (plist-get info :html-extension))) + (t raw-path))))) + (type (org-element-property :type link))) + (cond ((member type '("custom-id" "id")) + (let ((destination (org-export-resolve-id-link link info))) + (if (stringp destination) ; External file. + (let ((path (funcall --link-org-files-as-html-maybe + destination info))) + (if (not contents) (format "<%s>" path) + (format "[%s](%s)" contents path))) + (concat + (and contents (concat contents " ")) + (format "(%s)" + (format (org-export-translate "See section %s" :html info) + (mapconcat 'number-to-string + (org-export-get-headline-number + destination info) + "."))))))) + ((org-export-inline-image-p link org-e-html-inline-image-rules) + (format "![%s](%s)" + (let ((caption + (org-element-property + :caption (org-export-get-parent-element link)))) + (when caption (org-export-data (car caption) info))) + path)) + ((string= type "coderef") + (let ((ref (org-element-property :path link))) + (format (org-export-get-coderef-format ref contents) + (org-export-resolve-coderef ref info)))) + ((equal type "radio") + (let ((destination (org-export-resolve-radio-link link info))) + (org-export-data (org-element-contents destination) info))) + ((equal type "fuzzy") + (let ((destination (org-export-resolve-fuzzy-link link info))) + ;; Ignore invisible "#+TARGET: path". + (unless (eq (org-element-type destination) 'keyword) + (if (org-string-nw-p contents) contents + (when destination + (let ((number (org-export-get-ordinal destination info))) + (when number + (if (atom number) (number-to-string number) + (mapconcat 'number-to-string number "."))))))))) + (t (let* ((raw-path (org-element-property :path link)) + (path (cond + ((member type '("http" "https" "ftp")) + (concat type ":" raw-path)) + ((equal type "file") + ;; Extract just the file path and strip + ;; all other components. + (when (string-match "\\(.+\\)::.+" raw-path) + (setq raw-path (match-string 1 raw-path))) + ;; Treat links to ".org" files as ".html", + ;; if needed. + (setq raw-path + (funcall --link-org-files-as-html-maybe + raw-path info)) + ;; If file path is absolute, prepend it + ;; with protocol component - "file://". + (if (not (file-name-absolute-p raw-path)) raw-path + (concat "file://" (expand-file-name raw-path)))) + (t raw-path)))) + (if (not contents) (format "<%s>" path) + (format "[%s](%s)" contents path))))))) + + +;;;; Paragraph + +(defun org-md-paragraph (paragraph contents info) + "Transcode PARAGRAPH element into Markdown format. +CONTENTS is the paragraph contents. INFO is a plist used as +a communication channel." + (let ((first-object (car (org-element-contents paragraph)))) + ;; If paragraph starts with a #, protect it. + (if (and (stringp first-object) (string-match "\\`#" first-object)) + (replace-regexp-in-string "\\`#" "\\#" contents nil t) + contents))) + + +;;;; Plain List + +(defun org-md-plain-list (plain-list contents info) + "Transcode PLAIN-LIST element into Markdown format. +CONTENTS is the plain-list contents. INFO is a plist used as +a communication channel." + contents) + + +;;;; Plain Text + +(defun org-md-plain-text (text info) + "Transcode a TEXT string into Markdown format. +TEXT is the string to transcode. INFO is a plist holding +contextual information." + ;; Protect ambiguous #. This will protect # at the beginning of + ;; a line, but not at the beginning of a paragraph. See + ;; `org-md-paragraph'. + (setq text (replace-regexp-in-string "\n#" "\n\\\\#" text)) + ;; Protect ambiguous ! + (setq text (replace-regexp-in-string "\\(!\\)\\[" "\\\\!" text nil nil 1)) + ;; Protect `, *, _ and \ + (setq text + (replace-regexp-in-string + "[`*_\\]" (lambda (rep) (concat "\\\\" (match-string 1 rep))) text)) + ;; Handle special strings, if required. + (when (plist-get info :with-special-strings) + (setq text (org-e-html-convert-special-strings text))) + ;; Handle break preservation, if required. + (when (plist-get info :preserve-breaks) + (setq text (replace-regexp-in-string "[ \t]*\n" " \n" text))) + ;; Return value. + text) + + +;;;; Quote Block + +(defun org-md-quote-block (quote-block contents info) + "Transcode QUOTE-BLOCK element into Markdown format. +CONTENTS is the quote-block contents. INFO is a plist used as +a communication channel." + (replace-regexp-in-string + "^" "> " + (replace-regexp-in-string "\n\\'" "" contents))) + + +;;;; Section + +(defun org-md-section (section contents info) + "Transcode SECTION element into Markdown format. +CONTENTS is the section contents. INFO is a plist used as +a communication channel." + contents) + + +;;;; Template + +(defun org-md-template (contents info) + "Return complete document string after Markdown conversion. +CONTENTS is the transcoded contents string. INFO is a plist used +as a communication channel." + contents) + + + +;;; Interactive function + +;;;###autoload +(defun org-md-export-as-markdown (&optional subtreep visible-only) + "Export current buffer to a text buffer. + +If narrowing is active in the current buffer, only export its +narrowed part. + +If a region is active, export that region. + +When optional argument SUBTREEP is non-nil, export the sub-tree +at point, extracting information from the headline properties +first. + +When optional argument VISIBLE-ONLY is non-nil, don't export +contents of hidden elements. + +Export is done in a buffer named \"*Org MD Export*\", which will +be displayed when `org-export-show-temporary-export-buffer' is +non-nil." + (interactive) + (let ((outbuf (org-export-to-buffer + 'md "*Org MD Export*" subtreep visible-only))) + (with-current-buffer outbuf (text-mode)) + (when org-export-show-temporary-export-buffer + (switch-to-buffer-other-window outbuf)))) + + +;;;###autoload +(defun org-md-export-to-markdown (&optional subtreep visible-only pub-dir) + "Export current buffer to a Markdown file. + +If narrowing is active in the current buffer, only export its +narrowed part. + +If a region is active, export that region. + +When optional argument SUBTREEP is non-nil, export the sub-tree +at point, extracting information from the headline properties +first. + +When optional argument VISIBLE-ONLY is non-nil, don't export +contents of hidden elements. + +When optional argument PUB-DIR is set, use it as the publishing +directory. + +Return output file's name." + (interactive) + (let ((outfile (org-export-output-file-name ".md" subtreep pub-dir))) + (org-export-to-file 'md outfile subtreep visible-only))) + + +(provide 'org-md) +;;; org-md.el ends here diff --git a/contrib/lisp/org-mime.el b/contrib/lisp/org-mime.el new file mode 100644 index 0000000..fc333be --- /dev/null +++ b/contrib/lisp/org-mime.el @@ -0,0 +1,336 @@ +;;; org-mime.el --- org html export for text/html MIME emails + +;; Copyright (C) 2010-2012 Eric Schulte + +;; Author: Eric Schulte +;; Keywords: mime, mail, email, html +;; Homepage: http://orgmode.org/worg/org-contrib/org-mime.php +;; Version: 0.01 + +;; This file is not part of GNU Emacs. + +;;; License: + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;; WYSWYG, html mime composition using org-mode +;; +;; For mail composed using the orgstruct-mode minor mode, this +;; provides a function for converting all or part of your mail buffer +;; to embedded html as exported by org-mode. Call `org-mime-htmlize' +;; in a message buffer to convert either the active region or the +;; entire buffer to html. +;; +;; Similarly the `org-mime-org-buffer-htmlize' function can be called +;; from within an org-mode buffer to convert the buffer to html, and +;; package the results into an email handling with appropriate MIME +;; encoding. +;; +;; you might want to bind this to a key with something like the +;; following message-mode binding +;; +;; (add-hook 'message-mode-hook +;; (lambda () +;; (local-set-key "\C-c\M-o" 'org-mime-htmlize))) +;; +;; and the following org-mode binding +;; +;; (add-hook 'org-mode-hook +;; (lambda () +;; (local-set-key "\C-c\M-o" 'org-mime-org-buffer-htmlize))) + +;;; Code: +(require 'cl) + +(defcustom org-mime-use-property-inheritance nil + "Non-nil means al MAIL_ properties apply also for sublevels." + :group 'org-mime + :type 'boolean) + +(defcustom org-mime-default-header + "#+OPTIONS: latex:t\n" + "Default header to control html export options, and ensure + first line isn't assumed to be a title line." + :group 'org-mime + :type 'string) + +(defcustom org-mime-library 'mml + "Library to use for marking up MIME elements." + :group 'org-mime + :type '(choice 'mml 'semi 'vm)) + +(defcustom org-mime-preserve-breaks t + "Used as temporary value of `org-export-preserve-breaks' during + mime encoding." + :group 'org-mime + :type 'boolean) + +(defcustom org-mime-fixedwith-wrap + "
    \n%s
    \n" + "Format string used to wrap a fixedwidth HTML email." + :group 'org-mime + :type 'string) + +(defcustom org-mime-html-hook nil + "Hook to run over the html buffer before attachment to email. + This could be used for example to post-process html elements." + :group 'org-mime + :type 'hook) + +(mapc (lambda (fmt) + (eval `(defcustom + ,(intern (concat "org-mime-pre-" fmt "-hook")) + nil + (concat "Hook to run before " fmt " export.\nFunctions " + "should take no arguments and will be run in a " + "buffer holding\nthe text to be exported.")))) + '("ascii" "org" "html")) + +(defcustom org-mime-send-subtree-hook nil + "Hook to run in the subtree in the Org-mode file before export.") + +(defcustom org-mime-send-buffer-hook nil + "Hook to run in the Org-mode file before export.") + +;; example hook, for setting a dark background in
     elements
    +(defun org-mime-change-element-style (element style)
    +  "Set new default htlm style for  elements in exported html."
    +  (while (re-search-forward (format "<%s" element) nil t)
    +    (replace-match (format "<%s style=\"%s\"" element style))))
    +
    +(defun org-mime-change-class-style (class style)
    +  "Set new default htlm style for objects with classs=CLASS in
    +exported html."
    +  (while (re-search-forward (format "class=\"%s\"" class) nil t)
    +    (replace-match (format "class=\"%s\" style=\"%s\"" class style))))
    +
    +;; ;; example addition to `org-mime-html-hook' adding a dark background
    +;; ;; color to 
     elements
    +;; (add-hook 'org-mime-html-hook
    +;;           (lambda ()
    +;;             (org-mime-change-element-style
    +;;              "pre" (format "color: %s; background-color: %s;"
    +;;                            "#E6E1DC" "#232323"))
    +;; 	    (org-mime-change-class-style
    +;;              "verse" "border-left: 2px solid gray; padding-left: 4px;")))
    +
    +(defun org-mime-file (ext path id)
    +  "Markup a file for attachment."
    +  (case org-mime-library
    +    ('mml (format (concat "<#part type=\"%s\" filename=\"%s\" "
    +			  "disposition=inline id=\"<%s>\">\n<#/part>\n")
    +		  ext path id))
    +    ('semi (concat
    +            (format (concat "--[[%s\nContent-Disposition: "
    +			    "inline;\nContent-ID: <%s>][base64]]\n")
    +		    ext id)
    +            (base64-encode-string
    +             (with-temp-buffer
    +               (set-buffer-multibyte nil)
    +               (binary-insert-encoded-file path)
    +               (buffer-string)))))
    +    ('vm "?")))
    +
    +(defun org-mime-multipart (plain html &optional images)
    +  "Markup a multipart/alternative with text/plain and text/html alternatives.
    +If the html portion of the message includes images wrap the html
    +and images in a multipart/related part."
    +  (case org-mime-library
    +    ('mml (concat "<#multipart type=alternative><#part type=text/plain>"
    +		  plain
    +		  (when images "<#multipart type=related>")
    +		  "<#part type=text/html>"
    +		  html
    +		  images
    +		  (when images "<#/multipart>\n")
    +		  "<#/multipart>\n"))
    +    ('semi (concat
    +            "--" "<>-{\n"
    +            "--" "[[text/plain]]\n" plain
    +	    (when images (concat "--" "<>-{\n"))
    +            "--" "[[text/html]]\n"  html
    +	    images
    +	    (when images (concat "--" "}-<>\n"))
    +            "--" "}-<>\n"))
    +    ('vm "?")))
    +
    +(defun org-mime-replace-images (str current-file)
    +  "Replace images in html files with cid links."
    +  (let (html-images)
    +    (cons
    +     (replace-regexp-in-string ;; replace images in html
    +      "src=\"\\([^\"]+\\)\""
    +      (lambda (text)
    +        (format
    +         "src=\"cid:%s\""
    +         (let* ((url (and (string-match "src=\"\\([^\"]+\\)\"" text)
    +                          (match-string 1 text)))
    +                (path (expand-file-name
    +                       url (file-name-directory current-file)))
    +                (ext (file-name-extension path))
    +                (id (replace-regexp-in-string "[\/\\\\]" "_" path)))
    +           (add-to-list 'html-images
    +                        (org-mime-file (concat "image/" ext) path id))
    +           id)))
    +      str)
    +     html-images)))
    +
    +(defun org-mime-htmlize (arg)
    +  "Export a portion of an email body composed using `mml-mode' to
    +html using `org-mode'.  If called with an active region only
    +export that region, otherwise export the entire body."
    +  (interactive "P")
    +  (let* ((region-p (org-region-active-p))
    +         (html-start (or (and region-p (region-beginning))
    +                         (save-excursion
    +                           (goto-char (point-min))
    +                           (search-forward mail-header-separator)
    +                           (+ (point) 1))))
    +         (html-end (or (and region-p (region-end))
    +                       ;; TODO: should catch signature...
    +                       (point-max)))
    +         (raw-body (buffer-substring html-start html-end))
    +         (tmp-file (make-temp-name (expand-file-name
    +				    "mail" temporary-file-directory)))
    +         (body (org-export-string raw-body 'org (file-name-directory tmp-file)))
    +         ;; because we probably don't want to skip part of our mail
    +         (org-export-skip-text-before-1st-heading nil)
    +         ;; because we probably don't want to export a huge style file
    +         (org-export-htmlize-output-type 'inline-css)
    +         ;; makes the replies with ">"s look nicer
    +         (org-export-preserve-breaks org-mime-preserve-breaks)
    +	 ;; dvipng for inline latex because MathJax doesn't work in mail
    +	 (org-export-with-LaTeX-fragments 'dvipng)
    +         ;; to hold attachments for inline html images
    +         (html-and-images
    +          (org-mime-replace-images
    +           (org-export-string raw-body 'html (file-name-directory tmp-file))
    +           tmp-file))
    +         (html-images (unless arg (cdr html-and-images)))
    +         (html (org-mime-apply-html-hook
    +                (if arg
    +                    (format org-mime-fixedwith-wrap body)
    +                  (car html-and-images)))))
    +    (delete-region html-start html-end)
    +    (save-excursion
    +      (goto-char html-start)
    +      (insert (org-mime-multipart
    +	       body html (mapconcat 'identity html-images "\n"))))))
    +
    +(defun org-mime-apply-html-hook (html)
    +  (if org-mime-html-hook
    +      (with-temp-buffer
    +        (insert html)
    +        (goto-char (point-min))
    +        (run-hooks 'org-mime-html-hook)
    +        (buffer-string))
    +    html))
    +
    +(defmacro org-mime-try (&rest body)
    +  `(condition-case nil ,@body (error nil)))
    +
    +(defun org-mime-send-subtree (&optional fmt)
    +  (save-restriction
    +    (org-narrow-to-subtree)
    +    (run-hooks 'org-mime-send-subtree-hook)
    +    (flet ((mp (p) (org-entry-get nil p org-mime-use-property-inheritance)))
    +      (let* ((file (buffer-file-name (current-buffer)))
    +	     (subject (or (mp "MAIL_SUBJECT") (nth 4 (org-heading-components))))
    +	     (to (mp "MAIL_TO"))
    +	     (cc (mp "MAIL_CC"))
    +	     (bcc (mp "MAIL_BCC"))
    +	     (body (buffer-substring
    +		    (save-excursion (goto-char (point-min))
    +				    (forward-line 1)
    +				    (when (looking-at "[ \t]*:PROPERTIES:")
    +				      (re-search-forward ":END:" nil)
    +				      (forward-char))
    +				    (point))
    +		    (point-max))))
    +	(org-mime-compose body (or fmt 'org) file to subject
    +			  `((cc . ,cc) (bcc . ,bcc)))))))
    +
    +(defun org-mime-send-buffer (&optional fmt)
    +  (run-hooks 'org-mime-send-buffer-hook)
    +  (let* ((region-p (org-region-active-p))
    +	 (subject (org-export-grab-title-from-buffer))
    +         (file (buffer-file-name (current-buffer)))
    +         (body-start (or (and region-p (region-beginning))
    +                         (save-excursion (goto-char (point-min)))))
    +         (body-end (or (and region-p (region-end)) (point-max)))
    +	 (temp-body-file (make-temp-file "org-mime-export"))
    +	 (body (buffer-substring body-start body-end)))
    +    (org-mime-compose body (or fmt 'org) file nil subject)))
    +
    +(defun org-mime-compose (body fmt file &optional to subject headers)
    +  (require 'message)
    +  (message-mail to subject headers nil)
    +  (message-goto-body)
    +  (flet ((bhook (body fmt)
    +		(let ((hook (intern (concat "org-mime-pre-"
    +					    (symbol-name fmt)
    +					    "-hook"))))
    +		  (if (> (eval `(length ,hook)) 0)
    +		      (with-temp-buffer
    +			(insert body)
    +			(goto-char (point-min))
    +			(eval `(run-hooks ',hook))
    +			(buffer-string))
    +		    body))))
    +    (let ((fmt (if (symbolp fmt) fmt (intern fmt))))
    +      (cond
    +       ((eq fmt 'org)
    +	(insert (org-export-string (org-babel-trim (bhook body 'org)) 'org)))
    +       ((eq fmt 'ascii)
    +	(insert (org-export-string
    +		 (concat "#+Title:\n" (bhook body 'ascii)) 'ascii)))
    +       ((or (eq fmt 'html) (eq fmt 'html-ascii))
    +	(let* ((org-link-file-path-type 'absolute)
    +	       ;; we probably don't want to export a huge style file
    +	       (org-export-htmlize-output-type 'inline-css)
    +	       (html-and-images (org-mime-replace-images
    +				 (org-export-string
    +				  (bhook body 'html)
    +				  'html (file-name-nondirectory file))
    +				 file))
    +	       (images (cdr html-and-images))
    +	       (html (org-mime-apply-html-hook (car html-and-images))))
    +	  (insert (org-mime-multipart
    +		   (org-export-string
    +		    (org-babel-trim
    +		     (bhook body (if (eq fmt 'html) 'org 'ascii)))
    +		    (if (eq fmt 'html) 'org 'ascii))
    +		   html)
    +		  (mapconcat 'identity images "\n"))))))))
    +
    +(defun org-mime-org-buffer-htmlize ()
    +  "Create an email buffer containing the current org-mode file
    +  exported to html and encoded in both html and in org formats as
    +  mime alternatives."
    +  (interactive)
    +  (org-mime-send-buffer 'html))
    +
    +(defun org-mime-subtree ()
    +  "Create an email buffer containing the current org-mode subtree
    +  exported to a org format or to the format specified by the
    +  MAIL_FMT property of the subtree."
    +  (interactive)
    +  (org-mime-send-subtree
    +   (or (org-entry-get nil "MAIL_FMT" org-mime-use-property-inheritance) 'org)))
    +
    +(provide 'org-mime)
    diff --git a/contrib/lisp/org-mtags.el b/contrib/lisp/org-mtags.el
    new file mode 100644
    index 0000000..8ea5fa9
    --- /dev/null
    +++ b/contrib/lisp/org-mtags.el
    @@ -0,0 +1,257 @@
    +;;; org-mtags.el --- Muse-like tags in Org-mode
    +
    +;; Copyright (C) 2008-2012 Free Software Foundation, Inc.
    +;;
    +;; Author: Carsten Dominik 
    +;; Keywords: outlines, hypermedia, calendar, wp
    +;; Homepage: http://orgmode.org
    +;; Version: 0.01
    +;;
    +;; This file is not yet part of GNU Emacs.
    +;;
    +;; GNU Emacs is free software; you can redistribute it and/or modify
    +;; it under the terms of the GNU General Public License as published by
    +;; the Free Software Foundation; either version 3, or (at your option)
    +;; any later version.
    +
    +;; GNU Emacs is distributed in the hope that it will be useful,
    +;; but WITHOUT ANY WARRANTY; without even the implied warranty of
    +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    +;; GNU General Public License for more details.
    +
    +;; You should have received a copy of the GNU General Public License
    +;; along with GNU Emacs; see the file COPYING.  If not, write to the
    +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
    +;; Boston, MA 02110-1301, USA.
    +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    +;;
    +;;; Commentary:
    +;;
    +;; This modules implements some of the formatting tags available in
    +;; Emacs Muse.  This is not a way if adding new functionality, but just
    +;; a different way to write some formatting directives.  The advantage is
    +;; that files written in this way can be read by Muse reasonably well,
    +;; and that this provides an alternative way of writing formatting
    +;; directives in Org, a way that some might find more pleasant to type
    +;; and look at that the Org's #+BEGIN..#+END notation.
    +
    +;; The goal of this development is to make it easier for people to
    +;; move between both worlds as they see fit for different tasks.
    +
    +;; The following muse tags will be translated during export into their
    +;; native Org equivalents:
    +;;
    +;;   
    +;; Needs to be at the end of a line. Will be translated to "\\". +;; +;; +;; Needs to be on a line by itself, similarly the tag. +;; Will be translated into Org's #+BEGIN_EXAMPLE construct. +;; +;; +;; Needs to be on a line by itself, similarly the tag. +;; Will be translated into Org's #+BEGIN_QUOTE construct. +;; +;; +;; Needs to be on a line by itself, similarly the tag. +;; Will be translated into Org's #+BEGIN_COMMENT construct. +;; +;; +;; Needs to be on a line by itself, similarly the tag. +;; Will be translated into Org's #+BEGIN_VERSE construct. +;; +;; +;; This gets translated into "[TABLE-OF-CONTENTS]". It will not +;; trigger the production of a table of contents - that is done +;; in Org with the "#+OPTIONS: toc:t" setting. But it will define +;; the location where the TOC will be placed. +;; +;; ;; only latex, html, and docbook supported +;; in Org. +;; Needs to be on a line by itself, similarly the tag. +;; +;; +;; Needs to be on a line by itself, similarly the tag. +;; Will be translated into Org's BEGIN_SRC construct. +;; +;; +;; Needs to be on a line by itself. +;; Will be translated into Org's #+INCLUDE construct. +;; +;; The lisp/perl/ruby/python tags can be implemented using the +;; `org-eval.el' module, which see. + +(require 'org) + +;;; Customization + +(defgroup org-mtags nil + "Options concerning Muse tags in Org mode." + :tag "Org Muse Tags" + :group 'org) + +(defface org-mtags ; similar to shadow + (org-compatible-face 'shadow + '((((class color grayscale) (min-colors 88) (background light)) + (:foreground "grey50")) + (((class color grayscale) (min-colors 88) (background dark)) + (:foreground "grey70")) + (((class color) (min-colors 8) (background light)) + (:foreground "green")) + (((class color) (min-colors 8) (background dark)) + (:foreground "yellow")))) + "Face for Muse-like tags in Org." + :group 'org-mtags + :group 'org-faces) + +(defcustom org-mtags-prefer-muse-templates t + "Non-nil means prefere Muse tags for structure elements. +This is relevane when expanding the templates defined in the variable +`org-structure-templates'." + :group 'org-mtags + :type 'boolean) + +(defconst org-mtags-supported-tags + '("example" "quote" "comment" "verse" "contents" "literal" "src" "include") + "The tags that are supported by org-mtags.el for conversion. +In addition to this list, the
    tag is supported as well.") + +(defconst org-mtags-fontification-re + (concat + "^[ \t]*[^>]*>\\|
    [ \t]*$") + "Regular expression used for fontifying muse tags.") + +(defun org-mtags-replace () + "Replace Muse-like tags with the appropriate Org constructs. +The is done in the entire buffer." + (interactive) ;; FIXME + (let ((re (concat "^[ \t]*\\(\\)")) + info tag rpl style markup lang file prefix prefix1 switches) + ;; First, do the
    tag + (goto-char (point-min)) + (while (re-search-forward "
    [ \t]*$" nil t) + (replace-match "\\\\" t t)) + ;; Now, all the other tags + (goto-char (point-min)) + (while (re-search-forward re nil t) + (goto-char (match-beginning 1)) + (setq info (org-mtags-get-tag-and-attributes)) + (if (not info) + (end-of-line 1) + (setq tag (plist-get info :tag)) + (cond + ((equal tag "contents") + (setq rpl "[TABLE-OF-CONTENTS]") + ;; FIXME: also trigger TOC in options-plist????? + ) + ((member tag '("quote" "comment" "verse")) + (if (plist-get info :closing) + (setq rpl (format "#+END_%s" (upcase tag))) + (setq rpl (format "#+BEGIN_%s" (upcase tag))))) + ((equal tag "literal") + (setq style (plist-get info :style)) + (and style (setq style (downcase style))) + (if (plist-get info :closing) + (setq rpl (cond + ((member style '("latex")) + "#+END_LaTeX") + ((member style '("html")) + "#+END_HTML") + ((member style '("docbook")) + "#+END_DOCBOOK") + ((member style '("ascii")) + "#+END_ASCII"))) + (setq rpl (cond + ((member style '("latex")) + "#+BEGIN_LaTeX") + ((member style '("html")) + "#+BEGIN_HTML") + ((member style '("ascii")) + "#+BEGIN_ASCII"))))) + ((equal tag "example") + (if (plist-get info :closing) + (setq rpl "#+END_EXAMPLE") + (setq rpl "#+BEGIN_EXAMPLE") + (when (setq switches (plist-get info :switches)) + (setq rpl (concat rpl " " switches))))) + ((equal tag "src") + (if (plist-get info :closing) + (setq rpl "#+END_SRC") + (setq rpl "#+BEGIN_SRC") + (when (setq lang (plist-get info :lang)) + (setq rpl (concat rpl " " lang)) + (when (setq switches (plist-get info :switches)) + (setq rpl (concat rpl " " switches)))))) + ((equal tag "include") + (setq file (plist-get info :file) + markup (downcase (plist-get info :markup)) + lang (plist-get info :lang) + prefix (plist-get info :prefix) + prefix1 (plist-get info :prefix1) + switches (plist-get info :switches)) + (setq rpl "#+INCLUDE") + (setq rpl (concat rpl " " (prin1-to-string file))) + (when markup + (setq rpl (concat rpl " " markup)) + (when (and (equal markup "src") lang) + (setq rpl (concat rpl " " lang)))) + (when prefix + (setq rpl (concat rpl " :prefix " (prin1-to-string prefix)))) + (when prefix1 + (setq rpl (concat rpl " :prefix1 " (prin1-to-string prefix1)))) + (when switches + (setq rpl (concat rpl " " switches))))) + (when rpl + (goto-char (plist-get info :match-beginning)) + (delete-region (point-at-bol) (plist-get info :match-end)) + (insert rpl)))))) + +(defun org-mtags-get-tag-and-attributes () + "Parse a Muse-like tag at point ant rturn the information about it. +The return value is a property list which contains all the attributes +with string values. In addition, it reutnrs the following properties: + +:tag The tag as a string. +:match-beginning The beginning of the match, just before \"<\". +:match-end The end of the match, just after \">\". +:closing t when the tag starts with \"\\)\\([^>]*\\)>") + (let ((start 0) + tag rest prop attributes endp val) + (setq tag (org-match-string-no-properties 2) + endp (match-end 1) + rest (and (match-end 3) + (org-match-string-no-properties 3)) + attributes (list :tag tag + :match-beginning (match-beginning 0) + :match-end (match-end 0) + :closing endp)) + (when rest + (while (string-match "\\([a-zA-Z]+\\)=\\([^ \t\n>]+\\|\"[^>]+\"\\)" + rest start) + (setq start (match-end 0) + prop (org-match-string-no-properties 1 rest) + val (org-remove-double-quotes + (org-match-string-no-properties 2 rest))) + (setq attributes (plist-put attributes + (intern (concat ":" prop)) val)))) + attributes))) + +(defun org-mtags-fontify-tags (limit) + "Fontify the muse-like tags." + (while (re-search-forward org-mtags-fontification-re limit t) + (add-text-properties (match-beginning 0) (match-end 0) + '(face org-mtags font-lock-multiline t + font-lock-fontified t)))) + +(add-hook 'org-export-preprocess-hook 'org-mtags-replace) +(add-hook 'org-font-lock-hook 'org-mtags-fontify-tags) + +(provide 'org-mtags) + +;;; org-mtags.el ends here diff --git a/contrib/lisp/org-notify.el b/contrib/lisp/org-notify.el new file mode 100644 index 0000000..9ddf150 --- /dev/null +++ b/contrib/lisp/org-notify.el @@ -0,0 +1,377 @@ +;;; org-notify.el --- Notifications for Org-mode + +;; Copyright (C) 2012 Free Software Foundation, Inc. + +;; Author: Peter Münster +;; Keywords: notification, todo-list, alarm, reminder, pop-up + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; Get notifications, when there is something to do. +;; Sometimes, you need a reminder a few days before a deadline, e.g. to buy a +;; present for a birthday, and then another notification one hour before to +;; have enough time to choose the right clothes. +;; For other events, e.g. rolling the dustbin to the roadside once per week, +;; you probably need another kind of notification strategy. +;; This package tries to satisfy the various needs. + +;; In order to activate this package, you must add the following code +;; into your .emacs: +;; +;; (require 'org-notify) +;; (org-notify-start) + +;; Example setup: +;; (org-notify-add 'appt +;; '(:time "-1s" :period "20s" :duration 10 +;; :actions (-message -ding)) +;; '(:time "15m" :period "2m" :duration 100 +;; :actions -notify) +;; '(:time "2h" :period "5m" :actions -message) +;; '(:time "3d" :actions -email)) +;; This means for todo-items with `notify' property set to `appt': 3 days +;; before deadline, send a reminder-email, 2 hours before deadline, start to +;; send messages every 5 minutes, then 15 minutes before deadline, start to +;; pop up notification windows every 2 minutes. The timeout of the window is +;; set to 100 seconds. Finally, when deadline is overdue, send messages and +;; make noise." + +;; Take also a look at the function `org-notify-add'. + +;;; Code: + +(eval-when-compile (require 'cl)) +(require 'org-element) + +(declare-function appt-delete-window "appt" ()) +(declare-function notifications-notify "notifications" (&rest prms)) +(declare-function article-lapsed-string "gnus-art" (t &optional ms)) + +(defgroup org-notify nil + "Options for Org-mode notifications." + :tag "Org Notify" + :group 'org) + +(defcustom org-notify-audible t + "Non-nil means beep to indicate notification." + :type 'boolean + :group 'org-notify) + +(defconst org-notify-actions + '("show" "show" "done" "done" "hour" "one hour later" "day" "one day later" + "week" "one week later") + "Possible actions for call-back functions.") + +(defconst org-notify-window-buffer-name "*org-notify-%s*" + "Buffer-name for the `org-notify-action-window' function.") + +(defvar org-notify-map nil + "Mapping between names and parameter lists.") + +(defvar org-notify-timer nil + "Timer of the notification daemon.") + +(defvar org-notify-parse-file nil + "Index of current file, that `org-element-parse-buffer' is parsing.") + +(defvar org-notify-on-action-map nil + "Mapping between on-action identifiers and parameter lists.") + +(defun org-notify-string->seconds (str) + "Convert time string STR to number of seconds." + (when str + (let* ((conv `(("s" . 1) ("m" . 60) ("h" . ,(* 60 60)) + ("d" . ,(* 24 60 60)) ("w" . ,(* 7 24 60 60)) + ("M" . ,(* 30 24 60 60)))) + (letters (concat + (mapcar (lambda (x) (string-to-char (car x))) conv))) + (case-fold-search nil)) + (string-match (concat "\\(-?\\)\\([0-9]+\\)\\([" letters "]\\)") str) + (* (string-to-number (match-string 2 str)) + (cdr (assoc (match-string 3 str) conv)) + (if (= (length (match-string 1 str)) 1) -1 1))))) + +(defun org-notify-make-todo (heading &rest ignored) + "Create one todo item." + (macrolet ((get (k) `(plist-get list ,k)) + (pr (k v) `(setq result (plist-put result ,k ,v)))) + (let* ((list (nth 1 heading)) (notify (or (get :notify) "default")) + (deadline (get :deadline)) (heading (get :raw-value)) + result) + (when (and (eq (get :todo-type) 'todo) heading deadline) + (pr :heading heading) (pr :notify (intern notify)) + (pr :begin (get :begin)) + (pr :file (nth org-notify-parse-file (org-agenda-files 'unrestricted))) + (pr :timestamp deadline) (pr :uid (md5 (concat heading deadline))) + (pr :deadline (- (org-time-string-to-seconds deadline) + (org-float-time)))) + result))) + +(defun org-notify-todo-list () + "Create the todo-list for one org-agenda file." + (let* ((files (org-agenda-files 'unrestricted)) + (max (1- (length files)))) + (setq org-notify-parse-file + (if (or (not org-notify-parse-file) (>= org-notify-parse-file max)) + 0 + (1+ org-notify-parse-file))) + (save-excursion + (with-current-buffer (find-file-noselect + (nth org-notify-parse-file files)) + (org-element-map (org-element-parse-buffer 'headline) + 'headline 'org-notify-make-todo))))) + +(defun org-notify-maybe-too-late (diff period heading) + "Print waring message, when notified significantly later than defined by +PERIOD." + (if (> (/ diff period) 1.5) + (message "Warning: notification for \"%s\" behind schedule!" heading)) + t) + +(defun org-notify-process () + "Process the todo-list, and possibly notify user about upcoming or +forgotten tasks." + (macrolet ((prm (k) `(plist-get prms ,k)) (td (k) `(plist-get todo ,k))) + (dolist (todo (org-notify-todo-list)) + (let* ((deadline (td :deadline)) (heading (td :heading)) + (uid (td :uid)) (last-run-sym + (intern (concat ":last-run-" uid)))) + (dolist (prms (plist-get org-notify-map (td :notify))) + (when (< deadline (org-notify-string->seconds (prm :time))) + (let ((period (org-notify-string->seconds (prm :period))) + (last-run (prm last-run-sym)) (now (org-float-time)) + (actions (prm :actions)) diff plist) + (when (or (not last-run) + (and period (< period (setq diff (- now last-run))) + (org-notify-maybe-too-late diff period heading))) + (setq prms (plist-put prms last-run-sym now) + plist (append todo prms)) + (if (if (plist-member prms :audible) + (prm :audible) + org-notify-audible) + (ding)) + (unless (listp actions) + (setq actions (list actions))) + (dolist (action actions) + (funcall (if (fboundp action) action + (intern (concat "org-notify-action" + (symbol-name action)))) + plist)))) + (return))))))) + +(defun org-notify-add (name &rest params) + "Add a new notification type. The NAME can be used in Org-mode property +`notify'. If NAME is `default', the notification type applies for todo items +without the `notify' property. This file predefines such a default +notification type. + +Each element of PARAMS is a list with parameters for a given time +distance to the deadline. This distance must increase from one element to +the next. +List of possible parameters: + :time Time distance to deadline, when this type of notification shall + start. It's a string: an integral value (positive or negative) + followed by a unit (s, m, h, d, w, M). + :actions A function or a list of functions to be called to notify the + user. Instead of a function name, you can also supply a suffix + of one of the various predefined `org-notify-action-xxx' + functions. + :period Optional: can be used to repeat the actions periodically. Same + format as :time. + :duration Some actions use this parameter to specify the duration of the + notification. It's an integral number in seconds. + :audible Overwrite the value of `org-notify-audible' for this action. + +For the actions, you can use your own functions or some of the predefined +ones, whose names are prefixed with `org-notify-action-'." + (setq org-notify-map (plist-put org-notify-map name params))) + +(defun org-notify-start (&optional secs) + "Start the notification daemon. If SECS is positive, it's the +period in seconds for processing the notifications of one +org-agenda file, and if negative, notifications will be checked +only when emacs is idle for -SECS seconds. The default value for +SECS is 20." + (if org-notify-timer + (org-notify-stop)) + (setq secs (or secs 20) + org-notify-timer (if (< secs 0) + (run-with-idle-timer (* -1 secs) t + 'org-notify-process) + (run-with-timer secs secs 'org-notify-process)))) + +(defun org-notify-stop () + "Stop the notification daemon." + (when org-notify-timer + (cancel-timer org-notify-timer) + (setq org-notify-timer nil))) + +(defun org-notify-on-action (plist key) + "User wants to see action." + (let ((file (plist-get plist :file)) + (begin (plist-get plist :begin))) + (if (string-equal key "show") + (progn + (switch-to-buffer (find-file-noselect file)) + (org-with-wide-buffer + (goto-char begin) + (show-entry)) + (goto-char begin) + (search-forward "DEADLINE: <") + (if (display-graphic-p) + (x-focus-frame nil))) + (save-excursion + (with-current-buffer (find-file-noselect file) + (org-with-wide-buffer + (goto-char begin) + (search-forward "DEADLINE: <") + (cond + ((string-equal key "done") (org-todo)) + ((string-equal key "hour") (org-timestamp-change 60 'minute)) + ((string-equal key "day") (org-timestamp-up-day)) + ((string-equal key "week") (org-timestamp-change 7 'day))))))))) + +(defun org-notify-on-action-notify (id key) + "User wants to see action after mouse-click in notify window." + (org-notify-on-action (plist-get org-notify-on-action-map id) key) + (org-notify-on-close id nil)) + +(defun org-notify-on-action-button (button) + "User wants to see action after button activation." + (macrolet ((get (k) `(button-get button ,k))) + (org-notify-on-action (get 'plist) (get 'key)) + (org-notify-delete-window (get 'buffer)) + (cancel-timer (get 'timer)))) + +(defun org-notify-delete-window (buffer) + "Delete the notification window." + (require 'appt) + (let ((appt-buffer-name buffer) + (appt-audible nil)) + (appt-delete-window))) + +(defun org-notify-on-close (id reason) + "Notification window has been closed." + (setq org-notify-on-action-map (plist-put org-notify-on-action-map id nil))) + +(defun org-notify-action-message (plist) + "Print a message." + (message "TODO: \"%s\" at %s!" (plist-get plist :heading) + (plist-get plist :timestamp))) + +(defun org-notify-action-ding (plist) + "Make noise." + (let ((timer (run-with-timer 0 1 'ding))) + (run-with-timer (or (plist-get plist :duration) 3) nil + 'cancel-timer timer))) + +(defun org-notify-body-text (plist) + "Make human readable string for remaining time to deadline." + (require 'gnus-art) + (format "%s\n(%s)" + (replace-regexp-in-string + " in the future" "" + (article-lapsed-string + (time-add (current-time) + (seconds-to-time (plist-get plist :deadline))) 2)) + (plist-get plist :timestamp))) + +(defun org-notify-action-email (plist) + "Send email to user." + (compose-mail user-mail-address (concat "TODO: " (plist-get plist :heading))) + (insert (org-notify-body-text plist)) + (funcall send-mail-function) + (flet ((yes-or-no-p (prompt) t)) + (kill-buffer))) + +(defun org-notify-select-highest-window () + "Select the highest window on the frame, that is not is not an +org-notify window. Mostly copied from `appt-select-lowest-window'." + (let ((highest-window (selected-window)) + (bottom-edge (nth 3 (window-edges))) + next-bottom-edge) + (walk-windows (lambda (w) + (when (and + (not (string-match "^\\*org-notify-.*\\*$" + (buffer-name + (window-buffer w)))) + (> bottom-edge (setq next-bottom-edge + (nth 3 (window-edges w))))) + (setq bottom-edge next-bottom-edge + highest-window w))) 'nomini) + (select-window highest-window))) + +(defun org-notify-action-window (plist) + "Pop up a window, mostly copied from `appt-disp-window'." + (save-excursion + (macrolet ((get (k) `(plist-get plist ,k))) + (let ((this-window (selected-window)) + (buf (get-buffer-create + (format org-notify-window-buffer-name (get :uid))))) + (when (minibufferp) + (other-window 1) + (and (minibufferp) (display-multi-frame-p) (other-frame 1))) + (if (cdr (assq 'unsplittable (frame-parameters))) + (progn (set-buffer buf) (display-buffer buf)) + (unless (or (special-display-p (buffer-name buf)) + (same-window-p (buffer-name buf))) + (org-notify-select-highest-window) + (when (>= (window-height) (* 2 window-min-height)) + (select-window (split-window nil nil 'above)))) + (switch-to-buffer buf)) + (setq buffer-read-only nil buffer-undo-list t) + (erase-buffer) + (insert (format "TODO: %s, %s.\n" (get :heading) + (org-notify-body-text plist))) + (let ((timer (run-with-timer (or (get :duration) 10) nil + 'org-notify-delete-window buf))) + (dotimes (i (/ (length org-notify-actions) 2)) + (let ((key (nth (* i 2) org-notify-actions)) + (text (nth (1+ (* i 2)) org-notify-actions))) + (insert-button text 'action 'org-notify-on-action-button + 'key key 'buffer buf 'plist plist 'timer timer) + (insert " ")))) + (shrink-window-if-larger-than-buffer (get-buffer-window buf t)) + (set-buffer-modified-p nil) (setq buffer-read-only t) + (raise-frame (selected-frame)) (select-window this-window))))) + +(defun org-notify-action-notify (plist) + "Pop up a notification window." + (require 'notifications) + (let* ((duration (plist-get plist :duration)) + (id (notifications-notify + :title (plist-get plist :heading) + :body (org-notify-body-text plist) + :timeout (if duration (* duration 1000)) + :actions org-notify-actions + :on-action 'org-notify-on-action-notify))) + (setq org-notify-on-action-map + (plist-put org-notify-on-action-map id plist)))) + +(defun org-notify-action-notify/window (plist) + "For a graphics display, pop up a notification window, for a text +terminal an emacs window." + (if (display-graphic-p) + (org-notify-action-notify plist) + (org-notify-action-window plist))) + +;;; Provide a minimal default setup. +(org-notify-add 'default '(:time "1h" :actions -notify/window + :period "2m" :duration 60)) + +(provide 'org-notify) + +;;; org-notify.el ends here diff --git a/contrib/lisp/org-notmuch.el b/contrib/lisp/org-notmuch.el new file mode 100644 index 0000000..0affd71 --- /dev/null +++ b/contrib/lisp/org-notmuch.el @@ -0,0 +1,105 @@ +;;; org-notmuch.el --- Support for links to notmuch messages from within Org-mode + +;; Copyright (C) 2010-2012 Matthieu Lemerre + +;; Author: Matthieu Lemerre +;; Keywords: outlines, hypermedia, calendar, wp +;; Homepage: http://orgmode.org + +;; This file is not part of GNU Emacs. + +;; This file is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; This file is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;; This file implements links to notmuch messages and "searchs". A +;; search is a query to be performed by notmuch; it is the equivalent +;; to folders in other mail clients. Similarly, mails are refered to +;; by a query, so both a link can refer to several mails. + +;; Links have one the following form +;; notmuch: +;; notmuch-search:. + +;; The first form open the queries in notmuch-show mode, whereas the +;; second link open it in notmuch-search mode. Note that queries are +;; performed at the time the link is opened, and the result may be +;; different from whet the link was stored. + +;;; Code: + +(require 'org) + +;; Install the link type +(org-add-link-type "notmuch" 'org-notmuch-open) +(add-hook 'org-store-link-functions 'org-notmuch-store-link) + +(defun org-notmuch-store-link () + "Store a link to a notmuch search or message." + (when (eq major-mode 'notmuch-show-mode) + (let* ((message-id (notmuch-show-get-prop :id)) + (subject (notmuch-show-get-subject)) + (to (notmuch-show-get-to)) + (from (notmuch-show-get-from)) + desc link) + (org-store-link-props :type "notmuch" :from from :to to + :subject subject :message-id message-id) + (setq desc (org-email-link-description)) + (setq link (concat "notmuch:" "id:" message-id)) + (org-add-link-props :link link :description desc) + link))) + +(defun org-notmuch-open (path) + "Follow a notmuch message link specified by PATH." + (org-notmuch-follow-link path)) + +(defun org-notmuch-follow-link (search) + "Follow a notmuch link to SEARCH. + +Can link to more than one message, if so all matching messages are shown." + (require 'notmuch) + (notmuch-show (org-link-unescape search))) + + + + +(org-add-link-type "notmuch-search" 'org-notmuch-search-open) +(add-hook 'org-store-link-functions 'org-notmuch-search-store-link) + +(defun org-notmuch-search-store-link () + "Store a link to a notmuch search or message." + (when (eq major-mode 'notmuch-search-mode) + (let ((link (concat "notmuch-search:" + (org-link-escape notmuch-search-query-string))) + (desc (concat "Notmuch search: " notmuch-search-query-string))) + (org-store-link-props :type "notmuch-search" + :link link + :description desc) + link))) + +(defun org-notmuch-search-open (path) + "Follow a notmuch message link specified by PATH." + (message path) + (org-notmuch-search-follow-link path)) + +(defun org-notmuch-search-follow-link (search) + "Follow a notmuch link by displaying SEARCH in notmuch-search mode." + (require 'notmuch) + (notmuch-search (org-link-unescape search))) + +(provide 'org-notmuch) + +;;; org-notmuch.el ends here diff --git a/contrib/lisp/org-panel.el b/contrib/lisp/org-panel.el new file mode 100644 index 0000000..3ffdfaf --- /dev/null +++ b/contrib/lisp/org-panel.el @@ -0,0 +1,641 @@ +;;; org-panel.el --- Simple routines for us with bad memory +;; +;; Author: Lennart Borgman (lennart O borgman A gmail O com) +;; Created: Thu Nov 15 15:35:03 2007 +;; Version: 0.21 +;; Lxast-Updated: Wed Nov 21 03:06:03 2007 (3600 +0100) +;; URL: +;; Keywords: +;; Compatibility: +;; +;; Features that might be required by this library: +;; +;; `easymenu', `font-lock', `noutline', `org', `outline', `syntax', +;; `time-date'. +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: +;; +;; This defines a kind of control panel for `org-mode'. This control +;; panel should make it fast to move around and edit structure etc. +;; +;; To bring up the control panel type +;; +;; M-x orgpan-panel +;; +;; Type ? there for help. +;; +;; I suggest you add the following to your .emacs for quick access of +;; the panel: +;; +;; (eval-after-load 'org-mode +;; (define-key org-mode-map [(control ?c) ?p] 'orgpan-panel)) +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Change log: +;; +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 2, or +;; (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth +;; Floor, Boston, MA 02110-1301, USA. +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Code: + +(require 'org) +(require 'outline) + +;; Fix-me: this is for testing. A minor mode version interferes badly +;; with emulation minor modes. On the other hand, the other version +;; interferes badly with (interactive ...). +(defvar orgpan-minor-mode-version t) + +(defface orgpan-field + '((t (:inherit 'widget-field))) + "Face for fields." + :group 'winsize) +(defvar orgpan-field-face 'orgpan-field) + +(defface orgpan-active-field + '((t (:inherit 'highlight))) + "Face for fields." + :group 'winsize) +(defvar orgpan-active-field-face 'orgpan-active-field) + +(defface orgpan-spaceline + '((t (:height 0.2))) + "Face for spacing lines." + :group 'winsize) + +(defcustom orgpan-panel-buttons nil + "Panel style, if non-nil use buttons. +If there are buttons in the panel they are used to change the way +the arrow keys work. The panel looks something like this, with +the first button chosen: + + [Navigate] [Restructure] [TODO/Priority] + ---------- + up/down, left: Go to, right: Visibility + +The line below the buttons try to give a short hint about what +the arrow keys does. \(Personally I prefer the version without +buttons since I then do not have to remember which button is +active.)" + :type 'boolean + :group 'winsize) + +;; Fix-me: add org-mode-map +(defconst orgpan-org-mode-commands nil) +(defconst orgpan-org-commands + '( + orgpan-copy-subtree + orgpan-cut-subtree + orgpan-paste-subtree + undo + ;; + ;orgpan-occur + ;; + org-cycle + org-global-cycle + outline-up-heading + outline-next-visible-heading + outline-previous-visible-heading + outline-forward-same-level + outline-backward-same-level + org-todo + org-show-todo-tree + org-priority-up + org-priority-down + org-move-subtree-up + org-move-subtree-down + org-do-promote + org-do-demote + org-promote-subtree + org-demote-subtree)) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Hook functions etc + +;;(defvar orgpan-this-panel-window nil) + +(defun orgpan-delete-panel () + "Remove the panel." + (interactive) + (when (buffer-live-p orgpan-panel-buffer) + (delete-windows-on orgpan-panel-buffer) + (kill-buffer orgpan-panel-buffer)) + (setq orgpan-panel-buffer nil) + (setq orgpan-panel-window nil) + (orgpan-panel-minor-mode 0) + (remove-hook 'post-command-hook 'orgpan-minor-post-command) + (remove-hook 'post-command-hook 'orgpan-mode-post-command) + ;;(remove-hook 'window-configuration-change-hook 'orgpan-window-config-change) + ) + +(defvar orgpan-last-command-was-from-panel nil) +(defun orgpan-mode-pre-command () + (setq orgpan-last-command-was-from-panel nil) + (condition-case err + (if (not (and (windowp orgpan-org-window) + (window-live-p orgpan-org-window))) + (progn + (setq this-command 'ignore) + (orgpan-delete-panel) + (message "The window belonging to the panel had disappeared, removed panel.")) + (let ((buf (window-buffer orgpan-org-window))) + (when (with-current-buffer buf + (derived-mode-p 'org-mode)) + (setq orgpan-last-org-buffer buf)) + ;; Fix me: add a list of those commands that are not + ;; meaningful from the panel (for example org-time-stamp) + (when (or (memq this-command orgpan-org-commands) + (memq this-command orgpan-org-mode-commands) + ;; For some reason not all org commands are found above: + (string= "org-" (substring (format "%s" this-command) 0 4))) + (if (not (with-current-buffer buf + (derived-mode-p 'org-mode))) + (progn + (if (buffer-live-p orgpan-org-buffer) + (set-window-buffer orgpan-org-window orgpan-org-buffer) + (message "Please use `l' or `b' to choose an org-mode buffer")) + (setq this-command 'ignore)) + (setq orgpan-org-buffer (window-buffer orgpan-org-window)) + (setq orgpan-last-command-was-from-panel t) + (select-window orgpan-org-window) + ;;(when (active-minibuffer-window + ;;(set-buffer orgpan-org-buffer) + )))) + (error (lwarn 't :warning "orgpan-pre: %S" err)))) + +(defun orgpan-mode-post-command () + (condition-case err + (progn + (unless (and (windowp orgpan-panel-window) + (window-live-p orgpan-panel-window) + (bufferp orgpan-panel-buffer) + (buffer-live-p orgpan-panel-buffer)) + ;;(orgpan-delete-panel) + ) + (when (and orgpan-last-command-was-from-panel + (windowp orgpan-panel-window) + (window-live-p orgpan-panel-window)) + (select-window orgpan-panel-window) + (when (derived-mode-p 'orgpan-mode) + (setq deactivate-mark t) + (when orgpan-panel-buttons + (unless (and orgpan-point + (= (point) orgpan-point)) + ;; Go backward so it is possible to click on a "button": + (orgpan-backward-field))))) + (setq orgpan-this-panel-window nil)) + (error (lwarn 't :warning "orgpan-post: %S" err)))) + +;; (defun orgpan-window-config-change () +;; "Check if any frame is displaying an orgpan panel. +;; If not remove `orgpan-mode-post-command' and this function from +;; the hooks." +;; (condition-case err +;; (unless (and ( +;; (let ((found-pan nil)) +;; (dolist (f (frame-list)) +;; (dolist (w (window-list f 'nomini)) +;; (with-current-buffer (window-buffer w) +;; (when (derived-mode-p 'orgpan-mode) +;; (setq found-pan t))))) +;; (unless found-pan +;; (remove-hook 'post-command-hook 'orgpan-mode-post-command) +;; (remove-hook 'window-configuration-change-hook 'orgpan-window-config-change))) +;; (error (lwarn 't :warning "Error in orgpan-config-change: %S" err)))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Commands + +(defun orgpan-last-buffer () + "Open last org-mode buffer in panels org window." + (interactive) + (let ((buf (window-buffer orgpan-org-window)) + (last-buf orgpan-last-org-buffer)) + (when (with-current-buffer buf + (derived-mode-p 'org-mode)) + (setq orgpan-last-org-buffer buf)) + (when (eq last-buf buf) + (setq last-buf nil)) + (if (not last-buf) + (orgpan-switch-buffer) + (set-window-buffer orgpan-org-window last-buf)))) + +(defun orgpan-switch-buffer () + "Switch to next org-mode buffer in panels org window." + (interactive) + (let ((buf (window-buffer orgpan-org-window)) + (org-buffers nil)) + (with-current-buffer buf + (when (derived-mode-p 'org-mode) + (bury-buffer buf) + (setq orgpan-last-org-buffer buf))) + (setq org-buffers (delq nil (mapcar (lambda (buf) + (when (with-current-buffer buf + (derived-mode-p 'org-mode)) + buf)) + (buffer-list)))) + (setq org-buffers (delq buf org-buffers)) + (set-window-buffer orgpan-org-window (car org-buffers)) + (setq orgpan-org-buffer (car org-buffers)))) + +(defun orgpan-paste-subtree () + (interactive) + (if (y-or-n-p "Paste subtree here? ") + (org-paste-subtree) + (message "Nothing was pasted"))) + +(defun orgpan-cut-subtree () + (interactive) + (let ((heading (progn + (org-back-to-heading) + (buffer-substring (point) (line-end-position)) + ))) + (if (y-or-n-p (format "Do you want to cut the subtree\n%s\n? " heading)) + (org-cut-subtree) + (message "Nothing was cut")))) + +(defun orgpan-copy-subtree () + (interactive) + (let ((heading (progn + (org-back-to-heading) + (buffer-substring (point) (line-end-position)) + ))) + (if (y-or-n-p (format "Do you want to copy the subtree\n%s\n? " heading)) + (org-copy-subtree) + (message "Nothing was copied")))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Buttons + +(defvar orgpan-ovl-help nil) + +(defun orgpan-check-panel-mode () + (unless (derived-mode-p 'orgpan-mode) + (error "Not orgpan-mode in buffer: " major-mode))) + +(defun orgpan-display-bindings-help () + (orgpan-check-panel-mode) + (setq orgpan-point (point)) + (let* ((ovls (overlays-at (point))) + (ovl (car ovls)) + (help (when ovl (overlay-get ovl 'orgpan-explain)))) + (dolist (o (overlays-in (point-min) (point-max))) + (overlay-put o 'face orgpan-field-face)) + (overlay-put ovl 'face orgpan-active-field-face) + (overlay-put orgpan-ovl-help 'before-string help))) + +(defun orgpan-forward-field () + (interactive) + (orgpan-check-panel-mode) + (let ((pos (next-overlay-change (point)))) + (unless (overlays-at pos) + (setq pos (next-overlay-change pos))) + (when (= pos (point-max)) + (setq pos (point-min)) + (unless (overlays-at pos) + (setq pos (next-overlay-change pos)))) + (goto-char pos)) + (orgpan-display-bindings-help)) + +(defun orgpan-backward-field () + (interactive) + (orgpan-check-panel-mode) + (when (= (point) (point-min)) + (goto-char (point-max))) + (let ((pos (previous-overlay-change (point)))) + (unless (overlays-at pos) + (setq pos (previous-overlay-change pos))) + (goto-char pos)) + (orgpan-display-bindings-help)) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Mode + +(defconst orgpan-mode-map + ;; Fix-me: clean up here! + ;; Fix-me: viper support + (let ((map (make-sparse-keymap))) + (define-key map [?q] 'orgpan-delete-panel) + (define-key map [??] 'orgpan-help) + ;; Copying etc + (define-key map [?c] 'orgpan-copy-subtree) + (define-key map [?x] 'orgpan-cut-subtree) + (define-key map [?p] 'orgpan-paste-subtree) + (define-key map [?z] 'undo) + ;; Buffers: + (define-key map [?b] 'orgpan-switch-buffer) + (define-key map [?l] 'orgpan-last-buffer) + ;; Some keys for moving between headings. Emacs keys for next/prev + ;; line seems ok: + (define-key map [(control ?p)] 'outline-previous-visible-heading) + (define-key map [(control ?n)] 'outline-next-visible-heading) + (define-key map [(shift control ?p)] 'outline-backward-same-level) + (define-key map [(shift control ?n)] 'outline-forward-same-level) + ;; A mnemunic for up: + (define-key map [(control ?u)] 'outline-up-heading) + ;; Search sparse tree: + ;; + ;; Fix-me: Search does not work, some problem with + ;; interactive. Probably have to turn the whole thing around and + ;; always be in the org buffer, but with a minor mode running + ;; there. + ;; + ;;(define-key map [?s] 'org-sparse-tree) + (define-key map [?s] 'orgpan-occur) + ;; Same as in org-mode: + ;;(define-key map [(control ?c)(control ?v)] 'org-show-todo-tree) + ;; Fix-me: This leads to strange problems: + ;;(define-key map [t] 'ignore) + map)) + +(defun orgpan-occur () + "Replacement for `org-occur'. +Technical reasons." + (interactive) + (let ((rgx (read-from-minibuffer "my mini Regexp: "))) + (setq orgpan-last-command-was-from-panel t) + (select-window orgpan-org-window) + (org-occur rgx))) + +(defvar orgpan-panel-window nil + "The window showing `orgpan-panel-buffer'.") + +(defvar orgpan-panel-buffer nil + "The panel buffer. +There can be only one such buffer at any time.") + +(defvar orgpan-org-window nil) +;;(make-variable-buffer-local 'orgpan-org-window) + +;; Fix-me: used? +(defvar orgpan-org-buffer nil) +;;(make-variable-buffer-local 'orgpan-org-buffer) + +(defvar orgpan-last-org-buffer nil) +;;(make-variable-buffer-local 'orgpan-last-org-buffer) + +(defvar orgpan-point nil) +;;(make-variable-buffer-local 'orgpan-point) + +(defun orgpan-avoid-viper-in-buffer () + ;; Fix-me: This is ugly. However see `this-major-mode-requires-vi-state': + (set (make-local-variable 'viper-emacs-state-mode-list) '(orgpan-mode)) + (set (make-local-variable 'viper-new-major-mode-buffer-list) nil) + (local-set-key [?\ ] 'ignore)) + +(define-derived-mode orgpan-mode nil "Org-Panel" + "Mode for org-simple.el control panel." + (setq buffer-read-only t) + (unless orgpan-minor-mode-version + (add-hook 'pre-command-hook 'orgpan-mode-pre-command nil t) + (add-hook 'post-command-hook 'orgpan-mode-post-command t)) + (orgpan-avoid-viper-in-buffer) + (setq cursor-type nil)) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Panel layout + +(defun orgpan-insert-field (text keymap explain) + (insert text) + (let* ((end (point)) + (len (length text)) + (beg (- end len)) + (ovl (make-overlay beg end))) + (overlay-put ovl 'face orgpan-field-face) + (overlay-put ovl 'keymap keymap) + (overlay-put ovl 'orgpan-explain explain))) + +(defconst orgpan-with-keymap + (let ((map (make-sparse-keymap))) + (set-keymap-parent map org-mode-map) + ;; Users are used to tabbing between fields: + (define-key map [(tab)] 'orgpan-forward-field) + (define-key map [(shift tab)] 'orgpan-backward-field) + ;; Now we must use something else for visibility (first does not work if Viper): + (define-key map [(meta tab)] 'org-cycle) + (define-key map [(control meta tab)] 'org-global-cycle) + map)) + +(defconst orgpan-without-keymap + (let ((map (make-sparse-keymap))) + (set-keymap-parent map org-mode-map) + ;; Visibility (those are in org-mode-map): + ;;(define-key map [tab] 'org-cycle) + ;;(define-key map [(shift tab)] 'org-global-cycle) + ;; Navigate: + (define-key map [left] 'outline-up-heading) + (define-key map [right] 'org-cycle) + (define-key map [up] 'outline-previous-visible-heading) + (define-key map [down] 'outline-next-visible-heading) + (define-key map [(shift down)] 'outline-forward-same-level) + (define-key map [(shift up)] 'outline-backward-same-level) + ;; Restructure: + (define-key map [(control up)] 'org-move-subtree-up) + (define-key map [(control down)] 'org-move-subtree-down) + (define-key map [(control left)] 'org-do-promote) + (define-key map [(control right)] 'org-do-demote) + (define-key map [(control shift left)] 'org-promote-subtree) + (define-key map [(control shift right)] 'org-demote-subtree) + ;; Todo etc + (define-key map [?+] 'org-priority-up) + (define-key map [?-] 'org-priority-down) + (define-key map [?t] 'org-todo) + map)) + +(defun orgpan-make-panel-without-buttons (buf) + (with-current-buffer buf + (insert (propertize "Org Panel" 'face 'orgpan-active-field)) + (insert " ? for help, q quit\n") + (insert (propertize "arrows" 'face 'font-lock-keyword-face) + ": Go to, " + (propertize "C-arrows" 'face 'font-lock-keyword-face) + ": Edit tree\n" + (propertize "cxpz" 'face 'font-lock-keyword-face) + ": copy cut paste undo, " + (propertize "tT+-" 'face 'font-lock-keyword-face) + ": todo priority, " + (propertize "s" 'face 'font-lock-keyword-face) + " search" + ) + (set-keymap-parent orgpan-mode-map orgpan-without-keymap) + )) + +(defun orgpan-make-panel-with-buttons (buf) + (with-current-buffer buf + (let* ((base-map (make-sparse-keymap)) + (space-line (propertize "\n\n" 'face 'orgpan-spaceline)) + (arrow-face 'font-lock-keyword-face) + (L (propertize "left" 'face arrow-face)) + (R (propertize "right" 'face arrow-face)) + (U (propertize "up" 'face arrow-face)) + (D (propertize "down" 'face arrow-face))) + ;;(message D)(sit-for 2) + (define-key base-map [left] 'ignore) + (define-key base-map [right] 'ignore) + (define-key base-map [up] 'ignore) + (define-key base-map [down] 'ignore) + (define-key base-map [?q] 'delete-window) + (define-key base-map [??] 'orgpan-help) + ;; Navigating + (let ((map (copy-keymap base-map))) + (define-key map [left] 'outline-up-heading) + (define-key map [right] 'org-cycle) + (define-key map [up] 'outline-previous-visible-heading) + (define-key map [down] 'outline-next-visible-heading) + (define-key map [(shift down)] 'outline-forward-same-level) + (define-key map [(shift up)] 'outline-backward-same-level) + (orgpan-insert-field "Navigate" map (concat U "/" D ", " L ": Go to, " R ": Visibility"))) + (insert " ") + (let ((map (copy-keymap base-map))) + (define-key map [up] 'org-move-subtree-up) + (define-key map [down] 'org-move-subtree-down) + (define-key map [left] 'org-do-promote) + (define-key map [right] 'org-do-demote) + (define-key map [(shift left)] 'org-promote-subtree) + (define-key map [(shift right)] 'org-demote-subtree) + (orgpan-insert-field + "Restructure" map + (concat U "/" D ": " + (propertize "Move" 'face 'font-lock-warning-face) + ", " L "/" R ": " + (propertize "Level (w S: Subtree Level)" 'face 'font-lock-warning-face)))) + (insert " ") + (let ((map (copy-keymap base-map))) + (define-key map [up] 'org-priority-up) + (define-key map [down] 'org-priority-down) + (define-key map [right] 'org-todo) + (orgpan-insert-field "TODO/priority" map + (concat R ": TODO, " U "/" D ": Priority"))) + ) + (insert " ? for help, q quit\n") + (orgpan-display-bindings-help) + (setq orgpan-ovl-help (make-overlay (point) (point))) + )) + +(defun orgpan-make-panel-buffer () + "Make the panel buffer." + (let* ((buf-name "*Org Panel*")) + (when orgpan-panel-buffer (kill-buffer orgpan-panel-buffer)) + (setq orgpan-panel-buffer (get-buffer-create buf-name)) + (if orgpan-panel-buttons + (orgpan-make-panel-with-buttons orgpan-panel-buffer) + (orgpan-make-panel-without-buttons orgpan-panel-buffer)) + (with-current-buffer orgpan-panel-buffer + (orgpan-mode) + (goto-char (point-min))) + orgpan-panel-buffer)) + +(defun orgpan-help () + (interactive) + (set-keymap-parent orgpan-with-keymap nil) + (set-keymap-parent orgpan-without-keymap nil) + (describe-function 'orgpan-panel) + (set-keymap-parent orgpan-with-keymap org-mode-map) + (set-keymap-parent orgpan-without-keymap org-mode-map) + (message "Use 'l' to remove help window") + ) + +(defun orgpan-panel () + "Create a control panel for current `org-mode' buffer. +The control panel may be used to quickly move around and change +the headings. The idea is that when you want to to a lot of this +kind of editing you should be able to do that with few +keystrokes (and without having to remember the complicated +keystrokes). A typical situation when this perhaps can be useful +is when you are looking at your notes file \(usually ~/.notes, +see `remember-data-file') where you have saved quick notes with +`remember'. + +The keys below are defined in the panel. Note that the commands +are carried out in the `org-mode' buffer that belongs to the +panel. + +\\{orgpan-mode-map} + +In addition to the keys above most of the keys in `org-mode' can +also be used from the panel. + +Note: There are two forms of the control panel, one with buttons +and one without. The default is without, see +`orgpan-panel-buttons'. If buttons are used choosing a different +button changes the binding of the arrow keys." + (interactive) + (unless (derived-mode-p 'org-mode) + (error "Buffer is not in org-mode")) + (orgpan-delete-panel) + (unless orgpan-org-mode-commands + (map-keymap (lambda (ev def) + (when (and def + (symbolp def) + (fboundp def)) + (setq orgpan-org-mode-commands + (cons def orgpan-org-mode-commands)))) + org-mode-map)) + ;;(org-back-to-heading) + ;;(remove-hook 'window-configuration-change-hook 'orgpan-window-config-change) + (split-window) + (set-window-buffer (selected-window) (orgpan-make-panel-buffer)) + (setq orgpan-panel-window (selected-window)) + ;;(set-window-dedicated-p (selected-window) t) + (fit-window-to-buffer nil nil 3) + (setq orgpan-org-window (next-window)) + ;; The minor mode version starts here: + (when orgpan-minor-mode-version + (select-window orgpan-org-window) + (orgpan-panel-minor-mode 1) + (add-hook 'post-command-hook 'orgpan-minor-post-command t))) + +(defun orgpan-minor-post-command () + (unless (and + ;; Check org window and buffer + (windowp orgpan-org-window) + (window-live-p orgpan-org-window) + (eq orgpan-org-window (selected-window)) + (derived-mode-p 'org-mode) + ;; Check panel window and buffer + (windowp orgpan-panel-window) + (window-live-p orgpan-panel-window) + (bufferp orgpan-panel-buffer) + (buffer-live-p orgpan-panel-buffer) + (eq (window-buffer orgpan-panel-window) orgpan-panel-buffer) + ;; Check minor mode + orgpan-panel-minor-mode) + (orgpan-delete-panel))) + +(define-minor-mode orgpan-panel-minor-mode + "Minor mode used in `org-mode' buffer when showing panel." + :keymap orgpan-mode-map + :lighter " PANEL" + :group 'orgpan + ) + + +(provide 'org-panel) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; org-panel.el ends here diff --git a/contrib/lisp/org-registry.el b/contrib/lisp/org-registry.el new file mode 100644 index 0000000..c1a1c6c --- /dev/null +++ b/contrib/lisp/org-registry.el @@ -0,0 +1,271 @@ +;;; org-registry.el --- a registry for Org links +;; +;; Copyright 2007-2012 Bastien Guerry +;; +;; Emacs Lisp Archive Entry +;; Filename: org-registry.el +;; Version: 0.1a +;; Author: Bastien Guerry +;; Maintainer: Bastien Guerry +;; Keywords: org, wp, registry +;; Description: Shows Org files where the current buffer is linked +;; URL: http://www.cognition.ens.fr/~guerry/u/org-registry.el +;; +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, write to the Free Software +;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +;;; Commentary: +;; +;; This library add a registry to your Org setup. +;; +;; Org files are full of links inserted with `org-store-link'. This links +;; point to e-mail, webpages, files, dirs, info pages, man pages, etc. +;; Actually, they come from potentially *everywhere* since Org lets you +;; define your own storing/following functions. +;; +;; So, what if you are on a e-mail, webpage or whatever and want to know if +;; this buffer has already been linked to somewhere in your agenda files? +;; +;; This is were org-registry comes in handy. +;; +;; M-x org-registry-show will tell you the name of the file +;; C-u M-x org-registry-show will directly jump to the file +;; +;; In case there are several files where the link lives in: +;; +;; M-x org-registry-show will display them in a new window +;; C-u M-x org-registry-show will prompt for a file to visit +;; +;; Add this to your Org configuration: +;; +;; (require 'org-registry) +;; (org-registry-initialize) +;; +;; If you want to update the registry with newly inserted links in the +;; current buffer: M-x org-registry-update +;; +;; If you want this job to be done each time you save an Org buffer, +;; hook 'org-registry-update to the local 'after-save-hook in org-mode: +;; +;; (org-registry-insinuate) + +;;; Code: + +(eval-when-compile + (require 'cl)) + +(defgroup org-registry nil + "A registry for Org." + :group 'org) + +(defcustom org-registry-file + (concat (getenv "HOME") "/.org-registry.el") + "The Org registry file." + :group 'org-registry + :type 'file) + +(defcustom org-registry-find-file 'find-file-other-window + "How to find visit files." + :type 'function + :group 'org-registry) + +(defvar org-registry-alist nil + "An alist containing the Org registry.") + +;;;###autoload +(defun org-registry-show (&optional visit) + "Show Org files where there are links pointing to the current +buffer." + (interactive "P") + (org-registry-initialize) + (let* ((blink (or (org-remember-annotation) "")) + (link (when (string-match org-bracket-link-regexp blink) + (match-string-no-properties 1 blink))) + (desc (or (and (string-match org-bracket-link-regexp blink) + (match-string-no-properties 3 blink)) "No description")) + (files (org-registry-assoc-all link)) + file point selection tmphist) + (cond ((and files visit) + ;; result(s) to visit + (cond ((< 1 (length files)) + ;; more than one result + (setq tmphist (mapcar (lambda(entry) + (format "%s (%d) [%s]" + (nth 3 entry) ; file + (nth 2 entry) ; point + (nth 1 entry))) files)) + (setq selection (completing-read "File: " tmphist + nil t nil 'tmphist)) + (string-match "\\(.+\\) (\\([0-9]+\\))" selection) + (setq file (match-string 1 selection)) + (setq point (string-to-number (match-string 2 selection)))) + ((eq 1 (length files)) + ;; just one result + (setq file (nth 3 (car files))) + (setq point (nth 2 (car files))))) + ;; visit the (selected) file + (funcall org-registry-find-file file) + (goto-char point) + (unless (org-before-first-heading-p) + (org-show-context))) + ((and files (not visit)) + ;; result(s) to display + (cond ((eq 1 (length files)) + ;; show one file + (message "Link in file %s (%d) [%s]" + (nth 3 (car files)) + (nth 2 (car files)) + (nth 1 (car files)))) + (t (org-registry-display-files files link)))) + (t (message "No link to this in org-agenda-files"))))) + +(defun org-registry-display-files (files link) + "Display files in a separate window." + (switch-to-buffer-other-window + (get-buffer-create " *Org registry info*")) + (erase-buffer) + (insert (format "Files pointing to %s:\n\n" link)) + (let (file) + (while (setq file (pop files)) + (insert (format "%s (%d) [%s]\n" (nth 3 file) + (nth 2 file) (nth 1 file))))) + (shrink-window-if-larger-than-buffer) + (other-window 1)) + +(defun org-registry-assoc-all (link &optional registry) + "Return all associated entries of LINK in the registry." + (org-registry-find-all + (lambda (entry) (string= link (car entry))) + registry)) + +(defun org-registry-find-all (test &optional registry) + "Return all entries satisfying `test' in the registry." + (delq nil + (mapcar + (lambda (x) (and (funcall test x) x)) + (or registry org-registry-alist)))) + +;;;###autoload +(defun org-registry-visit () + "If an Org file contains a link to the current location, visit +this file." + (interactive) + (org-registry-show t)) + +;;;###autoload +(defun org-registry-initialize (&optional from-scratch) + "Initialize `org-registry-alist'. +If FROM-SCRATCH is non-nil or the registry does not exist yet, +create a new registry from scratch and eval it. If the registry +exists, eval `org-registry-file' and make it the new value for +`org-registry-alist'." + (interactive "P") + (if (or from-scratch (not (file-exists-p org-registry-file))) + ;; create a new registry + (let ((files org-agenda-files) file) + (while (setq file (pop files)) + (setq file (expand-file-name file)) + (mapc (lambda (entry) + (add-to-list 'org-registry-alist entry)) + (org-registry-get-entries file))) + (when from-scratch + (org-registry-create org-registry-alist))) + ;; eval the registry file + (with-temp-buffer + (insert-file-contents org-registry-file) + (eval-buffer)))) + +;;;###autoload +(defun org-registry-insinuate () + "Call `org-registry-update' after saving in Org-mode. +Use with caution. This could slow down things a bit." + (interactive) + (add-hook 'org-mode-hook + (lambda() (add-hook 'after-save-hook + 'org-registry-update t t)))) + +(defun org-registry-get-entries (file) + "List Org links in FILE that will be put in the registry." + (let (bufstr result) + (with-temp-buffer + (insert-file-contents file) + (goto-char (point-min)) + (while (re-search-forward org-angle-link-re nil t) + (let* ((point (match-beginning 0)) + (link (match-string-no-properties 0)) + (desc (match-string-no-properties 0))) + (add-to-list 'result (list link desc point file)))) + (goto-char (point-min)) + (while (re-search-forward org-bracket-link-regexp nil t) + (let* ((point (match-beginning 0)) + (link (match-string-no-properties 1)) + (desc (or (match-string-no-properties 3) "No description"))) + (add-to-list 'result (list link desc point file))))) + ;; return the list of new entries + result)) + +;;;###autoload +(defun org-registry-update () + "Update the registry for the current Org file." + (interactive) + (unless (eq major-mode 'org-mode) (error "Not in org-mode")) + (let* ((from-file (expand-file-name (buffer-file-name))) + (new-entries (org-registry-get-entries from-file))) + (with-temp-buffer + (unless (file-exists-p org-registry-file) + (org-registry-initialize t)) + (find-file org-registry-file) + (goto-char (point-min)) + (while (re-search-forward (concat from-file "\")$") nil t) + (let ((end (1+ (match-end 0))) + (beg (progn (re-search-backward "^(\"" nil t) + (match-beginning 0)))) + (delete-region beg end))) + (goto-char (point-min)) + (re-search-forward "^(\"" nil t) + (goto-char (match-beginning 0)) + (mapc (lambda (elem) + (insert (with-output-to-string (prin1 elem)) "\n")) + new-entries) + (save-buffer) + (kill-buffer (current-buffer))) + (message (format "Org registry updated for %s" + (file-name-nondirectory from-file))))) + +(defun org-registry-create (entries) + "Create `org-registry-file' with ENTRIES." + (let (entry) + (with-temp-buffer + (find-file org-registry-file) + (erase-buffer) + (insert + (with-output-to-string + (princ ";; -*- emacs-lisp -*-\n") + (princ ";; Org registry\n") + (princ ";; You shouldn't try to modify this buffer manually\n\n") + (princ "(setq org-registry-alist\n'(\n") + (while entries + (when (setq entry (pop entries)) + (prin1 entry) + (princ "\n"))) + (princ "))\n"))) + (save-buffer) + (kill-buffer (current-buffer)))) + (message "Org registry created")) + +(provide 'org-registry) + +;;; User Options, Variables + +;;; org-registry.el ends here diff --git a/contrib/lisp/org-screen.el b/contrib/lisp/org-screen.el new file mode 100644 index 0000000..a517b4b --- /dev/null +++ b/contrib/lisp/org-screen.el @@ -0,0 +1,108 @@ +;;; org-screen.el --- Integreate Org-mode with screen. + +;; Copyright (c) 2008-2012 Andrew Hyatt +;; +;; Author: Andrew Hyatt +;; Maintainer: Carsten Dominik +;; +;; This file is not yet part of GNU Emacs. +;; +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: +;; +;; This file contains functionality to integrate screen and org-mode. +;; When using org-mode, it is often useful to take tasks that have +;; some command-line work associated with them, and associate them +;; with a screen session. Screen is used rather than a direct +;; terminal to facilitate portability of the resulting session. +;; +;; To use screen in org, in your .emacs file, simply put this file in +;; a directory in your load-path and write: +;; +;; (require 'org-screen) +;; +;; When have a task and want to start some command-line activity +;; associated with that task, go to the end of your item and type: +;; +;; M-x org-screen +;; +;; This will prompt you for a name of a screen session. Type in a +;; name and it will insert a link into your org file at your current +;; location. +;; +;; When you want to visit the link, go to the link and type C-c C-o to +;; open the link. +;; +;; You may want to get rid of the constant queries about whether you +;; really want to execute lisp code. Do so by adding to your .emacs: +;; +;; (setq org-confirm-elisp-link-function nil) + +(require 'term) +(require 'org) + +(defcustom org-screen-program-name "/usr/bin/screen" + "Full location of the screen executable." + :group 'org-screen + :type 'string) + +(defun org-screen (name) + "Start a screen session with name" + (interactive "MScreen name: ") + (save-excursion + (org-screen-helper name "-S")) + (insert-string (concat "[[screen:" name "]]"))) + +(defun org-screen-buffer-name (name) + "Returns the buffer name corresponding to the screen name given." + (concat "*screen " name "*")) + +(defun org-screen-helper (name arg) + "This method will create a screen session with a specified name +and taking the specified screen arguments. Much of this function +is copied from ansi-term method." + + ;; Pick the name of the new buffer. + (let ((term-ansi-buffer-name + (generate-new-buffer-name + (org-screen-buffer-name name)))) + (setq term-ansi-buffer-name + (term-ansi-make-term + term-ansi-buffer-name org-screen-program-name nil arg name)) + (set-buffer term-ansi-buffer-name) + (term-mode) + (term-char-mode) + (term-set-escape-char ?\C-x) + term-ansi-buffer-name)) + +(defun org-screen-goto (name) + "Open the screen with the specified name in the window" + (interactive "MScreen name: ") + (let ((screen-buffer-name (org-screen-buffer-name name))) + (if (member screen-buffer-name + (mapcar 'buffer-name (buffer-list))) + (org-pop-to-buffer-same-window screen-buffer-name) + (org-pop-to-buffer-same-window (org-screen-helper name "-dr"))))) + +(if org-link-abbrev-alist + (add-to-list 'org-link-abbrev-alist + '("screen" . "elisp:(org-screen-goto \"%s\")")) + (setq org-link-abbrev-alist + '(("screen" . "elisp:(org-screen-goto \"%s\")")))) + +(provide 'org-screen) diff --git a/contrib/lisp/org-secretary.el b/contrib/lisp/org-secretary.el new file mode 100644 index 0000000..5db60f6 --- /dev/null +++ b/contrib/lisp/org-secretary.el @@ -0,0 +1,232 @@ +;;; org-secretary.el --- Team management with org-mode +;; Copyright (C) 2010-2012 Juan Reyero +;; +;; Author: Juan Reyero +;; Keywords: outlines, tasks, team, management +;; Homepage: http://juanreyero.com/article/emacs/org-teams.html +;; Version: 0.02 +;; +;; This file is not part of GNU Emacs. +;; +;; This file is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. + +;; THis file is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: +;; +;; This module implements helper functions for team management. It +;; makes it easy to keep track of the work of several people. It +;; keeps context (with whom and where you are) and allows you to use +;; it to metadata to your notes, and to query the tasks associated +;; with the people you are with and the place. +;; +;; See http://juanreyero.com/article/emacs/org-teams.html for a full +;; explanation and configuration instructions. +;; +;;; Configuration +;;;;;;;;;;;;;;;;; +;; +;; In short; your todos use the TODO keyword, your team's use TASK. +;; Your org-todo-keywords should look something like this: +;; +;; (setq org-todo-keywords +;; '((sequence "TODO(t)" "|" "DONE(d)" "CANCELLED(c)") +;; (sequence "TASK(f)" "|" "DONE(d)") +;; (sequence "MAYBE(m)" "|" "CANCELLED(c)"))) +;; +;; It helps to distinguish them by color, like this: +;; +;; (setq org-todo-keyword-faces +;; '(("TODO" . (:foreground "DarkOrange1" :weight bold)) +;; ("MAYBE" . (:foreground "sea green")) +;; ("DONE" . (:foreground "light sea green")) +;; ("CANCELLED" . (:foreground "forest green")) +;; ("TASK" . (:foreground "blue")))) +;; +;; If you want to keep track of stuck projects you should tag your +;; projects with :prj:, and define: +;; +;; (setq org-tags-exclude-from-inheritance '("prj") +;; org-stuck-projects '("+prj/-MAYBE-DONE" +;; ("TODO" "TASK") ())) +;; +;; Define a tag that marks TASK entries as yours: +;; +;; (setq org-sec-me "juanre") +;; +;; Finally, you add the special views to your org-agenda-custom-commands: +;; +;; (setq org-agenda-custom-commands +;; '(("h" "Work todos" tags-todo +;; "-personal-doat={.+}-dowith={.+}/!-TASK" +;; ((org-agenda-todo-ignore-scheduled t))) +;; ("H" "All work todos" tags-todo "-personal/!-TASK-MAYBE" +;; ((org-agenda-todo-ignore-scheduled nil))) +;; ("A" "Work todos with doat or dowith" tags-todo +;; "-personal+doat={.+}|dowith={.+}/!-TASK" +;; ((org-agenda-todo-ignore-scheduled nil))) +;; ("j" "TODO dowith and TASK with" +;; ((org-sec-with-view "TODO dowith") +;; (org-sec-where-view "TODO doat") +;; (org-sec-assigned-with-view "TASK with") +;; (org-sec-stuck-with-view "STUCK with"))) +;; ("J" "Interactive TODO dowith and TASK with" +;; ((org-sec-who-view "TODO dowith"))))) +;; +;;; Usage +;;;;;;;;; +;; +;; Do C-c w to say with whom you are meeting (a space-separated list +;; of names). Maybe do also C-c W to say where you are. Then do C-c a +;; j to see: +;; - Todo items defined with TODO (ie, mine) in which the +;; =dowith= property matches any of the people with me. +;; - Todo items defined with TODO in which the =doat= property +;; matches my current location. +;; - Todo items defined with TASK that are tagged with the name +;; of any of the people with me (this is, assigned to them). +;; - Stuck projects tagged with the name of the people with me. +;; +;; Use C-c j to add meta-data with the people with me, the +;; location and the time to entries. + +(require 'org) + +(defvar org-sec-me nil + "Tag that defines TASK todo entries associated to me") + +(defvar org-sec-with nil + "Value of the :with: property when doing an + org-sec-tag-entry. Change it with org-sec-set-with, + set to C-c w. Defaults to org-sec-me") + +(defvar org-sec-where "" + "Value of the :at: property when doing an + org-sec-tag-entry. Change it with org-sec-set-with, + set to C-c W") + +(defvar org-sec-with-history '() + "History list of :with: properties") + +(defvar org-sec-where-history '() + "History list of :where: properties") + +(defun org-sec-set-with () + "Changes the value of the org-sec-with variable for use in the + next call of org-sec-tag-entry. Leave it empty to default to + org-sec-me (you)." + (interactive) + (setq org-sec-with (let ((w (read-string "With: " nil + 'org-sec-with-history ""))) + (if (string= w "") + nil + w)))) +(global-set-key "\C-cw" 'org-sec-set-with) + +(defun org-sec-set-where () + "Changes the value of the org-sec-where variable for use + in the next call of org-sec-tag-entry." + (interactive) + (setq org-sec-where + (read-string "Where: " nil + 'org-sec-where-history ""))) +(global-set-key "\C-cW" 'org-sec-set-where) + +(defun org-sec-set-dowith () + "Sets the value of the dowith property." + (interactive) + (let ((do-with + (read-string "Do with: " + nil 'org-sec-dowith-history ""))) + (unless (string= do-with "") + (org-entry-put nil "dowith" do-with)))) +(global-set-key "\C-cd" 'org-sec-set-dowith) + +(defun org-sec-set-doat () + "Sets the value of the doat property." + (interactive) + (let ((do-at (read-string "Do at: " + nil 'org-sec-doat-history ""))) + (unless (string= do-at "") + (org-entry-put nil "doat" do-at)))) +(global-set-key "\C-cD" 'org-sec-set-doat) + +(defun org-sec-tag-entry () + "Adds a :with: property with the value of org-sec-with if + defined, an :at: property with the value of org-sec-where + if defined, and an :on: property with the current time." + (interactive) + (save-excursion + (org-entry-put nil "on" (format-time-string + (org-time-stamp-format 'long) + (current-time))) + (unless (string= org-sec-where "") + (org-entry-put nil "at" org-sec-where)) + (if org-sec-with + (org-entry-put nil "with" org-sec-with)))) +(global-set-key "\C-cj" 'org-sec-tag-entry) + +(defun join (lst sep &optional pre post) + (mapconcat (function (lambda (x) (concat pre x post))) lst sep)) + +(defun org-sec-get-with () + (if org-sec-with + org-sec-with + org-sec-me)) + +(defun org-sec-with-view (par &optional who) + "Select tasks marked as dowith=who, where who + defaults to the value of org-sec-with." + (org-tags-view '(4) (join (split-string (if who + who + (org-sec-get-with))) + "|" "dowith=\"" "\""))) + +(defun org-sec-where-view (par) + "Select tasks marked as doat=org-sec-where." + (org-tags-view '(4) (concat "doat={" org-sec-where "}"))) + +(defun org-sec-assigned-with-view (par &optional who) + "Select tasks assigned to who, by default org-sec-with." + (org-tags-view '(4) + (concat (join (split-string (if who + who + (org-sec-get-with))) + "|") + "/TASK"))) + +(defun org-sec-stuck-with-view (par &optional who) + "Select stuck projects assigned to who, by default + org-sec-with." + (let ((org-stuck-projects + `(,(concat "+prj+" + (join (split-string (if who + who + (org-sec-get-with))) "|") + "/-MAYBE-DONE") + ("TODO" "TASK") ()))) + (org-agenda-list-stuck-projects))) + +(defun org-sec-who-view (par) + "Builds agenda for a given user. Queried. " + (let ((who (read-string "Build todo for user/tag: " + "" "" ""))) + (org-sec-with-view "TODO dowith" who) + (org-sec-assigned-with-view "TASK with" who) + (org-sec-stuck-with-view "STUCK with" who))) + +(provide 'org-secretary) + +;;; org-secretary.el ends here diff --git a/contrib/lisp/org-static-mathjax.el b/contrib/lisp/org-static-mathjax.el new file mode 100644 index 0000000..29f2cfe --- /dev/null +++ b/contrib/lisp/org-static-mathjax.el @@ -0,0 +1,171 @@ +;;; org-static-mathjax.el --- Muse-like tags in Org-mode +;; +;; Author: Jan Böker + +;; This elisp code integrates Static MathJax into the +;; HTML export process of Org-mode. +;; +;; The supporting files for this package are in contrib/scripts/staticmathjax +;; Please read the README.org file in that directory for more information. + +;; To use it, evaluate it on startup, add the following to your .emacs: + +;; (require 'org-static-mathjax) +;; +;; You will then have to customize the following two variables: +;; - org-static-mathjax-app-ini-path +;; - org-static-mathjax-local-mathjax-path +;; +;; If xulrunner is not in your $PATH, you will also need to customize +;; org-static-mathjax-xulrunner-path. +;; +;; If everything is setup correctly, you can trigger Static MathJax on +;; export to HTML by adding the following line to your Org file: +;; #+StaticMathJax: embed-fonts:nil output-file-name:"embedded-math.html" +;; +;; You can omit either argument. +;; embed-fonts defaults to nil. If you do not specify output-file-name, +;; the exported file is overwritten with the static version. +;; +;; If embed-fonts is non-nil, the fonts are embedded directly into the +;; output file using data: URIs. +;; +;; output-file-name specifies the file name of the static version. You +;; can use any arbitrary lisp form here, for example: +;; output-file-name:(concat (file-name-sans-extension buffer-file-name) "-static.html") +;; +;; The StaticMathJax XULRunner application expects a UTF-8 encoded +;; input file. If the static version displays random characters instead +;; of your math, add the following line at the top of your Org file: +;; -*- coding: utf-8; -*- +;; +;; License: GPL v2 or later + +(defcustom org-static-mathjax-app-ini-path + (or (expand-file-name + "../scripts/staticmatchjax/application.ini" + (file-name-directory (or load-file-name buffer-file-name))) + "") + "Path to \"application.ini\" of the Static MathJax XULRunner application. +If you have extracted StaticMathJax to e.g. ~/.local/staticmathjax, set +this to ~/.local/staticmathjax/application.ini" + :type 'string) + +(defcustom org-static-mathjax-xulrunner-path + "xulrunner" + "Path to your xulrunner binary" + :type 'string) + +(defcustom org-static-mathjax-local-mathjax-path + "" + "Extract the MathJax zip file somewhere on your local +hard drive and specify the path here. + +The directory has to be writeable, as org-static-mathjax +creates a temporary file there during export." + :type 'string) + +(defvar org-static-mathjax-debug + nil + "If non-nil, org-static-mathjax will print some debug messages") + +(defun org-static-mathjax-hook-installer () + "Installs org-static-mathjax-process in after-save-hook. + +Sets the following buffer-local variables for org-static-mathjax-process to pick up: +org-static-mathjax-mathjax-path: The path to MathJax.js as used by Org HTML export +org-static-mathjax-options: The string given with #+STATICMATHJAX: in the file" + (let ((static-mathjax-option-string (plist-get opt-plist :static-mathjax))) + (if static-mathjax-option-string + (progn (set (make-local-variable 'org-static-mathjax-options) static-mathjax-option-string) + (set (make-local-variable 'org-static-mathjax-mathjax-path) + (nth 1 (assq 'path org-export-html-mathjax-options))) + (let ((mathjax-options (plist-get opt-plist :mathjax))) + (if mathjax-options + (if (string-match "\\ +;; Keywords: outlines, hypermedia, calendar, wp, games +;; Homepage: http://orgmode.org +;; Version: 0.01 +;; +;; This file is not yet part of GNU Emacs. +;; +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: +;; +;; This is a quick hack to create and solve SUDOKU games in org tables. +;; +;; Commands: +;; +;; org-sudoku-create Create a new SUDOKU game +;; org-sudoku-solve-field Solve the field at point in a SUDOKU game +;; (this is for cheeting when you are stuck) +;; org-sudoku-solve Solve the entire game +;; + +;;; Code + +(require 'org) +(require 'org-table) + +;;; Customization + +(defvar org-sudoku-size 9 + "The size of the sudoku game, 9 for a 9x9 game and 4 for a 4x4 game. +Larger games do not seem to work because of limited resources - even though +the algorithm is general.") + +(defvar org-sudoku-timeout 2.0 + "Timeout for finding a solution when creating a new game. +After this timeout, the program starts over from scratch to create +a game.") + +;;; Interactive commands + +(defun org-sudoku-create (nfilled) + "Create a sudoku game." + (interactive "nNumber of pre-filled fields: ") + (let ((sizesq org-sudoku-size) + game) + (loop for i from 1 to org-sudoku-size do + (loop for j from 1 to org-sudoku-size do + (push (list (cons i j) 0) game))) + (setq game (nreverse game)) + (random t) + (setq game (org-sudoku-build-allowed game)) + (setq game (org-sudoku-set-field game (cons 1 1) + (1+ (random org-sudoku-size)))) + (catch 'solved + (let ((cnt 0)) + (while t + (catch 'abort + (message "Attempt %d to create a game" (setq cnt (1+ cnt))) + (setq game1 (org-sudoku-deep-copy game)) + (setq game1 (org-sudoku-solve-game + game1 'random (+ (float-time) org-sudoku-timeout))) + (when game1 + (setq game game1) + (throw 'solved t)))))) + (let ((sqrtsize (floor (sqrt org-sudoku-size)))) + (loop for i from 1 to org-sudoku-size do + (insert "| |\n") + (if (and (= (mod i sqrtsize) 0) (< i org-sudoku-size)) + (insert "|-\n"))) + (backward-char 5) + (org-table-align)) + (while (> (length game) nfilled) + (setq game (delete (nth (1+ (random (length game))) game) game))) + (mapc (lambda (e) + (org-table-put (caar e) (cdar e) (int-to-string (nth 1 e)))) + game) + (org-table-align) + (org-table-goto-line 1) + (org-table-goto-column 1) + (message "Enjoy!"))) + +(defun org-sudoku-solve () + "Solve the sudoku game in the table at point." + (interactive) + (unless (org-at-table-p) + (error "not at a table")) + (let (game) + (setq game (org-sudoku-get-game)) + (setq game (org-sudoku-build-allowed game)) + (setq game (org-sudoku-solve-game game)) + ;; Insert the values + (mapc (lambda (e) + (org-table-put (caar e) (cdar e) (int-to-string (nth 1 e)))) + game) + (org-table-align))) + +(defun org-sudoku-solve-field () + "Just solve the field at point. +This works by solving the whole game, then inserting only the single field." + (interactive) + (unless (org-at-table-p) + (error "Not at a table")) + (org-table-check-inside-data-field) + (let ((i (org-table-current-dline)) + (j (org-table-current-column)) + game) + (setq game (org-sudoku-get-game)) + (setq game (org-sudoku-build-allowed game)) + (setq game (org-sudoku-solve-game game)) + (if game + (progn + (org-table-put i j (number-to-string + (nth 1 (assoc (cons i j) game))) + 'align) + (org-table-goto-line i) + (org-table-goto-column j)) + (error "No solution")))) + +;;; Internal functions + +(defun org-sudoku-get-game () + "Interpret table at point as sudoku game and read it. +A game structure is returned." + (let (b e g i j game) + + (org-table-goto-line 1) + (org-table-goto-column 1) + (setq b (point)) + (org-table-goto-line org-sudoku-size) + (org-table-goto-column org-sudoku-size) + (setq e (point)) + (setq g (org-table-copy-region b e)) + (setq i 0 j 0) + (mapc (lambda (c) + (setq i (1+ i) j 0) + (mapc + (lambda (v) + (setq j (1+ j)) + (push (list (cons i j) + (string-to-number v)) + game)) + c)) + g) + (nreverse game))) + +(defun org-sudoku-build-allowed (game) + (let (i j v numbers) + (loop for i from 1 to org-sudoku-size do + (push i numbers)) + (setq numbers (nreverse numbers)) + ;; add the lists of allowed values for each entry + (setq game (mapcar + (lambda (e) + (list (car e) (nth 1 e) + (if (= (nth 1 e) 0) + (copy-sequence numbers) + nil))) + game)) + ;; remove the known values from the list of allowed values + (mapc + (lambda (e) + (setq i (caar e) j (cdar e) v (cadr e)) + (when (> v 0) + ;; We do have a value here + (mapc + (lambda (f) + (setq a (assoc f game)) + (setf (nth 2 a) (delete v (nth 2 a)))) + (cons (cons i j) (org-sudoku-rel-fields i j))))) + game) + game)) + +(defun org-sudoku-find-next-constrained-field (game) + (setq game (mapcar (lambda (e) (if (nth 2 e) e nil)) game)) + (setq game (delq nil game)) + (let (va vb la lb) + (setq game + (sort game (lambda (a b) + (setq va (nth 1 a) vb (nth 1 b) + la (length (nth 2 a)) lb (length (nth 2 b))) + (cond + ((and (= va 0) (> vb 0)) t) + ((and (> va 0) (= vb 0)) nil) + ((not (= (* va vb) 0)) nil) + (t (< la lb)))))) + (if (or (not game) (> 0 (nth 1 (car game)))) + nil + (caar game)))) + +(defun org-sudoku-solve-game (game &optional random stop-at) + "Solve GAME. +If RANDOM is non-nit, select candidates randomly from a fields option. +If RANDOM is nil, always start with the first allowed value and try +solving from there. +STOP-AT can be a float time, the solver will abort at that time because +it is probably stuck." + (let (e v v1 allowed next g) + (when (and stop-at + (> (float-time) stop-at)) + (setq game nil) + (throw 'abort nil)) + (while (setq next (org-sudoku-find-next-constrained-field game)) + (setq e (assoc next game) + v (nth 1 e) + allowed (nth 2 e)) + (catch 'solved + (if (= (length allowed) 1) + (setq game (org-sudoku-set-field game next (car allowed))) + (while allowed + (setq g (org-sudoku-deep-copy game)) + (if (not random) + (setq v1 (car allowed)) + (setq v1 (nth (random (length allowed)) allowed))) + (setq g (org-sudoku-set-field g next v1)) + (setq g (org-sudoku-solve-game g random stop-at)) + (when g + (setq game g) + (throw 'solved g))) + (setq game nil)))) + (if (or (not game) + (org-sudoku-unknown-field-p game)) + nil + game))) + +(defun org-sudoku-unknown-field-p (game) + "Are there still unknown fields in the game?" + (delq nil (mapcar (lambda (e) (if (> (nth 1 e) 0) nil t)) game))) + +(defun org-sudoku-deep-copy (game) + "Make a copy of the game so that manipulating the copy does not change the parent." + (mapcar (lambda(e) + (list (car e) (nth 1 e) (copy-sequence (nth 2 e)))) + game)) + +(defun org-sudoku-set-field (game field value) + "Put VALUE into FIELD, and tell related fields that they cannot be VALUE." + (let (i j) + (setq i (car field) j (cdr field)) + (setq a (assoc field game)) + (setf (nth 1 a) value) + (setf (nth 2 a) nil) + + ;; Remove value from all related fields + (mapc + (lambda (f) + (setq a (assoc f game)) + (setf (nth 2 a) (delete value (nth 2 a)))) + (org-sudoku-rel-fields i j)) + game)) + +(defun org-sudoku-rel-fields (i j) + "Compute the list of related fields for field (i j)." + (let ((sqrtsize (floor (sqrt org-sudoku-size))) + ll imin imax jmin jmax f) + (setq f (cons i j)) + (loop for ii from 1 to org-sudoku-size do + (or (= ii i) (push (cons ii j) ll))) + (loop for jj from 1 to org-sudoku-size do + (or (= jj j) (push (cons i jj) ll))) + (setq imin (1+ (* sqrtsize (/ (1- i) sqrtsize))) + imax (+ imin sqrtsize -1)) + (setq jmin (1+ (* sqrtsize (/ (1- j) sqrtsize))) + jmax (+ jmin sqrtsize -1)) + (loop for ii from imin to imax do + (loop for jj from jmin to jmax do + (setq ff (cons ii jj)) + (or (equal ff f) + (member ff ll) + (push ff ll)))) + ll)) + +;;; org-sudoku ends here diff --git a/contrib/lisp/org-toc.el b/contrib/lisp/org-toc.el new file mode 100644 index 0000000..3f37cb8 --- /dev/null +++ b/contrib/lisp/org-toc.el @@ -0,0 +1,488 @@ +;;; org-toc.el --- Table of contents for Org-mode buffer + +;; Copyright 2007-2012 Free Software Foundation, Inc. +;; +;; Author: Bastien Guerry +;; Keywords: Org table of contents +;; Homepage: http://www.cognition.ens.fr/~guerry/u/org-toc.el +;; Version: 0.8 + +;; This file is not part of GNU Emacs. + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, write to the Free Software +;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +;;; Commentary: + +;; This library implements a browsable table of contents for Org files. + +;; Put this file into your load-path and the following into your ~/.emacs: +;; (require 'org-toc) + +;;; Code: + +(provide 'org-toc) +(eval-when-compile + (require 'cl)) + +;;; Custom variables: +(defvar org-toc-base-buffer nil) +(defvar org-toc-columns-shown nil) +(defvar org-toc-odd-levels-only nil) +(defvar org-toc-config-alist nil) +(defvar org-toc-cycle-global-status nil) +(defalias 'org-show-table-of-contents 'org-toc-show) + +(defgroup org-toc nil + "Options concerning the browsable table of contents of Org-mode." + :tag "Org TOC" + :group 'org) + +(defcustom org-toc-default-depth 1 + "Default depth when invoking `org-toc-show' without argument." + :group 'org-toc + :type '(choice + (const :tag "same as base buffer" nil) + (integer :tag "level"))) + +(defcustom org-toc-follow-mode nil + "Non-nil means navigating through the table of contents will +move the point in the Org buffer accordingly." + :group 'org-toc + :type 'boolean) + +(defcustom org-toc-info-mode nil + "Non-nil means navigating through the table of contents will +show the properties for the current headline in the echo-area." + :group 'org-toc + :type 'boolean) + +(defcustom org-toc-show-subtree-mode nil + "Non-nil means show subtree when going to headline or following +it while browsing the table of contents." + :group 'org-toc + :type '(choice + (const :tag "show subtree" t) + (const :tag "show entry" nil))) + +(defcustom org-toc-recenter-mode t + "Non-nil means recenter the Org buffer when following the +headlines in the TOC buffer." + :group 'org-toc + :type 'boolean) + +(defcustom org-toc-recenter 0 + "Where to recenter the Org buffer when unfolding a subtree. +This variable is only used when `org-toc-recenter-mode' is set to +'custom. A value >=1000 will call recenter with no arg." + :group 'org-toc + :type 'integer) + +(defcustom org-toc-info-exclude '("ALLTAGS") + "A list of excluded properties when displaying info in the +echo-area. The COLUMNS property is always exluded." + :group 'org-toc + :type 'lits) + +;;; Org TOC mode: +(defvar org-toc-mode-map (make-sparse-keymap) + "Keymap for `org-toc-mode'.") + +(defun org-toc-mode () + "A major mode for browsing the table of contents of an Org buffer. + +\\{org-toc-mode-map}" + (interactive) + (kill-all-local-variables) + (use-local-map org-toc-mode-map) + (setq mode-name "Org TOC") + (setq major-mode 'org-toc-mode)) + +;; toggle modes +(define-key org-toc-mode-map "f" 'org-toc-follow-mode) +(define-key org-toc-mode-map "S" 'org-toc-show-subtree-mode) +(define-key org-toc-mode-map "s" 'org-toc-store-config) +(define-key org-toc-mode-map "g" 'org-toc-restore-config) +(define-key org-toc-mode-map "i" 'org-toc-info-mode) +(define-key org-toc-mode-map "r" 'org-toc-recenter-mode) + +;; navigation keys +(define-key org-toc-mode-map "p" 'org-toc-previous) +(define-key org-toc-mode-map "n" 'org-toc-next) +(define-key org-toc-mode-map [(left)] 'org-toc-previous) +(define-key org-toc-mode-map [(right)] 'org-toc-next) +(define-key org-toc-mode-map [(up)] 'org-toc-previous) +(define-key org-toc-mode-map [(down)] 'org-toc-next) +(define-key org-toc-mode-map "1" (lambda() (interactive) (org-toc-show 1 (point)))) +(define-key org-toc-mode-map "2" (lambda() (interactive) (org-toc-show 2 (point)))) +(define-key org-toc-mode-map "3" (lambda() (interactive) (org-toc-show 3 (point)))) +(define-key org-toc-mode-map "4" (lambda() (interactive) (org-toc-show 4 (point)))) +(define-key org-toc-mode-map " " 'org-toc-goto) +(define-key org-toc-mode-map "q" 'org-toc-quit) +(define-key org-toc-mode-map "x" 'org-toc-quit) +;; go to the location and stay in the base buffer +(define-key org-toc-mode-map [(tab)] 'org-toc-jump) +(define-key org-toc-mode-map "v" 'org-toc-jump) +;; go to the location and delete other windows +(define-key org-toc-mode-map [(return)] + (lambda() (interactive) (org-toc-jump t))) + +;; special keys +(define-key org-toc-mode-map "c" 'org-toc-columns) +(define-key org-toc-mode-map "?" 'org-toc-help) +(define-key org-toc-mode-map ":" 'org-toc-cycle-subtree) +(define-key org-toc-mode-map "\C-c\C-o" 'org-open-at-point) +;; global cycling in the base buffer +(define-key org-toc-mode-map (kbd "C-S-") + 'org-toc-cycle-base-buffer) +;; subtree cycling in the base buffer +(define-key org-toc-mode-map [(control tab)] + (lambda() (interactive) (org-toc-goto nil t))) + +;;; Toggle functions: +(defun org-toc-follow-mode () + "Toggle follow mode in a `org-toc-mode' buffer." + (interactive) + (setq org-toc-follow-mode (not org-toc-follow-mode)) + (message "Follow mode is %s" + (if org-toc-follow-mode "on" "off"))) + +(defun org-toc-info-mode () + "Toggle info mode in a `org-toc-mode' buffer." + (interactive) + (setq org-toc-info-mode (not org-toc-info-mode)) + (message "Info mode is %s" + (if org-toc-info-mode "on" "off"))) + +(defun org-toc-show-subtree-mode () + "Toggle show subtree mode in a `org-toc-mode' buffer." + (interactive) + (setq org-toc-show-subtree-mode (not org-toc-show-subtree-mode)) + (message "Show subtree mode is %s" + (if org-toc-show-subtree-mode "on" "off"))) + +(defun org-toc-recenter-mode (&optional line) + "Toggle recenter mode in a `org-toc-mode' buffer. If LINE is +specified, then make `org-toc-recenter' use this value." + (interactive "P") + (setq org-toc-recenter-mode (not org-toc-recenter-mode)) + (when (numberp line) + (setq org-toc-recenter-mode t) + (setq org-toc-recenter line)) + (message "Recenter mode is %s" + (if org-toc-recenter-mode + (format "on, line %d" org-toc-recenter) "off"))) + +(defun org-toc-cycle-subtree () + "Locally cycle a headline through two states: 'children and +'folded" + (interactive) + (let ((beg (point)) + (end (save-excursion (end-of-line) (point))) + (ov (car (overlays-at (point)))) + status) + (if ov (setq status (overlay-get ov 'status)) + (setq ov (make-overlay beg end))) + ;; change the folding status of this headline + (cond ((or (null status) (eq status 'folded)) + (show-children) + (message "CHILDREN") + (overlay-put ov 'status 'children)) + ((eq status 'children) + (show-branches) + (message "BRANCHES") + (overlay-put ov 'status 'branches)) + (t (hide-subtree) + (message "FOLDED") + (overlay-put ov 'status 'folded))))) + +;;; Main show function: +;; FIXME name this org-before-first-heading-p? +(defun org-toc-before-first-heading-p () + "Before first heading?" + (save-excursion + (null (re-search-backward org-outline-regexp-bol nil t)))) + +;;;###autoload +(defun org-toc-show (&optional depth position) + "Show the table of contents of the current Org-mode buffer." + (interactive "P") + (if (eq major-mode 'org-mode) + (progn (setq org-toc-base-buffer (current-buffer)) + (setq org-toc-odd-levels-only org-odd-levels-only)) + (if (eq major-mode 'org-toc-mode) + (org-pop-to-buffer-same-window org-toc-base-buffer) + (error "Not in an Org buffer"))) + ;; create the new window display + (let ((pos (or position + (save-excursion + (if (org-toc-before-first-heading-p) + (progn (re-search-forward org-outline-regexp-bol nil t) + (match-beginning 0)) + (point)))))) + (setq org-toc-cycle-global-status org-cycle-global-status) + (delete-other-windows) + (and (get-buffer "*org-toc*") (kill-buffer "*org-toc*")) + (switch-to-buffer-other-window + (make-indirect-buffer org-toc-base-buffer "*org-toc*")) + ;; make content before 1st headline invisible + (goto-char (point-min)) + (let* ((beg (point-min)) + (end (and (re-search-forward "^\\*" nil t) + (1- (match-beginning 0)))) + (ov (make-overlay beg end)) + (help (format "Table of contents for %s (press ? for a quick help):\n" + (buffer-name org-toc-base-buffer)))) + (overlay-put ov 'invisible t) + (overlay-put ov 'before-string help)) + ;; build the browsable TOC + (cond (depth + (let* ((dpth (if org-toc-odd-levels-only + (1- (* depth 2)) depth))) + (org-content dpth) + (setq org-toc-cycle-global-status + `(org-content ,dpth)))) + ((null org-toc-default-depth) + (if (eq org-toc-cycle-global-status 'overview) + (progn (org-overview) + (setq org-cycle-global-status 'overview) + (run-hook-with-args 'org-cycle-hook 'overview)) + (progn (org-overview) + ;; FIXME org-content to show only headlines? + (org-content) + (setq org-cycle-global-status 'contents) + (run-hook-with-args 'org-cycle-hook 'contents)))) + (t (let* ((dpth0 org-toc-default-depth) + (dpth (if org-toc-odd-levels-only + (1- (* dpth0 2)) dpth0))) + (org-content dpth) + (setq org-toc-cycle-global-status + `(org-content ,dpth))))) + (goto-char pos)) + (move-beginning-of-line nil) + (org-toc-mode) + (shrink-window-if-larger-than-buffer) + (setq buffer-read-only t)) + +;;; Navigation functions: +(defun org-toc-goto (&optional jump cycle) + "From Org TOC buffer, follow the targeted subtree in the Org window. +If JUMP is non-nil, go to the base buffer. +If JUMP is 'delete, go to the base buffer and delete other windows. +If CYCLE is non-nil, cycle the targeted subtree in the Org window." + (interactive) + (let ((pos (point)) + (toc-buf (current-buffer))) + (switch-to-buffer-other-window org-toc-base-buffer) + (goto-char pos) + (if cycle (org-cycle) + (progn (org-overview) + (if org-toc-show-subtree-mode + (org-show-subtree) + (org-show-entry)) + (org-show-context))) + (if org-toc-recenter-mode + (if (>= org-toc-recenter 1000) (recenter) + (recenter org-toc-recenter))) + (cond ((null jump) + (switch-to-buffer-other-window toc-buf)) + ((eq jump 'delete) + (delete-other-windows))))) + +(defun org-toc-cycle-base-buffer () + "Call `org-cycle' with a prefix argument in the base buffer." + (interactive) + (switch-to-buffer-other-window org-toc-base-buffer) + (org-cycle t) + (other-window 1)) + +(defun org-toc-jump (&optional delete) + "From Org TOC buffer, jump to the targeted subtree in the Org window. +If DELETE is non-nil, delete other windows when in the Org buffer." + (interactive "P") + (if delete (org-toc-goto 'delete) + (org-toc-goto t))) + +(defun org-toc-previous () + "Go to the previous headline of the TOC." + (interactive) + (if (save-excursion + (beginning-of-line) + (re-search-backward "^\\*" nil t)) + (outline-previous-visible-heading 1) + (message "No previous heading")) + (if org-toc-info-mode (org-toc-info)) + (if org-toc-follow-mode (org-toc-goto))) + +(defun org-toc-next () + "Go to the next headline of the TOC." + (interactive) + (outline-next-visible-heading 1) + (if org-toc-info-mode (org-toc-info)) + (if org-toc-follow-mode (org-toc-goto))) + +(defun org-toc-quit () + "Quit the current Org TOC buffer." + (interactive) + (kill-this-buffer) + (other-window 1) + (delete-other-windows)) + +;;; Special functions: +(defun org-toc-columns () + "Toggle columns view in the Org buffer from Org TOC." + (interactive) + (let ((indirect-buffer (current-buffer))) + (org-pop-to-buffer-same-window org-toc-base-buffer) + (if (not org-toc-columns-shown) + (progn (org-columns) + (setq org-toc-columns-shown t)) + (progn (org-columns-remove-overlays) + (setq org-toc-columns-shown nil))) + (org-pop-to-buffer-same-window indirect-buffer))) + +(defun org-toc-info () + "Show properties of current subtree in the echo-area." + (interactive) + (let ((pos (point)) + (indirect-buffer (current-buffer)) + props prop msg) + (org-pop-to-buffer-same-window org-toc-base-buffer) + (goto-char pos) + (setq props (org-entry-properties)) + (while (setq prop (pop props)) + (unless (or (equal (car prop) "COLUMNS") + (member (car prop) org-toc-info-exclude)) + (let ((p (car prop)) + (v (cdr prop))) + (if (equal p "TAGS") + (setq v (mapconcat 'identity (split-string v ":" t) " "))) + (setq p (concat p ":")) + (add-text-properties 0 (length p) '(face org-special-keyword) p) + (setq msg (concat msg p " " v " "))))) + (org-pop-to-buffer-same-window indirect-buffer) + (message msg))) + +;;; Store and restore TOC configuration: +(defun org-toc-store-config () + "Store the current status of the tables of contents in +`org-toc-config-alist'." + (interactive) + (let ((file (buffer-file-name org-toc-base-buffer)) + (pos (point)) + (hlcfg (org-toc-get-headlines-status))) + (setq org-toc-config-alist + (delete (assoc file org-toc-config-alist) + org-toc-config-alist)) + (add-to-list 'org-toc-config-alist + `(,file ,pos ,org-toc-cycle-global-status ,hlcfg)) + (message "TOC configuration saved: (%s)" + (if (listp org-toc-cycle-global-status) + (concat "org-content " + (number-to-string + (cadr org-toc-cycle-global-status))) + (symbol-name org-toc-cycle-global-status))))) + +(defun org-toc-restore-config () + "Get the stored status in `org-toc-config-alist' and set the +current table of contents to it." + (interactive) + (let* ((file (buffer-file-name org-toc-base-buffer)) + (conf (cdr (assoc file org-toc-config-alist))) + (pos (car conf)) + (status (cadr conf)) + (hlcfg (caddr conf)) hlcfg0 ov) + (cond ((listp status) + (org-toc-show (cadr status) (point))) + ((eq status 'overview) + (org-overview) + (setq org-cycle-global-status 'overview) + (run-hook-with-args 'org-cycle-hook 'overview)) + (t + (org-overview) + (org-content) + (setq org-cycle-global-status 'contents) + (run-hook-with-args 'org-cycle-hook 'contents))) + (while (setq hlcfg0 (pop hlcfg)) + (save-excursion + (goto-char (point-min)) + (when (search-forward (car hlcfg0) nil t) + (unless (overlays-at (match-beginning 0)) + (setq ov (make-overlay (match-beginning 0) + (match-end 0)))) + (cond ((eq (cdr hlcfg0) 'children) + (show-children) + (message "CHILDREN") + (overlay-put ov 'status 'children)) + ((eq (cdr hlcfg0) 'branches) + (show-branches) + (message "BRANCHES") + (overlay-put ov 'status 'branches)))))) + (goto-char pos) + (if org-toc-follow-mode (org-toc-goto)) + (message "Last TOC configuration restored") + (sit-for 1) + (if org-toc-info-mode (org-toc-info)))) + +(defun org-toc-get-headlines-status () + "Return an alist of headlines and their associated folding +status." + (let (output ovs) + (save-excursion + (goto-char (point-min)) + (while (and (not (eobp)) + (goto-char (next-overlay-change (point)))) + (when (looking-at org-outline-regexp-bol) + (add-to-list + 'output + (cons (buffer-substring-no-properties + (match-beginning 0) + (save-excursion + (end-of-line) (point))) + (overlay-get + (car (overlays-at (point))) 'status)))))) + ;; return an alist like (("* Headline" . 'status)) + output)) + +;; In Org TOC buffer, hide headlines below the first level. +(defun org-toc-help () + "Display a quick help message in the echo-area for `org-toc-mode'." + (interactive) + (let ((st-start 0) + (help-message + "\[space\] show heading \[1-4\] hide headlines below this level +\[TAB\] jump to heading \[f\] toggle follow mode (currently %s) +\[return\] jump and delete others windows \[i\] toggle info mode (currently %s) +\[S-TAB\] cycle subtree (in Org) \[S\] toggle show subtree mode (currently %s) +\[C-S-TAB\] global cycle (in Org) \[r\] toggle recenter mode (currently %s) +\[:\] cycle subtree (in TOC) \[c\] toggle column view (currently %s) +\[n/p\] next/previous heading \[s\] save TOC configuration +\[q\] quit the TOC \[g\] restore last TOC configuration")) + (while (string-match "\\[[^]]+\\]" help-message st-start) + (add-text-properties (match-beginning 0) + (match-end 0) '(face bold) help-message) + (setq st-start (match-end 0))) + (message help-message + (if org-toc-follow-mode "on" "off") + (if org-toc-info-mode "on" "off") + (if org-toc-show-subtree-mode "on" "off") + (if org-toc-recenter-mode (format "on, line %s" org-toc-recenter) "off") + (if org-toc-columns-shown "on" "off")))) + + +;;;;########################################################################## +;;;; User Options, Variables +;;;;########################################################################## + +;;; org-toc.el ends here diff --git a/contrib/lisp/org-track.el b/contrib/lisp/org-track.el new file mode 100644 index 0000000..1d12862 --- /dev/null +++ b/contrib/lisp/org-track.el @@ -0,0 +1,219 @@ +;;; org-track.el --- Track the most recent Org-mode version available. +;; +;; Copyright (C) 2009-2012 +;; Free Software Foundation, Inc. +;; +;; Author: Bastien Guerry +;; Eric S Fraga +;; Sebastian Rose +;; The Worg people http://orgmode.org/worg/ +;; Keywords: outlines, hypermedia, calendar, wp +;; Homepage: http://orgmode.org +;; Version: 6.29a +;; +;; Released under the GNU General Public License version 3 +;; see: http://www.gnu.org/licenses/gpl-3.0.html +;; +;; This file is not part of GNU Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: +;; +;; Download the latest development tarball, unpack and optionally compile it +;; +;; Usage: +;; +;; (require 'org-track) +;; +;; ;; ... somewhere in your setup (use customize): +;; +;; (setq org-track-directory "~/test/") +;; (setq org-track-compile-sources nil) +;; (setq org-track-remove-package t) +;; +;; M-x org-track-update RET + + + +(require 'url-parse) +(require 'url-handlers) +(autoload 'url-file-local-copy "url-handlers") +(autoload 'url-generic-parse-url "url-parse") + + + + + +;;; Variables: + +(defgroup org-track nil + "Track the most recent Org-mode version available. + +To use org-track, adjust `org-track-directory'. +Org will download the archived latest git version for you, +unpack it into that directory (i.e. a subdirectory +`org-mode/' is added), create the autoloads file +`org-install.el' for you and, optionally, compile the +sources. +All you'll have to do is call `M-x org-track-update' from +time to time." + :version "22.1" + :group 'org) + +(defcustom org-track-directory "~/.emacs.d/org/lisp" + "Directory where your org-mode/ directory lives. +If that directory does not exist, it will be created." + :type 'directory) + +(defcustom org-track-compile-sources t + "If `nil', never compile org-sources. +Org will only create the autoloads file `org-install.el' for +you then. If `t', compile the sources, too. +Note, that emacs preferes compiled elisp files over +non-compiled ones." + :type 'boolean) + +(defcustom org-track-org-url "http://orgmode.org/" + "The URL where the package to download can be found. +Please append a slash." + :type 'string) + +(defcustom org-track-org-package "org-latest.tar.gz" + "The basename of the package you use. +Defaults to the development version of Org-mode. +This should be a *.tar.gz package, since emacs provides all +you need to unpack it." + :type 'string) + +(defcustom org-track-remove-package nil + "Remove org-latest.tar.gz after updates?" + :type 'boolean) + + + + + +;;; Frontend + +(defun org-track-update () + "Update to current Org-mode version. +Also, generate autoloads and evtl. compile the sources." + (interactive) + (let* ((base (file-truename org-track-directory)) + (org-exists (file-exists-p + (file-truename + (concat base "/org-mode/lisp/org.el")))) + (nobase (not (file-directory-p + (file-truename org-track-directory))))) + (if nobase + (when (y-or-n-p + (format "Directory %s does not exist. Create it?" base)) + (make-directory base t) + (setq nobase nil))) + (if nobase + (message "Not creating %s - giving up." org-track-directory) + (condition-case err + (progn + (org-track-fetch-package) + (org-track-compile-org)) + (error (message "%s" (error-message-string err))))))) + + + + +;;; tar related functions + +;; `url-retrieve-synchronously' fetches files synchronously. How can we ensure +;; that? If the maintainers of that package decide, that an assynchronous +;; download might be better??? (used by `url-file-local-copy') + +;;;###autoload +(defun org-track-fetch-package (&optional directory) + "Fetch Org package depending on `org-track-fetch-package-extension'. +If DIRECTORY is defined, unpack the package there, i.e. add the +subdirectory org-mode/ to DIRECTORY." + (interactive "Dorg-track directory: ") + (let* ((pack (concat + (if (string-match "/$" org-track-org-url) + org-track-org-url + (concat org-track-org-url "/")) + org-track-org-package)) + (base (file-truename + (or directory org-track-directory))) + (target (file-truename + (concat base "/" org-track-org-package))) + url download tarbuff) + (message "Fetching to %s - this might take some time..." base) + (setq url (url-generic-parse-url pack)) + (setq download (url-file-local-copy url)) ;; errors if fail + (copy-file download target t) + (delete-file download) + ;; (tar-mode) leads to dubious errors. We use the auto-mode-alist to + ;; ensure tar-mode is used: + (add-to-list 'auto-mode-alist '("org-latest\\.tar\\.gz\\'" . tar-mode)) + (setq tarbuff (find-file target)) + (with-current-buffer tarbuff ;; with-temp-buffer does not work with tar-mode?? + (tar-untar-buffer)) + (kill-buffer tarbuff) + (if org-track-remove-package + (delete-file target)))) + + + + +;;; Compile Org-mode sources + + +;;;###autoload +(defun org-track-compile-org (&optional directory) + "Compile all *.el files that come with org-mode. +Generate the autoloads file `org-install.el'. + +DIRECTORY is where the directory org-mode/ lives (i.e. the + parent directory of your local repo." + (interactive) + ;; file-truename expands the filename and removes double slash, if exists: + (setq directory (file-truename + (concat + (or directory + (file-truename (concat org-track-directory "/org-mode/lisp"))) + "/"))) + (add-to-list 'load-path directory) + (let ((list-of-org-files (file-expand-wildcards (concat directory "*.el")))) + ;; create the org-install file + (require 'autoload) + (setq esf/org-install-file (concat directory "org-install.el")) + (find-file esf/org-install-file) + (erase-buffer) + (mapc (lambda (x) + (generate-file-autoloads x)) + list-of-org-files) + (insert "\n(provide (quote org-install))\n") + (save-buffer) + (kill-buffer) + (byte-compile-file esf/org-install-file t) + + (mapc (lambda (f) + (if (file-exists-p (concat f "c")) + (delete-file (concat f "c")))) + list-of-org-files) + (if org-track-compile-sources + (mapc (lambda (f) (byte-compile-file f)) list-of-org-files)))) + + +(provide 'org-track) + +;;; org-track.el ends here diff --git a/contrib/lisp/org-velocity.el b/contrib/lisp/org-velocity.el new file mode 100644 index 0000000..7425d32 --- /dev/null +++ b/contrib/lisp/org-velocity.el @@ -0,0 +1,724 @@ +;;; org-velocity.el --- something like Notational Velocity for Org. + +;; Copyright (C) 2010-2012 Paul M. Rodriguez + +;; Author: Paul M. Rodriguez +;; Created: 2010-05-05 +;; Version: 3.0 + +;; This file is not part of GNU Emacs. + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation version 2. + +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; For a copy of the GNU General Public License, search the Internet, +;; or write to the Free Software Foundation, Inc., 59 Temple Place, +;; Suite 330, Boston, MA 02111-1307 USA + +;;; Commentary: +;; Org-Velocity.el is an interface for Org inspired by the minimalist +;; notetaking program Notational Velocity. The idea is to let you +;; amass and access brief notes on many subjects with minimal fuss. +;; Each note is an entry in an ordinary Org file. + +;; Org-Velocity can be used in two ways: when called outside Org, to +;; store and access notes in a designated bucket file; or, when called +;; inside Org, as a method for navigating any Org file. (Setting the +;; option `org-velocity-always-use-bucket' disables navigation inside +;; Org files by default, although you can still force this behavior by +;; calling `org-velocity-read' with an argument.) + +;; Org-Velocity prompts for search terms in the minibuffer. A list of +;; headings of entries whose text matches your search is updated as +;; you type; you can end the search and visit an entry at any time by +;; clicking on its heading. + +;; RET displays the results. If there are no matches, Org-Velocity +;; offers to create a new entry with your search string as its +;; heading. If there are matches, it displays a list of results where +;; the heading of each matching entry is hinted with a number or +;; letter; clicking a result, or typing the matching hint, opens the +;; entry for editing in an indirect buffer. 0 forces a new entry; RET +;; reopens the search for editing. + +;; You can customize every step in this process, including the search +;; method, completion for search terms, and templates for creating new +;; entries; M-x customize-group RET org-velocity RET to see all the +;; options. + +;; Thanks to Richard Riley, Carsten Dominik, Bastien Guerry, and Jeff +;; Horn for their suggestions. + +;;; Usage: +;; (require 'org-velocity) +;; (setq org-velocity-bucket (expand-file-name "bucket.org" org-directory)) +;; (global-set-key (kbd "C-c v") 'org-velocity) + +;;; Code: +(require 'org) +(require 'button) +(require 'electric) +(require 'dabbrev) +(eval-when-compile (require 'cl)) + +(defgroup org-velocity nil + "Notational Velocity-style interface for Org." + :tag "Org-Velocity" + :group 'outlines + :group 'hypermedia + :group 'org) + +(defcustom org-velocity-bucket "" + "Where is the bucket file?" + :group 'org-velocity + :type 'file) + +(defcustom org-velocity-search-is-incremental t + "Show results incrementally when possible?" + :group 'org-velocity + :type 'boolean + :safe 'booleanp) + +(defcustom org-velocity-show-previews t + "Show previews of the text of each heading?" + :group 'velocity + :type 'boolean + :safe 'booleanp) + +(defcustom org-velocity-exit-on-match nil + "When searching incrementally, exit on a single match?" + :group 'org-velocity + :type 'boolean + :safe 'booleanp) + +(defcustom org-velocity-force-new nil + "Should exiting the minibuffer with C-j force a new entry?" + :group 'org-velocity + :type 'boolean + :safe 'booleanp) + +(defcustom org-velocity-use-search-ring t + "Push search to `search-ring' when visiting an entry? + +This means that C-s C-s will take you directly to the first +instance of the search string." + :group 'org-velocity + :type 'boolean + :safe 'booleanp) + +(defcustom org-velocity-always-use-bucket nil + "Use bucket file even when called from an Org buffer?" + :group 'org-velocity + :type 'boolean + :safe 'booleanp) + +(defcustom org-velocity-use-completion nil + "Use completion? + +Notwithstanding the value of this option, calling +`dabbrev-expand' always completes against the text of the bucket +file." + :group 'org-velocity + :type '(choice + (const :tag "Do not use completion" nil) + (const :tag "Use completion" t)) + :safe 'booleanp) + +(defcustom org-velocity-search-method 'phrase + "Match on whole phrase, any word, or all words?" + :group 'org-velocity + :type '(choice + (const :tag "Match whole phrase" phrase) + (const :tag "Match any word" any) + (const :tag "Match all words" all) + (const :tag "Match a regular expression" regexp)) + :safe (lambda (v) (memq v '(phrase any all regexp)))) + +(defcustom org-velocity-capture-templates + '(("v" + "Velocity entry" + entry + (file "") + "* %:search\n\n%i%?")) + "Use these template with `org-capture'. +Meanwhile `org-default-notes-file' is bound to `org-velocity-bucket-file'. +The keyword :search inserts the current search. +See the documentation for `org-capture-templates'." + :group 'org-velocity + :type (or (get 'org-capture-templates 'custom-type) 'list)) + +(defsubst org-velocity-grab-preview () + "Grab preview of a subtree. +The length of the preview is determined by `window-width'. + +Replace all contiguous whitespace with single spaces." + (let ((start (progn + (forward-line 1) + (if (looking-at org-property-start-re) + (re-search-forward org-property-end-re) + (1- (point)))))) + (mapconcat + #'identity + (split-string + (buffer-substring-no-properties + start + (min + (+ start (window-width)) + (point-max)))) + " "))) + +(defstruct org-velocity-heading buffer position name level preview) + +(defsubst org-velocity-nearest-heading (position) + "Return last heading at POSITION. +If there is no last heading, return nil." + (save-excursion + (goto-char position) + (re-search-backward org-velocity-heading-regexp) + (let ((components (org-heading-components))) + (make-org-velocity-heading + :buffer (current-buffer) + :position (point) + :name (nth 4 components) + :level (nth 0 components) + :preview (if org-velocity-show-previews + (org-velocity-grab-preview)))))) + +(defconst org-velocity-index + (eval-when-compile + (nconc (number-sequence 49 57) ;numbers + (number-sequence 97 122) ;lowercase letters + (number-sequence 65 90))) ;uppercase letters + "List of chars for indexing results.") + +(defconst org-velocity-match-buffer-name "*Velocity matches*") + +(defconst org-velocity-heading-regexp "^\\* " + "Regexp to match only top-level headings.") + +(defvar org-velocity-search nil + "Variable to bind to current search.") + +(defun org-velocity-buffer-file-name (&optional buffer) + "Return the name of the file BUFFER saves to. +Same as function `buffer-file-name' unless BUFFER is an indirect +buffer or a minibuffer. In the former case, return the file name +of the base buffer; in the latter, return the file name of +`minibuffer-selected-window' (or its base buffer)." + (let ((buffer (if (minibufferp buffer) + (window-buffer (minibuffer-selected-window)) + buffer))) + (buffer-file-name + (or (buffer-base-buffer buffer) + buffer)))) + +(defun org-velocity-minibuffer-contents () + "Return the contents of the minibuffer when it is active." + (if (active-minibuffer-window) + (with-current-buffer (window-buffer (active-minibuffer-window)) + (minibuffer-contents)))) + +(defsubst org-velocity-singlep (object) + "Return t when OBJECT is a list or sequence of one element." + (if (consp object) + (null (cdr object)) + (= (length object) 1))) + +(defun org-velocity-bucket-file () + "Return the proper file for Org-Velocity to search. +If `org-velocity-always-use-bucket' is t, use bucket file; +complain if missing. Otherwise, if an Org file is current, then +use it." + (let ((org-velocity-bucket + (when org-velocity-bucket (expand-file-name org-velocity-bucket))) + (buffer + (let ((buffer-file (org-velocity-buffer-file-name))) + (when buffer-file + ;; Use the target in capture buffers. + (org-find-base-buffer-visiting buffer-file))))) + (if org-velocity-always-use-bucket + (or org-velocity-bucket (error "Bucket required but not defined")) + (if (and (eq (buffer-local-value 'major-mode (or buffer (current-buffer))) + 'org-mode) + (org-velocity-buffer-file-name)) + (org-velocity-buffer-file-name) + (or org-velocity-bucket + (error "No bucket and not an Org file")))))) + +(defvar org-velocity-bucket-buffer nil) + +(defsubst org-velocity-bucket-buffer () + (or org-velocity-bucket-buffer + (find-file-noselect (org-velocity-bucket-file)))) + +(defsubst org-velocity-match-buffer () + "Return the proper buffer for Org-Velocity to display in." + (get-buffer-create org-velocity-match-buffer-name)) + +(defun org-velocity-beginning-of-headings () + "Goto the start of the first heading." + (goto-char (point-min)) + ;; If we are before the first heading we could still be at the + ;; first heading. + (or (looking-at org-velocity-heading-regexp) + (re-search-forward org-velocity-heading-regexp))) + +(defun org-velocity-make-indirect-buffer (heading) + "Make or switch to an indirect buffer visiting HEADING." + + (let* ((bucket (org-velocity-heading-buffer heading)) + (name (org-velocity-heading-name heading)) + (existing (get-buffer name))) + (if (and existing (buffer-base-buffer existing) + (equal (buffer-base-buffer existing) bucket)) + existing + (make-indirect-buffer + bucket + (generate-new-buffer-name (org-velocity-heading-name heading)))))) + +(defun org-velocity-capture () + "Record a note with `org-capture'." + (let ((org-capture-templates + org-velocity-capture-templates)) + (org-capture nil + ;; This is no longer automatically selected. + (when (org-velocity-singlep org-capture-templates) + (caar org-capture-templates))) + (if org-capture-mode (rename-buffer org-velocity-search t)))) + +(defvar org-velocity-saved-winconf nil) +(make-variable-buffer-local 'org-velocity-saved-winconf) + +(defun org-velocity-edit-entry (heading) + "Edit entry at HEADING in an indirect buffer." + (let ((winconf (current-window-configuration))) + (let ((buffer (org-velocity-make-indirect-buffer heading))) + (with-current-buffer buffer + (let ((org-inhibit-startup t)) + (org-mode)) + (setq org-velocity-saved-winconf winconf) + (goto-char (org-velocity-heading-position heading)) + (narrow-to-region (point) + (save-excursion + (org-end-of-subtree t) + (point))) + (goto-char (point-min)) + (add-hook 'org-ctrl-c-ctrl-c-hook 'org-velocity-dismiss nil t)) + (pop-to-buffer buffer) + (set (make-local-variable 'header-line-format) + (format "%s Use C-c C-c to finish." + (abbreviate-file-name + (buffer-file-name + (org-velocity-heading-buffer heading)))))))) + +(defun org-velocity-dismiss () + "Save current entry and close indirect buffer." + (let ((winconf org-velocity-saved-winconf)) + (prog1 t ;Tell hook we're done. + (save-buffer) + (kill-buffer) + (when (window-configuration-p winconf) + (set-window-configuration winconf))))) + +(defun org-velocity-visit-button (button) + (run-hooks 'mouse-leave-buffer-hook) + (if org-velocity-use-search-ring + (add-to-history 'search-ring + (button-get button 'search) + search-ring-max)) + (org-velocity-edit-entry (button-get button 'match))) + +(define-button-type 'org-velocity-button + 'action #'org-velocity-visit-button) + +(defsubst org-velocity-buttonize (heading) + "Insert HEADING as a text button with no hints." + (insert-text-button + (propertize (org-velocity-heading-name heading) 'face 'link) + :type 'org-velocity-button + 'match heading + 'search org-velocity-search)) + +(defsubst org-velocity-insert-preview (heading) + (when org-velocity-show-previews + (insert-char ?\ 1) + (insert + (propertize + (org-velocity-heading-preview heading) + 'face 'shadow)))) + +(defsubst* org-velocity-present-match (&key hint match) + (with-current-buffer (org-velocity-match-buffer) + (when hint (insert "#" hint " ")) + (org-velocity-buttonize match) + (org-velocity-insert-preview match) + (newline))) + +(defun org-velocity-generic-search (search &optional hide-hints) + "Display any entry containing SEARCH." + (let ((hints org-velocity-index) matches) + (block nil + (while (and hints (re-search-forward search nil t)) + (let ((match (org-velocity-nearest-heading (point)))) + (org-velocity-present-match + :hint (unless hide-hints (car hints)) + :match match) + (push match matches)) + (setq hints (cdr hints)) + (unless (re-search-forward org-velocity-heading-regexp nil t) + (return)))) + (nreverse matches))) + +(defun* org-velocity-all-search (search &optional hide-hints max) + "Display only entries containing every word in SEARCH." + (let ((keywords (mapcar 'regexp-quote (split-string search))) + (hints org-velocity-index) + matches) + (org-map-entries + (lambda () + ;; Return if we've run out of hints. + (when (null hints) + (return-from org-velocity-all-search (nreverse matches))) + ;; Only search the subtree once. + (setq org-map-continue-from + (save-excursion + (goto-char (line-end-position)) + (if (re-search-forward org-velocity-heading-regexp nil t) + (line-end-position) + (point-max)))) + (when (loop for word in keywords + always (save-excursion + (re-search-forward + (concat "\\<" word "\\>") + org-map-continue-from t))) + (let ((match (org-velocity-nearest-heading (match-end 0)))) + (org-velocity-present-match + :hint (unless hide-hints (car hints)) + :match match) + (push match matches) + (setq hints (cdr hints)))))) + (nreverse matches))) + +(defun* org-velocity-present (search &key hide-hints) + "Buttonize matches for SEARCH in `org-velocity-match-buffer'. +If HIDE-HINTS is non-nil, display entries without indices. SEARCH +binds `org-velocity-search'. + +Return matches." + (if (and (stringp search) (not (string= "" search))) + ;; Fold case when the search string is all lowercase. + (let ((case-fold-search (equal search (downcase search))) + (truncate-partial-width-windows t)) + (with-current-buffer (org-velocity-match-buffer) + (erase-buffer) + ;; Permanent locals. + (setq cursor-type nil + truncate-lines t)) + (prog1 + (with-current-buffer (org-velocity-bucket-buffer) + (let ((inhibit-point-motion-hooks t) + (inhibit-field-text-motion t)) + (save-excursion + (org-velocity-beginning-of-headings) + (case org-velocity-search-method + (all (org-velocity-all-search search hide-hints)) + (phrase (org-velocity-generic-search + (concat "\\<" (regexp-quote search)) + hide-hints)) + (any (org-velocity-generic-search + (concat "\\<" + (regexp-opt (split-string search))) + hide-hints)) + (regexp (condition-case lossage + (org-velocity-generic-search + search hide-hints) + (invalid-regexp + (minibuffer-message "%s" lossage)))))))) + (with-current-buffer (org-velocity-match-buffer) + (goto-char (point-min))))) + (with-current-buffer (org-velocity-match-buffer) + (erase-buffer)))) + +(defun org-velocity-store-link () + "Function for `org-store-link-functions'." + (if org-velocity-search + (org-store-link-props + :search org-velocity-search))) + +(add-hook 'org-store-link-functions 'org-velocity-store-link) + +(defun* org-velocity-create (search &key ask) + "Create new heading named SEARCH. +If ASK is non-nil, ask first." + (when (or (null ask) (y-or-n-p "No match found, create? ")) + (let ((org-velocity-search search) + (org-default-notes-file (org-velocity-bucket-file)) + ;; save a stored link + org-store-link-plist) + (org-velocity-capture)) + search)) + +(defun org-velocity-engine (search) + "Display a list of headings where SEARCH occurs." + (let ((org-velocity-search search)) + (unless (or + (not (stringp search)) + (string= "" search)) ;exit on empty string + (case + (if (and org-velocity-force-new (eq last-command-event ?\C-j)) + :force + (let ((matches (org-velocity-present search))) + (cond ((null matches) :new) + ((org-velocity-singlep matches) :follow) + (t :prompt)))) + (:prompt (progn + (pop-to-buffer (org-velocity-match-buffer)) + (let ((hint (org-velocity-electric-read-hint))) + (when hint (case hint + (:edit (org-velocity-read nil search)) + (:force (org-velocity-create search)) + (otherwise (org-velocity-activate-button hint))))))) + (:new (unless (org-velocity-create search :ask t) + (org-velocity-read nil search))) + (:force (org-velocity-create search)) + (:follow (if (y-or-n-p "One match, follow? ") + (progn + (set-buffer (org-velocity-match-buffer)) + (goto-char (point-min)) + (button-activate (next-button (point)))) + (org-velocity-read nil search))))))) + +(defun org-velocity-position (item list) + "Return first position of ITEM in LIST." + (loop for elt in list + for i from 0 + when (equal elt item) + return i)) + +(defun org-velocity-activate-button (char) + "Go to button on line number associated with CHAR in `org-velocity-index'." + (goto-char (point-min)) + (forward-line (org-velocity-position char org-velocity-index)) + (goto-char + (button-start + (next-button (point)))) + (message "%s" (button-label (button-at (point)))) + (button-activate (button-at (point)))) + +(defun org-velocity-electric-undefined () + "Complain about an undefined key." + (interactive) + (message "%s" + (substitute-command-keys + "\\[org-velocity-electric-new] for new entry, +\\[org-velocity-electric-edit] to edit search, +\\[scroll-up] to scroll up, +\\[scroll-down] to scroll down, +\\[keyboard-quit] to quit.")) + (sit-for 4)) + +(defun org-velocity-electric-follow (ev) + "Follow a hint indexed by keyboard event EV." + (interactive (list last-command-event)) + (if (not (> (org-velocity-position ev org-velocity-index) + (1- (count-lines (point-min) (point-max))))) + (throw 'org-velocity-select ev) + (call-interactively 'org-velocity-electric-undefined))) + +(defun org-velocity-electric-click (ev) + "Follow hint indexed by a mouse event EV." + (interactive "e") + (throw 'org-velocity-select + (nth (1- (count-lines + (point-min) + (posn-point (event-start ev)))) + org-velocity-index))) + +(defun org-velocity-electric-edit () + "Edit the search string." + (interactive) + (throw 'org-velocity-select :edit)) + +(defun org-velocity-electric-new () + "Force a new entry." + (interactive) + (throw 'org-velocity-select :force)) + +(defvar org-velocity-electric-map + (let ((map (make-sparse-keymap))) + (define-key map [t] 'org-velocity-electric-undefined) + (loop for c in org-velocity-index + do (define-key map (char-to-string c) 'org-velocity-electric-follow)) + (define-key map "0" 'org-velocity-electric-new) + (define-key map "\C-v" 'scroll-up) + (define-key map "\M-v" 'scroll-down) + (define-key map (kbd "RET") 'org-velocity-electric-edit) + (define-key map [mouse-1] 'org-velocity-electric-click) + (define-key map [mouse-2] 'org-velocity-electric-click) + (define-key map [escape] 'keyboard-quit) + (define-key map "\C-h" 'help-command) + map)) + +(defun org-velocity-electric-read-hint () + "Read index of button electrically." + (with-current-buffer (org-velocity-match-buffer) + (use-local-map org-velocity-electric-map) + (catch 'org-velocity-select + (Electric-command-loop 'org-velocity-select "Follow: ")))) + +(defvar org-velocity-incremental-keymap + (let ((map (make-sparse-keymap))) + (define-key map [mouse-1] 'org-velocity-click-for-incremental) + (define-key map [mouse-2] 'org-velocity-click-for-incremental) + (define-key map "\C-v" 'scroll-up) + (define-key map "\M-v" 'scroll-down) + map)) + +(defun org-velocity-click-for-incremental () + "Jump out of search and select hint clicked on." + (interactive) + (let ((ev last-command-event)) + (org-velocity-activate-button + (nth (- (count-lines + (point-min) + (posn-point (event-start ev))) 2) + org-velocity-index))) + (throw 'click (current-buffer))) + +(defun org-velocity-displaying-completions-p () + "Is there a *Completions* buffer showing?" + (get-window-with-predicate + (lambda (w) + (eq (buffer-local-value 'major-mode (window-buffer w)) + 'completion-list-mode)))) + +(defun org-velocity-update () + "Display results of search without hinting. +Stop searching once there are more matches than can be displayed." + (unless (org-velocity-displaying-completions-p) + (let* ((search (org-velocity-minibuffer-contents)) + (matches (org-velocity-present search :hide-hints t))) + (cond ((null matches) + (select-window (active-minibuffer-window)) + (unless (or (null search) (string= "" search)) + (minibuffer-message "No match; RET to create"))) + ((and (org-velocity-singlep matches) + org-velocity-exit-on-match) + (throw 'click search)) + (t + (with-current-buffer (org-velocity-match-buffer) + (use-local-map org-velocity-incremental-keymap))))))) + +(defvar dabbrev--last-abbrev) + +(defun org-velocity-dabbrev-completion-list (abbrev) + "Return all dabbrev completions for ABBREV." + ;; This is based on `dabbrev-completion'. + (dabbrev--reset-global-variables) + (setq dabbrev--last-abbrev abbrev) + (dabbrev--find-all-expansions abbrev case-fold-search)) + +(defvar org-velocity-local-completion-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map minibuffer-local-completion-map) + (define-key map " " 'self-insert-command) + (define-key map [remap minibuffer-complete] 'minibuffer-complete-word) + map) + "Keymap for completion with `completing-read'.") + +(defun org-velocity-read-with-completion (prompt) + "Completing read with PROMPT." + (let ((minibuffer-local-completion-map + org-velocity-local-completion-map) + (completion-no-auto-exit t) + (crm-separator " ")) + (funcall + (case org-velocity-search-method + (phrase #'completing-read) + (any #'completing-read-multiple) + (all #'completing-read-multiple)) + prompt + (completion-table-dynamic + 'org-velocity-dabbrev-completion-list)))) + +(defun org-velocity-read-string (prompt &optional initial-input) + "Read string with PROMPT followed by INITIAL-INPUT." + ;; The use of initial inputs to the minibuffer is deprecated (see + ;; `read-from-minibuffer'), but in this case it is the user-friendly + ;; thing to do. + (minibuffer-with-setup-hook + (lexical-let ((initial-input initial-input)) + (lambda () + (and initial-input (insert initial-input)) + (goto-char (point-max)))) + (if (eq org-velocity-search-method 'regexp) + (read-regexp prompt) + (if org-velocity-use-completion + (org-velocity-read-with-completion prompt) + (read-string prompt))))) + +(defun org-velocity-incremental-read (prompt) + "Read string with PROMPT and display results incrementally." + (let ((res + (unwind-protect + (let* ((match-window (display-buffer (org-velocity-match-buffer))) + (org-velocity-index + ;; Truncate the index to the size of the buffer to be + ;; displayed. + (with-selected-window match-window + (if (> (window-height) (length org-velocity-index)) + ;; (subseq org-velocity-index 0 (window-height)) + (let ((hints (copy-sequence org-velocity-index))) + (setcdr (nthcdr (window-height) hints) nil) + hints) + org-velocity-index)))) + (catch 'click + (add-hook 'post-command-hook 'org-velocity-update) + (if (eq org-velocity-search-method 'regexp) + (read-regexp prompt) + (if org-velocity-use-completion + (org-velocity-read-with-completion prompt) + (read-string prompt))))) + (remove-hook 'post-command-hook 'org-velocity-update)))) + (if (bufferp res) (org-pop-to-buffer-same-window res) res))) + +(defun org-velocity (arg &optional search) + "Read a search string SEARCH for Org-Velocity interface. +This means that a buffer will display all headings where SEARCH +occurs, where one can be selected by a mouse click or by typing +its index. If SEARCH does not occur, then a new heading may be +created named SEARCH. + +If `org-velocity-bucket' is defined and +`org-velocity-always-use-bucket' is non-nil, then the bucket file +will be used; otherwise, this will work when called in any Org +file. Calling with ARG forces current file." + (interactive "P") + (let ((org-velocity-always-use-bucket + (if arg nil org-velocity-always-use-bucket))) + ;; complain if inappropriate + (assert (org-velocity-bucket-file)) + (let ((org-velocity-bucket-buffer + (find-file-noselect (org-velocity-bucket-file)))) + (unwind-protect + (let ((dabbrev-search-these-buffers-only + (list (org-velocity-bucket-buffer)))) + (org-velocity-engine + (if org-velocity-search-is-incremental + (org-velocity-incremental-read "Velocity search: ") + (org-velocity-read-string "Velocity search: " search)))) + (progn + (kill-buffer (org-velocity-match-buffer)) + (delete-other-windows)))))) + +(defalias 'org-velocity-read 'org-velocity) + +(provide 'org-velocity) + +;;; org-velocity.el ends here diff --git a/contrib/lisp/org-wikinodes.el b/contrib/lisp/org-wikinodes.el new file mode 100644 index 0000000..bdc3e34 --- /dev/null +++ b/contrib/lisp/org-wikinodes.el @@ -0,0 +1,340 @@ +;;; org-wikinodes.el --- Wiki-like CamelCase links to outline nodes + +;; Copyright (C) 2010-2012 Free Software Foundation, Inc. + +;; Author: Carsten Dominik +;; Keywords: outlines, hypermedia, calendar, wp +;; Homepage: http://orgmode.org +;; Version: 7.01trans +;; +;; This file is not part of GNU Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(require 'org) +(eval-when-compile + (require 'cl)) + +(defgroup org-wikinodes nil + "Wiki-like CamelCase links words to outline nodes in Org mode." + :tag "Org WikiNodes" + :group 'org) + +(defconst org-wikinodes-camel-regexp "\\<[A-Z]+[a-z]+[A-Z]+[a-z]+[a-zA-Z]*\\>" + "Regular expression matching CamelCase words.") + +(defcustom org-wikinodes-active t + "Should CamelCase links be active in the current file?" + :group 'org-wikinodes + :type 'boolean) +(put 'org-wikinodes-active 'safe-local-variable 'booleanp) + +(defcustom org-wikinodes-scope 'file + "The scope of searches for wiki targets. +Allowed values are: + +file Search for targets in the current file only +directory Search for targets in all org files in the current directory" + :group 'org-wikinodes + :type '(choice + (const :tag "Find targets in current file" file) + (const :tag "Find targets in current directory" directory))) + +(defcustom org-wikinodes-create-targets 'query + "Non-nil means create Wiki target when following a wiki link fails. +Allowed values are: + +nil never create node, just throw an error if the target does not exist +query ask the user what to do +t create the node in the current buffer +\"file.org\" create the node in the file \"file.org\", in the same directory + +If you are using wiki links across files, you need to set `org-wikinodes-scope' +to `directory'." + :group 'org-wikinodes + :type '(choice + (const :tag "Never automatically create node" nil) + (const :tag "In current file" t) + (file :tag "In one special file\n") + (const :tag "Query the user" query))) + +;;; Link activation + +(defun org-wikinodes-activate-links (limit) + "Activate CamelCase words as links to Wiki targets." + (when org-wikinodes-active + (let (case-fold-search) + (if (re-search-forward org-wikinodes-camel-regexp limit t) + (if (equal (char-after (point-at-bol)) ?*) + (progn + ;; in heading - deactivate flyspell + (org-remove-flyspell-overlays-in (match-beginning 0) + (match-end 0)) + (add-text-properties (match-beginning 0) (match-end 0) + '(org-no-flyspell t)) + t) + ;; this is a wiki link + (org-remove-flyspell-overlays-in (match-beginning 0) + (match-end 0)) + (add-text-properties (match-beginning 0) (match-end 0) + (list 'mouse-face 'highlight + 'face 'org-link + 'keymap org-mouse-map + 'help-echo "Wiki Link")) + t))))) + +;;; Following links and creating non-existing target nodes + +(defun org-wikinodes-open-at-point () + "Check if the cursor is on a Wiki link and follow the link. + +This function goes into `org-open-at-point-functions'." + (and org-wikinodes-active + (not (org-at-heading-p)) + (let (case-fold-search) (org-in-regexp org-wikinodes-camel-regexp)) + (progn (org-wikinodes-follow-link (match-string 0)) t))) + +(defun org-wikinodes-follow-link (target) + "Follow a wiki link to TARGET. + +This need to be found as an exact headline match, either in the current +buffer, or in any .org file in the current directory, depending on the +variable `org-wikinodes-scope'. + +If a target headline is not found, it may be created according to the +setting of `org-wikinodes-create-targets'." + (if current-prefix-arg (org-wikinodes-clear-directory-targets-cache)) + (let ((create org-wikinodes-create-targets) + visiting buffer m pos file rpl) + (setq pos + (or (org-find-exact-headline-in-buffer target (current-buffer)) + (and (eq org-wikinodes-scope 'directory) + (setq file (org-wikinodes-which-file + target (file-name-directory (buffer-file-name)))) + (org-find-exact-headline-in-buffer + target (or (get-file-buffer file) + (find-file-noselect file)))))) + (if pos + (progn + (org-mark-ring-push (point)) + (org-goto-marker-or-bmk pos) + (move-marker pos nil)) + (when (eq create 'query) + (if (eq org-wikinodes-scope 'directory) + (progn + (message "Node \"%s\" does not exist. Should it be created? +\[RET] in this buffer [TAB] in another file [q]uit" target) + (setq rpl (read-char-exclusive)) + (cond + ((member rpl '(?\C-g ?q)) (error "Abort")) + ((equal rpl ?\C-m) (setq create t)) + ((equal rpl ?\C-i) + (setq create (file-name-nondirectory + (read-file-name "Create in file: ")))) + (t (error "Invalid selection")))) + (if (y-or-n-p (format "Create new node \"%s\" in current buffer? " + target)) + (setq create t) + (error "Abort")))) + + (cond + ((not create) + ;; We are not allowed to create the new node + (error "No match for link to \"%s\"" target)) + ((stringp create) + ;; Make new node in another file + (org-mark-ring-push (point)) + (org-pop-to-buffer-same-window (find-file-noselect create)) + (goto-char (point-max)) + (or (bolp) (newline)) + (insert "\n* " target "\n") + (backward-char 1) + (org-wikinodes-add-target-to-cache target) + (message "New Wiki target `%s' created in file \"%s\"" + target create)) + (t + ;; Make new node in current buffer + (org-mark-ring-push (point)) + (goto-char (point-max)) + (or (bolp) (newline)) + (insert "* " target "\n") + (backward-char 1) + (org-wikinodes-add-target-to-cache target) + (message "New Wiki target `%s' created in current buffer" + target)))))) + +;;; The target cache + +(defvar org-wikinodes-directory-targets-cache nil) + +(defun org-wikinodes-clear-cache-when-on-target () + "When on a headline that is a Wiki target, clear the cache." + (when (and (org-at-heading-p) + (org-in-regexp (format org-complex-heading-regexp-format + org-wikinodes-camel-regexp)) + (org-in-regexp org-wikinodes-camel-regexp)) + (org-wikinodes-clear-directory-targets-cache) + t)) + +(defun org-wikinodes-clear-directory-targets-cache () + "Clear the cache where to find wiki targets." + (interactive) + (setq org-wikinodes-directory-targets-cache nil) + (message "Wiki target cache cleared, so that it will update when used again")) + +(defun org-wikinodes-get-targets () + "Return a list of all wiki targets in the current buffer." + (let ((re (format org-complex-heading-regexp-format + org-wikinodes-camel-regexp)) + (case-fold-search nil) + targets) + (save-excursion + (save-restriction + (widen) + (goto-char (point-min)) + (while (re-search-forward re nil t) + (push (org-match-string-no-properties 4) targets)))) + (nreverse targets))) + +(defun org-wikinodes-get-links-for-directory (dir) + "Return an alist that connects wiki links to files in directory DIR." + (let ((files (directory-files dir nil "\\`[^.#].*\\.org\\'")) + (org-inhibit-startup t) + target-file-alist file visiting m buffer) + (while (setq file (pop files)) + (setq visiting (org-find-base-buffer-visiting file)) + (setq buffer (or visiting (find-file-noselect file))) + (with-current-buffer buffer + (mapc + (lambda (target) + (setq target-file-alist (cons (cons target file) target-file-alist))) + (org-wikinodes-get-targets))) + (or visiting (kill-buffer buffer))) + target-file-alist)) + +(defun org-wikinodes-add-target-to-cache (target &optional file) + (setq file (or file buffer-file-name (error "No file for new wiki target"))) + (set-text-properties 0 (length target) nil target) + (let ((dir (file-name-directory (expand-file-name file))) + a) + (setq a (assoc dir org-wikinodes-directory-targets-cache)) + (if a + ;; Push the new target onto the existing list + (push (cons target (expand-file-name file)) (cdr a)) + ;; Call org-wikinodes-which-file so that the cache will be filled + (org-wikinodes-which-file target dir)))) + +(defun org-wikinodes-which-file (target &optional directory) + "Return the file for wiki headline TARGET DIRECTORY. +If there is no such wiki target, return nil." + (let* ((directory (expand-file-name (or directory default-directory))) + (founddir (assoc directory org-wikinodes-directory-targets-cache)) + (foundfile (cdr (assoc target (cdr founddir))))) + (or foundfile + (and (push (cons directory (org-wikinodes-get-links-for-directory directory)) + org-wikinodes-directory-targets-cache) + (cdr (assoc target (cdr (assoc directory + org-wikinodes-directory-targets-cache)))))))) + +;;; Exporting Wiki links + +(defvar target) +(defvar target-alist) +(defvar last-section-target) +(defvar org-export-target-aliases) +(defun org-wikinodes-set-wiki-targets-during-export () + (let ((line (buffer-substring (point-at-bol) (point-at-eol))) + (case-fold-search nil) + wtarget a) + (when (string-match (format org-complex-heading-regexp-format + org-wikinodes-camel-regexp) + line) + (setq wtarget (match-string 4 line)) + (push (cons wtarget target) target-alist) + (setq a (or (assoc last-section-target org-export-target-aliases) + (progn + (push (list last-section-target) + org-export-target-aliases) + (car org-export-target-aliases)))) + (push (caar target-alist) (cdr a))))) + +(defvar org-current-export-file) +(defun org-wikinodes-process-links-for-export () + "Process Wiki links in the export preprocess buffer. + +Try to find target matches in the wiki scope and replace CamelCase words +with working links." + (let ((re org-wikinodes-camel-regexp) + (case-fold-search nil) + link file) + (goto-char (point-min)) + (while (re-search-forward re nil t) + (org-if-unprotected-at (match-beginning 0) + (unless (save-match-data + (or (org-at-heading-p) + (org-in-regexp org-bracket-link-regexp) + (org-in-regexp org-plain-link-re) + (org-in-regexp "<<[^<>]+>>"))) + (setq link (match-string 0)) + (delete-region (match-beginning 0) (match-end 0)) + (save-match-data + (cond + ((org-find-exact-headline-in-buffer link (current-buffer)) + ;; Found in current buffer + (insert (format "[[#%s][%s]]" link link))) + ((eq org-wikinodes-scope 'file) + ;; No match in file, and other files are not allowed + (insert (format "%s" link))) + ((setq file + (and (org-string-nw-p org-current-export-file) + (org-wikinodes-which-file + link (file-name-directory org-current-export-file)))) + ;; Match in another file in the current directory + (insert (format "[[file:%s::%s][%s]]" file link link))) + (t ;; No match for this link + (insert (format "%s" link)))))))))) + +;;; Hook the WikiNode mechanism into Org + +;; `C-c C-o' should follow wiki links +(add-hook 'org-open-at-point-functions 'org-wikinodes-open-at-point) + +;; `C-c C-c' should clear the cache +(add-hook 'org-ctrl-c-ctrl-c-hook 'org-wikinodes-clear-cache-when-on-target) + +;; Make Wiki haeding create additional link names for headlines +(add-hook 'org-export-define-heading-targets-headline-hook + 'org-wikinodes-set-wiki-targets-during-export) + +;; Turn Wiki links into links the exporter will treat correctly +(add-hook 'org-export-preprocess-after-radio-targets-hook + 'org-wikinodes-process-links-for-export) + +;; Activate CamelCase words as part of Org mode font lock + +(defun org-wikinodes-add-to-font-lock-keywords () + "Add wikinode CamelCase highlighting to `org-font-lock-extra-keywords'." + (let ((m (member '(org-activate-plain-links) org-font-lock-extra-keywords))) + (if m + (setcdr m (cons '(org-wikinodes-activate-links) (cdr m))) + (message + "Failed to add wikinodes to `org-font-lock-extra-keywords'.")))) + +(add-hook 'org-font-lock-set-keywords-hook + 'org-wikinodes-add-to-font-lock-keywords) + +(provide 'org-wikinodes) + +;;; org-wikinodes.el ends here diff --git a/contrib/lisp/org2rem.el b/contrib/lisp/org2rem.el new file mode 100644 index 0000000..3052462 --- /dev/null +++ b/contrib/lisp/org2rem.el @@ -0,0 +1,651 @@ +;;; org2rem.el --- Convert org appointments into reminders + +;; Copyright (C) 2006-2012 Free Software Foundation, Inc. + +;; Author: Bastien Guerry and Shatad Pratap +;; Keywords: outlines, hypermedia, calendar, wp +;; Homepage: http://orgmode.org +;; Version: 6.09a +;; +;; This file is not part of GNU Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: + +;; (require 'org2rem) +;; To export, do +;; +;; M-x org2rem-combine-agenda-files +;; +;; Then you can use reming like this: +;; +;; $ remind ~/org.rem +;; +;; If you want to use this regualrly, try in .emacs +;; +;; (add-hook 'org-mode-hook +;; (lambda() (add-hook 'after-save-hook +;; 'org-export-remind-all-agenda-files t t))) + +(require 'org) +(require 'org-agenda) +(require 'org-exp) +(eval-and-compile + (require 'cl)) + +(defgroup org2rem nil + "Options specific for Remind export of Org-mode files." + :tag "Org Export Remind" + :group 'org-export) + +(defcustom org-combined-agenda-remind-file "~/org.rem" + "The file name for the Remind file covering all agenda files. +This file is created with the command \\[org2rem-all-agenda-files]. +The file name should be absolute, the file will be overwritten without warning." + :group 'org2rem + :type 'file) + +(defcustom org-remind-combined-name "OrgMode" + "Calendar name for the combined Remind representing all agenda files." + :group 'org2rem + :type 'string) + +(defcustom org-remind-use-deadline '(event-if-not-todo todo-due) + "Contexts where Remind export should use a deadline time stamp. +This is a list with several symbols in it. Valid symbol are: + +event-if-todo Deadlines in TODO entries become calendar events. +event-if-not-todo Deadlines in non-TODO entries become calendar events. +todo-due Use deadlines in TODO entries as due-dates" + :group 'org2rem + :type '(set :greedy t + (const :tag "Deadlines in non-TODO entries become events" + event-if-not-todo) + (const :tag "Deadline in TODO entries become events" + event-if-todo) + (const :tag "Deadlines in TODO entries become due-dates" + todo-due))) + +(defcustom org-remind-use-scheduled '(todo-start) + "Contexts where Remind export should use a scheduling time stamp. +This is a list with several symbols in it. Valid symbol are: + +event-if-todo Scheduling time stamps in TODO entries become an event. +event-if-not-todo Scheduling time stamps in non-TODO entries become an event. +todo-start Scheduling time stamps in TODO entries become start date. + Some calendar applications show TODO entries only after + that date." + :group 'org2rem + :type '(set :greedy t + (const :tag + "SCHEDULED timestamps in non-TODO entries become events" + event-if-not-todo) + (const :tag "SCHEDULED timestamps in TODO entries become events" + event-if-todo) + (const :tag "SCHEDULED in TODO entries become start date" + todo-start))) + +(defcustom org-remind-categories '(local-tags category) + "Items that should be entered into the categories field. +This is a list of symbols, the following are valid: + +category The Org-mode category of the current file or tree +todo-state The todo state, if any +local-tags The tags, defined in the current line +all-tags All tags, including inherited ones." + :group 'org2rem + :type '(repeat + (choice + (const :tag "The file or tree category" category) + (const :tag "The TODO state" todo-state) + (const :tag "Tags defined in current line" local-tags) + (const :tag "All tags, including inherited ones" all-tags)))) + +(defcustom org-remind-include-todo nil + "Non-nil means export to remind files should also cover TODO items." + :group 'org2rem + :type '(choice + (const :tag "None" nil) + (const :tag "Unfinished" t) + (const :tag "All" all))) + +(defcustom org-remind-include-sexps t + "Non-nil means export to Remind files should also cover sexp entries. +These are entries like in the diary, but directly in an Org-mode file." + :group 'org2rem + :type 'boolean) + +(defcustom org-remind-deadline-over-scheduled t + "Non-nil means use deadline as target when both deadline and +scheduled present, vice-versa. Default is Non-nil." + :group 'org2rem + :type 'boolean) + +(defcustom org-remind-escape-percentage t + "Non-nil means % will be escaped, vice-versa. Default is Non-nil." + :group 'org2rem + :type 'boolean) + +(defcustom org-remind-extra-warn-days 3 + "Extra days Remind keep reminding." + :group 'org2rem + :type 'number) + +(defcustom org-remind-advanced-warn-days 3 + "Advanced days Remind start reminding." + :group 'org2rem + :type 'number) + +(defcustom org-remind-suppress-last-newline nil + "Non-nil means suppress last newline REM body. Default is nil." + :group 'org2rem + :type 'boolean) + +(defcustom org-remind-include-body 100 + "Amount of text below headline to be included in Remind export. +This is a number of characters that should maximally be included. +Properties, scheduling and clocking lines will always be removed. +The text will be inserted into the DESCRIPTION field." + :group 'org2rem + :type '(choice + (const :tag "Nothing" nil) + (const :tag "Everything" t) + (integer :tag "Max characters"))) + +(defcustom org-remind-store-UID nil + "Non-nil means store any created UIDs in properties. +The Remind standard requires that all entries have a unique identifyer. +Org will create these identifiers as needed. When this variable is non-nil, +the created UIDs will be stored in the ID property of the entry. Then the +next time this entry is exported, it will be exported with the same UID, +superceeding the previous form of it. This is essential for +synchronization services. +This variable is not turned on by default because we want to avoid creating +a property drawer in every entry if people are only playing with this feature, +or if they are only using it locally." + :group 'org2rem + :type 'boolean) + +;;;; Exporting + +;;; Remind export + +;;;###autoload +(defun org2rem-this-file () + "Export current file as an Remind file. +The Remind file will be located in the same directory as the Org-mode +file, but with extension `.rem'." + (interactive) + (org2rem nil buffer-file-name)) + +;;;###autoload +(defun org2rem-all-agenda-files () + "Export all files in `org-agenda-files' to Remind .rem files. +Each Remind file will be located in the same directory as the Org-mode +file, but with extension `.rem'." + (interactive) + (apply 'org2rem nil (org-agenda-files t))) + +;;;###autoload +(defun org2rem-combine-agenda-files () + "Export all files in `org-agenda-files' to a single combined Remind file. +The file is stored under the name `org-combined-agenda-remind-file'." + (interactive) + (apply 'org2rem t (org-agenda-files t))) + +(defun org2rem (combine &rest files) + "Create Remind files for all elements of FILES. +If COMBINE is non-nil, combine all calendar entries into a single large +file and store it under the name `org-combined-agenda-remind-file'." + (save-excursion + (org-agenda-prepare-buffers files) + (let* ((dir (org-export-directory + :ical (list :publishing-directory + org-export-publishing-directory))) + file rem-file rem-buffer category started org-agenda-new-buffers) + (and (get-buffer "*rem-tmp*") (kill-buffer "*rem-tmp*")) + (when combine + (setq rem-file + (if (file-name-absolute-p org-combined-agenda-remind-file) + org-combined-agenda-remind-file + (expand-file-name org-combined-agenda-remind-file dir)) + rem-buffer (org-get-agenda-file-buffer rem-file)) + (set-buffer rem-buffer) (erase-buffer)) + (while (setq file (pop files)) + (catch 'nextfile + (org-check-agenda-file file) + (set-buffer (org-get-agenda-file-buffer file)) + (unless combine + (setq rem-file (concat (file-name-as-directory dir) + (file-name-sans-extension + (file-name-nondirectory buffer-file-name)) + ".rem")) + (setq rem-buffer (org-get-agenda-file-buffer rem-file)) + (with-current-buffer rem-buffer (erase-buffer))) + (setq category (or org-category + (file-name-sans-extension + (file-name-nondirectory buffer-file-name)))) + (if (symbolp category) (setq category (symbol-name category))) + (let ((standard-output rem-buffer)) + (if combine + (and (not started) (setq started t) + (org-start-remind-file org-remind-combined-name)) + (org-start-remind-file category)) + (org-print-remind-entries combine) + (when (or (and combine (not files)) (not combine)) + (org-finish-remind-file) + (set-buffer rem-buffer) + (run-hooks 'org-before-save-Remind-file-hook) + (save-buffer) + (run-hooks 'org-after-save-Remind-file-hook) + (and (boundp 'org-wait) (numberp org-wait) (sit-for org-wait)) + )))) + (org-release-buffers org-agenda-new-buffers)))) + +(defvar org-before-save-Remind-file-hook nil + "Hook run before an Remind file has been saved. +This can be used to modify the result of the export.") + +(defvar org-after-save-Remind-file-hook nil + "Hook run after an Remind file has been saved. +The Remind buffer is still current when this hook is run. +A good way to use this is to tell a desktop calenndar application to re-read +the Remind file.") + +(defvar org-agenda-default-appointment-duration) ; defined in org-agenda.el +(defun org-print-remind-entries (&optional combine) + "Print Remind entries for the current Org-mode file to `standard-output'. +When COMBINE is non nil, add the category to each line." + (require 'org-agenda) + (let ((re1 (concat org-ts-regexp "\\|<%%([^>\n]+>")) + (re2 (concat "--?-?\\(" org-ts-regexp "\\)")) + (dts (org-rem-ts-to-string + (format-time-string (cdr org-time-stamp-formats) (current-time)) + "start time:")) + hd ts ts2 state status (inc t) pos b sexp rrule + scheduledp deadlinep todo prefix due start + tmp pri categories entry location summary desc uid + remind-aw remind-ew (org-rem-ew org-remind-extra-warn-days) + (org-rem-aw org-remind-advanced-warn-days) + trigger diff-days (dos org-remind-deadline-over-scheduled) + (suppress-last-newline org-remind-suppress-last-newline) + (sexp-buffer (get-buffer-create "*rem-tmp*"))) + (org-refresh-category-properties) + (save-excursion + (goto-char (point-min)) + (while (re-search-forward re1 nil t) + (catch :skip + (org-agenda-skip) + (when (boundp 'org-remind-verify-function) + (unless (funcall org-remind-verify-function) + (outline-next-heading) + (backward-char 1) + (throw :skip nil))) + (setq pos (match-beginning 0) + ts (match-string 0) + inc t + hd (condition-case nil + (org-remind-cleanup-string + (org-get-heading)) + (error (throw :skip nil))) + summary (org-remind-cleanup-string + (org-entry-get nil "SUMMARY")) + desc (org-remind-cleanup-string + (or (org-entry-get nil "DESCRIPTION") + (and org-remind-include-body (org-get-entry))) + t org-remind-include-body) + location (org-remind-cleanup-string + (org-entry-get nil "LOCATION")) + uid (if org-remind-store-UID + (org-id-get-create) + (or (org-id-get) (org-id-new))) + categories (org-export-get-remind-categories) + deadlinep nil scheduledp nil) + (if (looking-at re2) + (progn + (goto-char (match-end 0)) + (setq ts2 (match-string 1) + inc (not (string-match "[0-9]\\{1,2\\}:[0-9][0-9]" ts2)))) + (setq tmp (buffer-substring (max (point-min) + (- pos org-ds-keyword-length)) + pos) + ts2 (if (string-match "[0-9]\\{1,2\\}:[0-9][0-9]-\\([0-9]\\{1,2\\}:[0-9][0-9]\\)" ts) + (progn + (setq inc nil) + (replace-match "\\1" t nil ts)) + ts) + deadlinep (string-match org-deadline-regexp tmp) + scheduledp (string-match org-scheduled-regexp tmp) + todo (org-get-todo-state) + ;; donep (org-entry-is-done-p) + )) + (when (and + deadlinep + (if todo + (not (memq 'event-if-todo org-remind-use-deadline)) + (not (memq 'event-if-not-todo org-remind-use-deadline)))) + (throw :skip t)) + (when (and + scheduledp + (if todo + (not (memq 'event-if-todo org-remind-use-scheduled)) + (not (memq 'event-if-not-todo org-remind-use-scheduled)))) + (throw :skip t)) + (setq prefix (if deadlinep "DEADLINE-" (if scheduledp "SCHEDULED-" "TS-"))) + (if (or (string-match org-tr-regexp hd) + (string-match org-ts-regexp hd)) + (setq hd (replace-match "" t t hd))) + (if (string-match "\\+\\([0-9]+\\)\\([dwmy]\\)>" ts) + (setq rrule ;is recurrence value. later give it good name. + (* (string-to-number + (cdr (assoc + (match-string 2 ts) + '(("d" . "1")("w" . "7") + ("m" . "0")("y" . "0"))))) + (string-to-number (match-string 1 ts)))) + (setq rrule nil)) + (setq summary (or summary hd)) + (if (string-match org-bracket-link-regexp summary) + (setq summary + (replace-match (if (match-end 3) + (match-string 3 summary) + (match-string 1 summary)) + t t summary))) + (if deadlinep (setq summary (concat "DEADLINE: " summary))) + (if scheduledp (setq summary (concat "SCHEDULED: " summary))) + (if (string-match "\\`<%%" ts) + (with-current-buffer sexp-buffer + (insert (substring ts 1 -1) " " summary "\n")) + (princ (format "\n## BEGIN:EVENT +## UID: %s +REM %s %s MSG EVENT:%s%s %s%s%% +## CATEGORIES:%s +## END:EVENT\n" + (concat prefix uid) + (org-rem-ts-to-string ts nil nil rrule) + (org-rem-ts-to-string ts2 "UNTIL " inc) + summary + (if (and desc (string-match "\\S-" desc)) + (concat "%_\\\n" desc) "") + (if (and location (string-match "\\S-" location)) + (concat "\nLOCATION: " location) "") + (if suppress-last-newline "" "%_") + categories))))) + + (when (and org-remind-include-sexps + (condition-case nil (require 'remind) (error nil)) + (fboundp 'remind-export-region)) + ;; Get all the literal sexps + (goto-char (point-min)) + (while (re-search-forward "^&?%%(" nil t) + (catch :skip + (org-agenda-skip) + (setq b (match-beginning 0)) + (goto-char (1- (match-end 0))) + (forward-sexp 1) + (end-of-line 1) + (setq sexp (buffer-substring b (point))) + (with-current-buffer sexp-buffer + (insert sexp "\n")))) + ;; (princ (org-diary-to-rem-string sexp-buffer)) + (kill-buffer sexp-buffer)) + + (when org-remind-include-todo + (setq prefix "TODO-") + (goto-char (point-min)) + (while (re-search-forward org-todo-line-regexp nil t) + (catch :skip + (org-agenda-skip) + (when (boundp 'org-remind-verify-function) + (unless (funcall org-remind-verify-function) + (outline-next-heading) + (backward-char 1) + (throw :skip nil))) + (setq state (match-string 2)) + (setq status (if (member state org-done-keywords) + "COMPLETED" "NEEDS-ACTION")) + (when (and state + (or (not (member state org-done-keywords)) + (eq org-remind-include-todo 'all)) + (not (member org-archive-tag (org-get-tags-at))) + ) + (setq hd (match-string 3) + summary (org-remind-cleanup-string + (org-entry-get nil "SUMMARY")) + desc (org-remind-cleanup-string + (or (org-entry-get nil "DESCRIPTION") + (and org-remind-include-body (org-get-entry))) + t org-remind-include-body) + location (org-remind-cleanup-string + (org-entry-get nil "LOCATION")) + due (and (member 'todo-due org-remind-use-deadline) + (org-entry-get nil "DEADLINE")) + start (and (member 'todo-start org-remind-use-scheduled) + (org-entry-get nil "SCHEDULED")) + categories (org-export-get-remind-categories) + uid (if org-remind-store-UID + (org-id-get-create) + (or (org-id-get) (org-id-new)))) + + (if (and due start) + (setq diff-days (org-rem-time-diff-days due start))) + + (setq remind-aw + (if due + (if diff-days + (if (> diff-days 0) + (if dos diff-days 0) + (if dos 0 diff-days)) + 1000))) + + (if (and (numberp org-rem-aw) (> org-rem-aw 0)) + (setq remind-aw (+ (or remind-aw 0) org-rem-aw))) + + (setq remind-ew + (if due + (if diff-days + (if (> diff-days 0) due nil) + due))) + + (setq trigger (if dos (if due due start) (if start start due))) + ;; (and trigger (setq trigger (org-rem-ts-to-string trigger nil nil 1 remind-aw))) + (if trigger + (setq trigger (concat + (format "[trigger('%s')] *%d " + (org-rem-ts-to-remind-date-type trigger) 1) + (if remind-aw (format "++%d" remind-aw))))) + (and due (setq due (org-rem-ts-to-remind-date-type due))) + (and start (setq start (org-rem-ts-to-remind-date-type start))) + (and remind-ew (setq remind-ew (org-rem-ts-to-remind-date-type remind-ew))) + + (if (string-match org-bracket-link-regexp hd) + (setq hd (replace-match (if (match-end 3) (match-string 3 hd) + (match-string 1 hd)) + t t hd))) + (if (string-match org-priority-regexp hd) + (setq pri (string-to-char (match-string 2 hd)) + hd (concat (substring hd 0 (match-beginning 1)) + (substring hd (match-end 1)))) + (setq pri org-default-priority)) + (setq pri (floor (1+ (* 8. (/ (float (- org-lowest-priority pri)) + (- org-lowest-priority org-highest-priority)))))) + + (princ (format "\n## BEGIN:TODO +## UID: %s +REM %s %s %s MSG TODO: %s%s%s%s%s%s%% +## CATEGORIES:%s +## SEQUENCE:1 +## STATUS:%s +## END:TODO\n" + (concat prefix uid) + (or trigger "") ;; dts) + (if remind-ew (format "UNTIL [trigger('%s' + %d)]" remind-ew (or org-rem-ew 0)) "") + (if pri (format "PRIORITY %d" pri) "") + (or summary hd) + (if (and desc (string-match "\\S-" desc)) + (concat "%_\\\nDESCRIPTION: " desc) "") + (if (and location (string-match "\\S-" location)) + (concat "LOCATION: " location) "") + (if start + (concat + "%_\\\n['" start "' - today()] " + "days over, for scheduled date - " + "[trigger('" start "')]") "") + (if due + (concat + "%_\\\n[today() - '" due "'] " + "days left, to deadline date - " + "[trigger('" due "')]") "") + (if suppress-last-newline "" "%_") + categories + status))))))))) + +(defun org-export-get-remind-categories () + "Get categories according to `org-remind-categories'." + (let ((cs org-remind-categories) c rtn tmp) + (while (setq c (pop cs)) + (cond + ((eq c 'category) (push (org-get-category) rtn)) + ((eq c 'todo-state) + (setq tmp (org-get-todo-state)) + (and tmp (push tmp rtn))) + ((eq c 'local-tags) + (setq rtn (append (nreverse (org-get-local-tags-at (point))) rtn))) + ((eq c 'all-tags) + (setq rtn (append (nreverse (org-get-tags-at (point))) rtn))))) + (mapconcat 'identity (nreverse rtn) ","))) + +(defun org-remind-cleanup-string (s &optional is-body maxlength) + "Take out stuff and quote what needs to be quoted. +When IS-BODY is non-nil, assume that this is the body of an item, clean up +whitespace, newlines, drawers, and timestamps, and cut it down to MAXLENGTH +characters." + (if (or (not s) (string-match "^[ \t\n]*$" s)) + nil + (when is-body + (let ((re (concat "\\(" org-drawer-regexp "\\)[^\000]*?:END:.*\n?")) + (re2 (concat "^[ \t]*" org-keyword-time-regexp ".*\n?"))) + (while (string-match re s) (setq s (replace-match "" t t s))) + (while (string-match re2 s) (setq s (replace-match "" t t s))))) + (if org-remind-escape-percentage + (let ((start 0)) + (while (string-match "\\([%]\\)" s start) + (setq start (+ (match-beginning 0) 2) + s (replace-match "\\1\\1" nil nil s))))) + + (let ((start 0)) + (while (string-match "\\([\n]\\)" s start) + (setq start (+ (match-beginning 0) 4) ;; less than 4 is not correct. + s (replace-match "%_\\\\\\1" nil nil s)))) + + (let ((start 0)) + (while (string-match "\\([[]\\)" s start) + (setq start (+ (match-beginning 0) 5) + s (replace-match (concat "\[" "\"" "\\1" "\"" "\]") nil nil s)))) + +;;; (when is-body +;;; (while (string-match "[ \t]*\n[ \t]*" s) +;;; (setq s (replace-match "%_" t t s)))) + + (setq s (org-trim s)) + (if is-body + (if maxlength + (if (and (numberp maxlength) + (> (length s) maxlength)) + (setq s (substring s 0 maxlength))))) + s)) + +(defun org-get-entry () + "Clean-up description string." + (save-excursion + (org-back-to-heading t) + (buffer-substring (point-at-bol 2) (org-end-of-subtree t)))) + +(defun org-start-remind-file (name) + "Start an Remind file by inserting the header." + (let ((user user-full-name) + (name (or name "unknown")) + (timezone (cadr (current-time-zone)))) + (princ + (format "# -*- Mode: shell-script; auto-fill-mode: nil -*- +## BEGIN: Reminders +## VERSION:2.0 +## Emacs with Org-mode +## Calendar:%s +## Created by: %s +## Timezone:%s +## Calscale:Gregorian\n" name user timezone)))) + +(defun org-finish-remind-file () + "Finish an Remind file by inserting the END statement." + (princ "\n## END:Reminders\n")) + +(defun org-rem-ts-to-remind-date-type (s) + (format-time-string + "%Y-%m-%d" + (apply 'encode-time (butlast (org-parse-time-string s) 3)))) + +;; (defun org-rem-date-type-to-string (s keyword &optional inc day-repeat day-advance-warn) +;; (if trigger +;; (setq trigger +;; (concat +;; (format "[trigger('%s')] *%d " +;; (org-rem-ts-to-remind-date-type trigger) day-repeat) +;; (if day-advance-warn (format "++%d" day-advance-warn)))))) + +;; (format-time-string "%Y" +;; (apply 'encode-time (butlast (org-parse-time-string "<2008-11-20 Thu 10:30>") 3))) + +(defun org-rem-ts-to-string (s keyword &optional inc day-repeat day-advance-warn) + "Take a time string S and convert it to Remind format. +KEYWORD is added in front, to make a complete line like DTSTART.... +When INC is non-nil, increase the hour by two (if time string contains +a time), or the day by one (if it does not contain a time)." + (let ((t1 (org-parse-time-string s 'nodefault)) + t2 fmt have-time time) + (if (and (car t1) (nth 1 t1) (nth 2 t1)) + (setq t2 t1 have-time t) + (setq t2 (org-parse-time-string s))) + (let ((s (car t2)) (mi (nth 1 t2)) (h (nth 2 t2)) + (d (nth 3 t2)) (m (nth 4 t2)) (y (nth 5 t2))) + (when inc + (if have-time + (if org-agenda-default-appointment-duration + (setq mi (+ org-agenda-default-appointment-duration mi)) + (setq h (+ 2 h))) + (setq d (1+ d)))) + (setq time (encode-time s mi h d m y))) + (setq fmt (concat + "%d %b %Y" + (if day-advance-warn (format " ++%d" day-advance-warn)) + (if day-repeat (format " *%d" day-repeat)) + (if have-time " AT %H:%M"))) + (concat keyword (format-time-string fmt time)))) + +(defun org-rem-time-diff-days (end start) + (floor (/ (apply '- (mapcar + (lambda (s) + (let* + ((t1 (org-parse-time-string s)) + (s (car t1)) (mi (nth 1 t1)) + (h (nth 2 t1)) (d (nth 3 t1)) + (m (nth 4 t1)) (y (nth 5 t1))) + (float-time (encode-time s mi h d m y)))) + (list end start))) (* 24 60 60)))) + +(provide 'org2rem) + +;;; org-exp.el ends here diff --git a/contrib/lisp/orgtbl-sqlinsert.el b/contrib/lisp/orgtbl-sqlinsert.el new file mode 100644 index 0000000..d2580d8 --- /dev/null +++ b/contrib/lisp/orgtbl-sqlinsert.el @@ -0,0 +1,116 @@ +;;; orgtbl-sqlinsert.el --- orgtbl to SQL insert statements. + +;; Copyright (C) 2008-2012 Free Software Foundation + +;; Author: Jason Riedy +;; Keywords: org, tables, sql + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; Converts an orgtbl to a sequence of SQL insertion commands. +;; Table cells are quoted and escaped very conservatively. + +;;; Code: + +(defun orgtbl-to-sqlinsert (table params) + "Convert the orgtbl-mode TABLE to SQL insert statements. +TABLE is a list, each entry either the symbol `hline' for a horizontal +separator line, or a list of fields for that line. +PARAMS is a property list of parameters that can influence the conversion. + +Names and strings are modified slightly by default. Single-ticks +are doubled as per SQL's standard mechanism. Backslashes and +dollar signs are deleted. And tildes are changed to spaces. +These modifications were chosed for use with TeX. See +ORGTBL-SQL-STRIP-AND-QUOTE. + +Supports all parameters from ORGTBL-TO-GENERIC. New to this function +are: + +:sqlname The name of the database table; defaults to the name of the + target region. + +:nowebname If not nil, used as a wrapping noweb fragment name. + +The most important parameters of ORGTBL-TO-GENERIC for SQL are: + +:splice When set to t, return only insert statements, don't wrap + them in a transaction. Default is nil. + +:tstart, :tend + The strings used to begin and commit the transaction. + +:hfmt A function that gathers the quoted header names into a + dynamically scoped variable HDRLIST. Probably should + not be changed by the user. + +The general parameters :skip and :skipcols have already been applied when +this function is called." + (let* (hdrlist + (alignment (mapconcat (lambda (x) (if x "r" "l")) + org-table-last-alignment "")) + (nowebname (plist-get params :nowebname)) + (breakvals (plist-get params :breakvals)) + (firstheader t) + (*orgtbl-default-fmt* 'orgtbl-sql-strip-and-quote) + (params2 + (list + :sqlname name + :tstart (lambda () (concat (if nowebname + (format "<<%s>>= \n" nowebname) + "") + "BEGIN TRANSACTION;")) + :tend (lambda () (concat "COMMIT;" (if nowebname "\n@ " ""))) + :hfmt (lambda (f) (progn (if firstheader (push f hdrlist)) "")) + :hlfmt (lambda (lst) (setq firstheader nil)) + :lstart (lambda () (concat "INSERT INTO " + sqlname "( " + (mapconcat 'identity (reverse hdrlist) + ", ") + " )" (if breakvals "\n" " ") + "VALUES ( ")) + :lend " );" + :sep " , " + :hline nil + :remove-nil-lines t)) + (params (org-combine-plists params2 params)) + (sqlname (plist-get params :sqlname))) + (orgtbl-to-generic table params))) + +(defun orgtbl-sql-quote (str) + "Convert single ticks to doubled single ticks and wrap in single ticks." + (concat "'" (mapconcat 'identity (split-string str "'") "''") "'")) + +(defun orgtbl-sql-strip-dollars-escapes-tildes (str) + "Strip dollarsigns and backslash escapes, replace tildes with spaces." + (mapconcat 'identity + (split-string (mapconcat 'identity + (split-string str "\\$\\|\\\\") + "") + "~") + " ")) + +(defun orgtbl-sql-strip-and-quote (str) + "Apply ORGBTL-SQL-QUOTE and ORGTBL-SQL-STRIP-DOLLARS-ESCAPES-TILDES +to sanitize STR for use in SQL statements." + (cond ((stringp str) + (orgtbl-sql-quote (orgtbl-sql-strip-dollars-escapes-tildes str))) + ((sequencep str) (mapcar 'orgtbl-sql-strip-and-quote str)) + (t nil))) + +(provide 'orgtbl-sqlinsert) + +;;; orgtbl-sqlinsert.el ends here diff --git a/contrib/scripts/.gitignore b/contrib/scripts/.gitignore new file mode 100644 index 0000000..20d5925 --- /dev/null +++ b/contrib/scripts/.gitignore @@ -0,0 +1 @@ +plantuml.jar diff --git a/contrib/scripts/StartOzServer.oz b/contrib/scripts/StartOzServer.oz new file mode 100644 index 0000000..db12dec --- /dev/null +++ b/contrib/scripts/StartOzServer.oz @@ -0,0 +1,231 @@ +%%% ************************************************************* +%%% Copyright (C) 2009-2012 Torsten Anders (www.torsten-anders.de) +%%% This program is free software; you can redistribute it and/or +%%% modify it under the terms of the GNU General Public License +%%% as published by the Free Software Foundation; either version 2 +%%% of the License, or (at your option) any later version. +%%% This program is distributed in the hope that it will be useful, +%%% but WITHOUT ANY WARRANTY; without even the implied warranty of +%%% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +%%% GNU General Public License for more details. +%%% ************************************************************* + +%% +%% This code implements the Oz-side of the Org-babel Oz interface. It +%% creates a socket server (to which org-babel-oz.el then +%% connects). Any input to this socket must be an Oz expression. The +%% input is fed to the OPI oz compiler, and the results are send back +%% via the socket. +%% + + +declare + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% +%% Accessing the OPI compiler +%% + +MyCompiler = Emacs.condSend.compiler + + +/* % testing + +%% Feed an expression (result browsed) +{MyCompiler enqueue(setSwitch(expression true))} +{Browse + {MyCompiler enqueue(feedVirtualString("1 + 2" return(result: $)))}} +{MyCompiler enqueue(setSwitch(expression false))} + +%% It is really the OPI: I can use declare! +{MyCompiler enqueue(setSwitch(expression false))} +{MyCompiler enqueue(feedVirtualString("declare X=3\n{Browse X*X}"))} + +%% Note: expressions starting with keyword declare need keyword in +{MyCompiler enqueue(setSwitch(expression true))} +{Browse + {MyCompiler enqueue(feedVirtualString("declare X=3\nin X*X" return(result: $)))}} +{MyCompiler enqueue(setSwitch(expression false))} + +%% Alternatively you use a session with multiple feeds: first declare (statement), and then feed an expression +{MyCompiler enqueue(setSwitch(expression false))} +{MyCompiler enqueue(feedVirtualString("declare X=7" return))} +{MyCompiler enqueue(setSwitch(expression true))} +{Browse + {MyCompiler enqueue(feedVirtualString("X*X" return(result: $)))}} +{MyCompiler enqueue(setSwitch(expression false))} + +%% !!?? does not work? +%% return nil in case of any error (division by 0) +{MyCompiler enqueue(setSwitch(expression true))} +{Browse + {MyCompiler enqueue(feedVirtualString( + {Accum ["try\n" +% "skip\n" % do something in any case.. + "1 div 0" % my code +% "1" % my code + "\ncatch E then {Error.printException E}\n" + "error\n" % always return nil + "end\n"] + List.append} + return(result: $)))}} +{MyCompiler enqueue(setSwitch(expression false))} + + +%% !! catching some exceptions does not work?? + +%% exception is not catched +try {Bla} catch E then {Error.printException E} {Browse nil} end + +%% exception is catched +try {Browse 1 div 0} catch E then {Error.printException E} {Browse nil} end +{Browse ok} + + +*/ + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% +%% Socket interface +%% + + +%% +%% Create socket +%% + +MyPort = 6001 + +/** %% Creates a TCP socket server. Expects a Host (e.g., 'localhost') and a PortNo and returns a server plus its corresponding client. This client is an instance of Open.socket, and is the interface for reading and writing into the socket. +%% MakeServer blocks until the server listens. However, waiting until a connection has been accepted happens in its own thread (i.e. MakeServer does only block until the server listens). +%% NB: A port can be used only once, so assign it carefully. In case this postnnumber was shortly used before, you may need to wait a bit before reusing it. +%% */ +%% !! Alternatively, let it assign automatically and output the port number.. +%% +%% NOTE: for supporting multiple connections see http://www.mozart-oz.org/documentation/op/node13.html#section.sockets.accept +proc {MakeServer Host PortNo ?MyServer ?MyClient} + proc {Accept MyClient} + thread H in % P + %% suspends until a connection has been accepted + {MyServer accept(host:H + acceptClass:Open.socket + accepted:?MyClient)} +% {Myserver accept(host:H port:P)} % suspends until a connection has been accepted + %% !!?? port number of client is usually created randomly.. + {System.showInfo "% connection accepted from host "#H} + end + %% !!??? + %% If Accept is called recursively, then server accepts multiple connections. These share the same compiler instance (e.g. variable bindings are shared). For multiple independent compiler instances call the OzServer application multiple times. + %% However, how shall the output for multiple connections be sorted?? Would using the different client sockets created with the Server accept method work? + %% NB: The number of clients accepted concurrently must be limited to the number set by {MyServer listen} + % {Accept} + end +in + MyServer = {New Open.socket init} + %% To avoid problems with portnumbers, the port could be assigned automatically and then output.. + %%{MyServer bind(port:PortNo)} + {MyServer bind(host:Host takePort:PortNo)} + {MyServer listen} + {System.showInfo "% OzServer started at host "#Host#" and port "#PortNo} + MyClient = {Accept} +end +%% +MySocket = {MakeServer localhost MyPort _/*MyServer*/} + + +%% +%% Read socket input +%% + +declare +%% Copied from OzServer/source/Socket.oz +local + proc {Aux Socket Size Stream} + In = {Socket read(list:$ + size:Size)} + in + {Wait In} + %% !! Is this the right way to stop the processing?? + %% + %% abort condition when client stream ended (i.e. nothing was sent) + if In == nil + then {System.showInfo "socket stream ended"} + Stream = nil + else Stream = In | {Aux Socket Size} + end + end +in + /** %% The socket Server returns a stream of the strings it receives. The Server always waits until someone writes something into the socket, then the input is immediately written to a stream and the Server waits again. + %% */ + proc {ReadToStream Socket Size Xs} + thread {Aux Socket Size Xs} end + end +end + +/* % test + +MyStream = {ReadToStream MySocket 1024} + +*/ + +/* % test + +%% writing +{MySocket write(vs:"this is a test")} + +*/ + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% +%% Send socket input to compiler and send results back to socket +%% + +%% NOTE: Input code must be expression +thread + {ForAll {ReadToStream MySocket 1024} + proc {$ Code} + Result + %% Catch any exception (so the will not cause blocking) and return nil in that case + FullCode = {Accum ["try\n" +% "skip\n" % do something in any case.. + Code + "\ncatch E then {Error.printException E}\n" + "error\n" % in case of an error, return 'error' + "end\n"] + List.append} + in + %% ?? Should I make setting switches etc atomic? + {MyCompiler enqueue(setSwitch(expression true))} + {MyCompiler enqueue(feedVirtualString(FullCode return(result: ?Result)))} + {MyCompiler enqueue(setSwitch(expression false))} + %% + {Wait Result} + {MySocket write(vs: if {VirtualString.is Result} + then Result + else {Value.toVirtualString Result 1000 1000} + end)} + {Show 'Org-babel result: '#Result} + end} +end + + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% +%% Aux defs +%% + +/** %% Binds the accumulation of the binary function Fn on all neighbors in Xs to Y. E.g., Accum returns the sum in Xs if Fn is Number.'+'. +%% */ +proc {Accum Xs Fn Y} + {List.foldL Xs.2 Fn Xs.1 Y} +end + + + + + + + diff --git a/contrib/scripts/dir2org.zsh b/contrib/scripts/dir2org.zsh new file mode 100755 index 0000000..1ea8be4 --- /dev/null +++ b/contrib/scripts/dir2org.zsh @@ -0,0 +1,54 @@ +# desc: +# +# Output an org compatible structure representing the filesystem from +# the point passed on the command line (or . by default). +# +# options: +# none +# +# usage: +# dir2org.zsh [DIR]... +# +# author: +# Phil Jackson (phil@shellarchive.co.uk) + +set -e + +function headline { + local depth="${1}" + local text="${2}" + + printf "%${depth}s %s" "" | tr ' ' '*' + echo " ${text}" +} + +function scan_and_populate { + local depth="${1}" + local dir="${2}" + + headline ${depth} "${dir}" + + # if there is no files in dir then just move on + [[ $(ls "${dir}" | wc -l) -eq 0 ]] && return + + (( depth += 1 )) + + for f in $(ls -d "${dir}"/*); do + if [ -d "${f}" ]; then + scan_and_populate ${depth} "${f}" + else + headline ${depth} "[[file://${f}][${${f##*/}%.*}]]" + fi + done + + (( depth -= 1 )) +} + +function main { + local scan_dir="${1:-$(pwd)}" + local depth=0 + + scan_and_populate ${depth} "${scan_dir}" +} + +main "${@}" diff --git a/contrib/scripts/docco.css b/contrib/scripts/docco.css new file mode 100644 index 0000000..9030b6c --- /dev/null +++ b/contrib/scripts/docco.css @@ -0,0 +1,185 @@ +/*--------------------- Layout and Typography ----------------------------*/ +body { + font-family: 'Palatino Linotype', 'Book Antiqua', Palatino, FreeSerif, serif; + font-size: 15px; + line-height: 22px; + color: #252519; + margin: 0; padding: 0; +} +a { + color: #261a3b; +} + a:visited { + color: #261a3b; + } +p { + margin: 0 0 15px 0; +} +h1, h2, h3, h4, h5, h6 { + margin: 0px 0 15px 0; +} + h1 { + margin-top: 40px; + } +#container { + position: relative; +} +#background { + position: fixed; + top: 0; left: 525px; right: 0; bottom: 0; + background: #f5f5ff; + border-left: 1px solid #e5e5ee; + z-index: -1; +} +#jump_to, #jump_page { + background: white; + -webkit-box-shadow: 0 0 25px #777; -moz-box-shadow: 0 0 25px #777; + -webkit-border-bottom-left-radius: 5px; -moz-border-radius-bottomleft: 5px; + font: 10px Arial; + text-transform: uppercase; + cursor: pointer; + text-align: right; +} +#jump_to, #jump_wrapper { + position: fixed; + right: 0; top: 0; + padding: 5px 10px; +} + #jump_wrapper { + padding: 0; + display: none; + } + #jump_to:hover #jump_wrapper { + display: block; + } + #jump_page { + padding: 5px 0 3px; + margin: 0 0 25px 25px; + } + #jump_page .source { + display: block; + padding: 5px 10px; + text-decoration: none; + border-top: 1px solid #eee; + } + #jump_page .source:hover { + background: #f5f5ff; + } + #jump_page .source:first-child { + } +table td { + border: 0; + outline: 0; +} + td.docs, th.docs { + max-width: 450px; + min-width: 450px; + min-height: 5px; + padding: 10px 25px 1px 50px; + overflow-x: hidden; + vertical-align: top; + text-align: left; + } + .docs pre { + margin: 15px 0 15px; + padding-left: 15px; + } + .docs p tt, .docs p code { + background: #f8f8ff; + border: 1px solid #dedede; + font-size: 12px; + padding: 0 0.2em; + } + .pilwrap { + position: relative; + } + .pilcrow { + font: 12px Arial; + text-decoration: none; + color: #454545; + position: absolute; + top: 3px; left: -20px; + padding: 1px 2px; + opacity: 0; + -webkit-transition: opacity 0.2s linear; + } + td.docs:hover .pilcrow { + opacity: 1; + } + td.code, th.code { + padding: 14px 15px 16px 25px; + width: 100%; + vertical-align: top; + border-left: 1px solid #e5e5ee; + } + pre, tt, code { + font-size: 12px; line-height: 18px; + font-family: Menlo, Monaco, Consolas, "Lucida Console", monospace; + margin: 0; padding: 0; + } + + +/*---------------------- Syntax Highlighting -----------------------------*/ +td.linenos { background-color: #f0f0f0; padding-right: 10px; } +span.lineno { background-color: #f0f0f0; padding: 0 5px 0 5px; } +body .hll { background-color: #ffffcc } +body .c { color: #408080; font-style: italic } /* Comment */ +body .err { border: 1px solid #FF0000 } /* Error */ +body .k { color: #954121 } /* Keyword */ +body .o { color: #666666 } /* Operator */ +body .cm { color: #408080; font-style: italic } /* Comment.Multiline */ +body .cp { color: #BC7A00 } /* Comment.Preproc */ +body .c1 { color: #408080; font-style: italic } /* Comment.Single */ +body .cs { color: #408080; font-style: italic } /* Comment.Special */ +body .gd { color: #A00000 } /* Generic.Deleted */ +body .ge { font-style: italic } /* Generic.Emph */ +body .gr { color: #FF0000 } /* Generic.Error */ +body .gh { color: #000080; font-weight: bold } /* Generic.Heading */ +body .gi { color: #00A000 } /* Generic.Inserted */ +body .go { color: #808080 } /* Generic.Output */ +body .gp { color: #000080; font-weight: bold } /* Generic.Prompt */ +body .gs { font-weight: bold } /* Generic.Strong */ +body .gu { color: #800080; font-weight: bold } /* Generic.Subheading */ +body .gt { color: #0040D0 } /* Generic.Traceback */ +body .kc { color: #954121 } /* Keyword.Constant */ +body .kd { color: #954121; font-weight: bold } /* Keyword.Declaration */ +body .kn { color: #954121; font-weight: bold } /* Keyword.Namespace */ +body .kp { color: #954121 } /* Keyword.Pseudo */ +body .kr { color: #954121; font-weight: bold } /* Keyword.Reserved */ +body .kt { color: #B00040 } /* Keyword.Type */ +body .m { color: #666666 } /* Literal.Number */ +body .s { color: #219161 } /* Literal.String */ +body .na { color: #7D9029 } /* Name.Attribute */ +body .nb { color: #954121 } /* Name.Builtin */ +body .nc { color: #0000FF; font-weight: bold } /* Name.Class */ +body .no { color: #880000 } /* Name.Constant */ +body .nd { color: #AA22FF } /* Name.Decorator */ +body .ni { color: #999999; font-weight: bold } /* Name.Entity */ +body .ne { color: #D2413A; font-weight: bold } /* Name.Exception */ +body .nf { color: #0000FF } /* Name.Function */ +body .nl { color: #A0A000 } /* Name.Label */ +body .nn { color: #0000FF; font-weight: bold } /* Name.Namespace */ +body .nt { color: #954121; font-weight: bold } /* Name.Tag */ +body .nv { color: #19469D } /* Name.Variable */ +body .ow { color: #AA22FF; font-weight: bold } /* Operator.Word */ +body .w { color: #bbbbbb } /* Text.Whitespace */ +body .mf { color: #666666 } /* Literal.Number.Float */ +body .mh { color: #666666 } /* Literal.Number.Hex */ +body .mi { color: #666666 } /* Literal.Number.Integer */ +body .mo { color: #666666 } /* Literal.Number.Oct */ +body .sb { color: #219161 } /* Literal.String.Backtick */ +body .sc { color: #219161 } /* Literal.String.Char */ +body .sd { color: #219161; font-style: italic } /* Literal.String.Doc */ +body .s2 { color: #219161 } /* Literal.String.Double */ +body .se { color: #BB6622; font-weight: bold } /* Literal.String.Escape */ +body .sh { color: #219161 } /* Literal.String.Heredoc */ +body .si { color: #BB6688; font-weight: bold } /* Literal.String.Interpol */ +body .sx { color: #954121 } /* Literal.String.Other */ +body .sr { color: #BB6688 } /* Literal.String.Regex */ +body .s1 { color: #219161 } /* Literal.String.Single */ +body .ss { color: #19469D } /* Literal.String.Symbol */ +body .bp { color: #954121 } /* Name.Builtin.Pseudo */ +body .vc { color: #19469D } /* Name.Variable.Class */ +body .vg { color: #19469D } /* Name.Variable.Global */ +body .vi { color: #19469D } /* Name.Variable.Instance */ +body .il { color: #666666 } /* Literal.Number.Integer.Long */ \ No newline at end of file diff --git a/contrib/scripts/org-docco.org b/contrib/scripts/org-docco.org new file mode 100644 index 0000000..d846aa3 --- /dev/null +++ b/contrib/scripts/org-docco.org @@ -0,0 +1,206 @@ +#+Title: Org-Docco +#+Author: Eric Schulte +#+Style: +#+Property: tangle yes + +The =docco= tool (see http://jashkenas.github.com/docco/) generates +HTML from JavaScript source code providing an attractive side-by-side +display of source code and comments. This file (see [[http://orgmode.org/w/?p=org-mode.git;a=blob_plain;f=contrib/scripts/org-docco.org;hb=HEAD][org-docco.org]]) +generates the same type of output from Org-mode documents with code +embedded in code blocks. + +The way this works is an Org-mode document with embedded code blocks +is exported to html using the standard Org-mode export functions. +This file defines a new function named =org-docco-buffer= which, when +added to the =org-export-html-final-hook=, will be run automatically +as part of the Org-mod export process doccoizing your Org-mode +document. + +A pure source code file can be extracted (or "/tangled/") from the +Org-mode document using the normal =org-babel-tangle= function. See +[[http://orgmode.org/manual/Working-With-Source-Code.html][Working With Source Code]] chapter of the Org-mode manual for more +information on using code blocks in Org-mode files. + +*Disclaimer*: this currently only works on /very/ simple Org-mode +files which have no headings but rather are just a collection of +alternating text and code blocks. It wouldn't be difficult to +generalize the following code so that it could be run in particular +sub-trees but I simply don't have the time to do so myself, and this +version perfectly satisfies my own limit needs. I make no promises to +support this code moving forward. /Caveat Emptor/ + +#+begin_src emacs-lisp :padline no +;;; org-docco.el --- docco type html generation from Org-mode + +;; Copyright (C) 2012 Eric Schulte + +;; Author: Eric Schulte +;; Keywords: org-mode, literate programming, html +;; Homepage: http://orgmode.org/worg/org-contrib/org-mime.php +;; Version: 0.01 + +;; This file is not part of GNU Emacs. + +;;; License: + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;; <- look over there +#+end_src + +The =cl= package provides all of the state-changing functions used +below e.g., =push= and =incf=. It looks like a namespace-safe version +of =cl= may soon be permissible for use in official Emacs packages. +#+begin_src emacs-lisp +;;; Code: +(require 'cl) +#+end_src + +This is a function which returns the buffer positions of matching +regular expressions. It has two special features... +1. It only counts matched instances of =beg-re= and =end-re= which are + properly nested, so for example if =beg-re= and =end-re= are set to + =(= and =)= respectively and we run this against the following, + : 1 2 3 4 5 6 + : | | | | | | + : v v v v v v + : (foo (bar baz) (qux) quux) + it will return 1 and 6 rather than 1 and 3. +2. It uses [[www.gnu.org/s/emacs/manual/html_node/elisp/Markers.html][markers]] which save their position in a buffer even as the + buffer is changed (e.g., by me adding in extra HTML text). +#+begin_src emacs-lisp +(defun org-docco-balanced-re (beg-re end-re) + "Return the beginning and of a balanced regexp." + (save-excursion + (save-match-data + (let ((both-re (concat "\\(" beg-re "\\|" end-re "\\)")) + (beg-count 0) (end-count 0) + beg end) + (when (re-search-forward beg-re nil t) + (goto-char (match-beginning 0)) + (setq beg (point-marker)) + (incf beg-count) + (goto-char (match-end 0)) + (while (and (not end) (re-search-forward both-re nil t)) + (goto-char (match-beginning 0)) + (cond ((looking-at beg-re) (incf beg-count)) + ((looking-at end-re) (incf end-count)) + (:otherwise (error "miss-matched"))) + (goto-char (match-end 0)) + (when (= beg-count end-count) (setq end (point-marker)))) + (when end (cons beg end))))))) +#+end_src + +This ugly large function does the actual conversion. It wraps the +entire main content =div= of the exported Org-mode html into a single +large table. Each row of the table has documentation on the left side +and code on the right side. This function has two parts. +1. We use =(org-docco-balanced-re "")= to find the + beginning and end of the main content div. We then break up this + div at =
    = boundaries with multiple calls to
    +   =(org-docco-balanced-re "
    ")=.
    +2. With all documentation/code boundaries in hand we step through the
    +   buffer inserting the table html code at boundary locations.
    +#+begin_src emacs-lisp
    +(defun org-docco-buffer ()
    +  "Call from within an HTML buffer to doccoize it."
    +  (interactive)
    +  (let ((table-start "\n")
    +        (doc-row-start  "\n")
    +        (code-row-start "    \n")
    +        (table-end "
    \n") (doc-row-end "\n") (code-row-end "
    " ) + pair transition-points next) + (save-excursion + (save-match-data + (goto-char (point-min)) + (when (re-search-forward "
    " nil t) + (goto-char (match-end 0)) + (push (point-marker) transition-points) + (goto-char (match-beginning 0)) + (setq pair (org-docco-balanced-re "")) + (while (setq next (org-docco-balanced-re "
    "))
    +            (goto-char (cdr next))
    +            (push (car next) transition-points)
    +            (push (cdr next) transition-points))
    +          (goto-char (cdr pair))
    +          (push (and (re-search-backward "
    " nil t) (point-marker)) + transition-points) + ;; collected transitions, so build the table + (setq transition-points (nreverse transition-points)) + (goto-char (pop transition-points)) + (insert table-start doc-row-start) + (while (> (length transition-points) 1) + (goto-char (pop transition-points)) + (insert doc-row-end code-row-start) + (goto-char (pop transition-points)) + (insert code-row-end doc-row-start)) + (goto-char (pop transition-points)) + (insert code-row-end table-end) + (unless (null transition-points) + (error "leftover points"))))))) +#+end_src + +We'll use Emacs [[http://www.gnu.org/software/emacs/manual/html_node/emacs/Specifying-File-Variables.html][File Local Variables]] and the +=org-export-html-final-hook= to control which buffers have +=org-docco-buffer= run as part of their export process. +#+begin_src emacs-lisp + (defvar org-docco-doccoize-me nil + "File local variable controlling if html export should be doccoized.") + (make-local-variable 'org-docco-doccoize-me) +#+end_src + +A simple function will conditionally process HTML output based on the +value of this variable. +#+begin_src emacs-lisp + (defun org-docco-buffer-maybe () + (when org-docco-doccoize-me (org-docco-buffer))) +#+end_src + +Finally this function is added to the =org-export-html-final-hook=. +#+begin_src emacs-lisp + (add-hook 'org-export-html-final-hook #'org-docco-buffer-maybe) +#+end_src + +That's it. To use this simply; +1. Checkout this file from https://github.com/eschulte/org-docco, + : git clone git://github.com/eschulte/org-docco.git + and open it using Emacs. +2. Tangle =org-docco.el= out of this file by calling + =org-babel-tangle= or =C-c C-v t=. +3. Load the resulting Emacs Lisp file. +4. Execute the following in any Org-mode buffer to add file local + variable declarations which will enable post-processed with + =org-docco-buffer=. + : (add-file-local-variable 'org-export-html-postamble nil) + : (add-file-local-variable 'org-export-html-style-include-default nil) + : (add-file-local-variable 'org-docco-doccoize-me t) + And add the following style declaration to make use of the + =docco.css= style sheet taken directly from + https://github.com/jashkenas/docco. + : #+Style: + +#+begin_src emacs-lisp +(provide 'org-docco) +;;; org-docco.el ends here +#+end_src + +# Local Variables: +# org-export-html-postamble: nil +# org-export-html-style-include-default: nil +# org-docco-doccoize-me: t +# End: diff --git a/contrib/scripts/org2hpda b/contrib/scripts/org2hpda new file mode 100755 index 0000000..de0b573 --- /dev/null +++ b/contrib/scripts/org2hpda @@ -0,0 +1,106 @@ +# org2hpda - a small utility to generate hipster pda style printouts from org mode +# Copyright (C) 2007-2012 Christian Egli +# +# Version: 0.6 +# +# This program is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . +# +# Commentary: +# =========== +# +# set cal-tex-diary to true so that diary entries show up in the calendar +# +# Usage: +# ====== +# +# run this makefile with +# +# make -f org2hpda +# +# The makfile will take the entries from your diary file and generate +# two PDFs containing nicely printed weekly and monthly calendars. One +# is done in the style of a pocketMod (http://www.pocketmod.com/) and +# the other is done in the style of the Hipster PDA +# (http://en.wikipedia.org/wiki/Hipster_PDA). +# +# Requirements: +# ============= +# +# the pdf* commands are part of the pdfjam package which can be found +# at http://www.warwick.ac.uk/go/pdfjam + +EMACS = emacs -batch -l ~/.emacs +LATEX = latex +DIARY = $($(EMACS) -eval "diary-file") + +# Number of weeks to be printed. Should be a multiple of 4, because 4 +# of them are merged on one page. Can be set when invoking the script +# as follows: make NUMBER_OF_WEEKS=8 -f org2hpda +NUMBER_OF_WEEKS = 4 + +hipsterFiles = weekCalendar.pdf yearCalendar.pdf monthCalendar3.pdf monthCalendar2.pdf monthCalendar1.pdf +pocketModFiles = weekCalendar.pdf yearCalendar-rotated.pdf \ + monthCalendar3-rotated.pdf monthCalendar2-rotated.pdf monthCalendar1-rotated.pdf + +all: pocketMod.pdf hipsterPDA.pdf + +%.dvi: %.tex + # Quick hack to massage the LaTeX produced by cal-tex + # quote '@', then increase font size of week calendars, + # increase font of diary entries in moth calendar and + # finally reduce links to their destination, i.e. + # change '[[http://foo][bar]]' to 'bar' + sed -e 's/\\verb|@|/\@/g' \ + -e 's/documentclass\[11pt\]/documentclass[12pt]/g' \ + -e 's/{\\tiny \\raggedright #3}/{\\small \\raggedright #3}/g' \ + -e 's/\[\[[^]]\+\]\[\([^]]\+\)\]\]/\1/g' \ + < $< > /tmp/temp-org-file.$$$$; mv /tmp/temp-org-file.$$$$ $< + $(LATEX) $^ + +%.pdf: %.dvi + dvipdf $^ + +%-rotated.pdf: %.pdf + cp $^ $@ + for n in 1 2 3; do \ + pdf90 --quiet --outfile tmp.pdf $@; mv tmp.pdf $@; \ + done + +weekCalendar.tex: $(DIARY) + $(EMACS) -eval "(progn (calendar) (cal-tex-cursor-week-iso $(NUMBER_OF_WEEKS)) (with-current-buffer cal-tex-buffer (write-file \"$@\")))" + +monthCalendar1.tex: $(DIARY) + $(EMACS) -eval "(progn (calendar) (cal-tex-cursor-month-landscape 1) (with-current-buffer cal-tex-buffer (write-file \"$@\")))" + +monthCalendar2.tex: $(DIARY) + $(EMACS) -eval "(progn (calendar) (calendar-forward-month 1) (cal-tex-cursor-month-landscape 1) (with-current-buffer cal-tex-buffer (write-file \"$@\")))" + +monthCalendar3.tex: $(DIARY) + $(EMACS) -eval "(progn (calendar) (calendar-forward-month 2) (cal-tex-cursor-month-landscape 1) (with-current-buffer cal-tex-buffer (write-file \"$@\")))" + +yearCalendar.tex: $(DIARY) + $(EMACS) -eval "(progn (calendar) (calendar-forward-month 2) (cal-tex-cursor-year-landscape 1) (with-current-buffer cal-tex-buffer (write-file \"$@\")))" + +pocketMod.pdf: $(pocketModFiles) + pdfjoin --quiet --outfile tmp.pdf $^ + pdfnup tmp.pdf --quiet --outfile $@ --nup 4x2 --frame true + +hipsterPDA.pdf: $(hipsterFiles) + pdfnup weekCalendar.pdf --quiet --outfile page1.pdf --batch --nup 2x2 --frame true --no-landscape + pdfjoin --quiet --outfile tmp.pdf monthCalendar[1-3]-rotated.pdf yearCalendar-rotated.pdf + pdfnup tmp.pdf --quiet --outfile page2.pdf --batch --nup 2x2 --frame true --no-landscape + pdfjoin --quiet --outfile $@ page1.pdf page2.pdf + +clean: + rm -rf *.aux *.dvi *.tex *.log *.pdf diff --git a/contrib/scripts/staticmathjax/.gitignore b/contrib/scripts/staticmathjax/.gitignore new file mode 100644 index 0000000..b25c15b --- /dev/null +++ b/contrib/scripts/staticmathjax/.gitignore @@ -0,0 +1 @@ +*~ diff --git a/contrib/scripts/staticmathjax/README.org b/contrib/scripts/staticmathjax/README.org new file mode 100644 index 0000000..d28fc90 --- /dev/null +++ b/contrib/scripts/staticmathjax/README.org @@ -0,0 +1,79 @@ +Static MathJax v0.1 README +#+AUTHOR: Jan Böcker + +Static MathJax is a XULRunner application which loads a HTML input +file that uses MathJax into a browser, waits until MathJax is done +processing, and then writes the formatted result to an output HTML +file. + +I have only tested exports from Emacs Org-mode as input files. (As of +2010-08-14, MathJax is used by default with HTML exports in the +current Org development version.) + +Optionally, references to the math fonts used will be converted to +"data:" URIs, thus embedding the font data into the HTML file itself. +(see [[http://en.wikipedia.org/wiki/Data_URI_scheme]]) + +The code is licensed under the GNU General Public License version +2, or, at your option, any later version. + + +* Usage + To run Static MathJax, an existing XULRunner installation is + required. From the directory to which you unpacked Static MathJax, + run: + + xulrunner application.ini <--embed-fonts | --final-mathjax-url > + + + If you prefer to call "staticmathjax" instead of "xulrunner + application.ini", link xulrunner-stub into the directory: + ln /usr/lib/xulrunner-1.9.2.8/xulrunner-stub ./staticmathjax + + - input file :: + name of the input file (the result of a HTML export + from Org-mode). It is assumed that this file uses the + UTF-8 character encoding. + + - output file :: + name of the output file. + + - --embed-fonts :: + if specified, the math fonts will be embedded into + the output file using data: URIs + + - --final-mathjax-url :: + if --embed-fonts is not specified, this + must be the URL to a MathJax installation folder (e.g. "MathJax" + if MathJax is installed in a subdirectory, or + "http://orgmode.org/mathjax" to use the version hosted on the Org + website. + + All references to math fonts in the output file will point to + this directory. + +* Caveats + + The input file must not use a MathJax installation on the + web. Otherwise, due to a security feature of Firefox, MathJax will + fallback to image fonts. If you have unpacked MathJax to a + subdirectory "MathJax", specify the following in your Org file: + + #+MathJax: path:"MathJax" + + The math is rendered in Firefox, so MathJax applies its + Firefox-specific settings. When viewing the output files in other + browsers, it will look slightly different than the result that + running MathJax in that browser would produce. + + Internet Explorer does not use the correct font, because it only + supports the EOT font format. For all other browsers (including + Firefox), MathJax uses the OTF font format. + + Embedding fonts into the HTML file wastes some space due to the + base64 encoding used in data: URIs. + + I have found no way to access stdout or set an exit code in an + XULRunner app, so any code which calls Static MathJax has no idea if + processing was successful and when an error occurs, graphical + message boxes are displayed. diff --git a/contrib/scripts/staticmathjax/application.ini b/contrib/scripts/staticmathjax/application.ini new file mode 100644 index 0000000..d7957b0 --- /dev/null +++ b/contrib/scripts/staticmathjax/application.ini @@ -0,0 +1,11 @@ +[App] +Vendor=Jan Boecker +Name=StaticMathJax +Version=0.2 +BuildID=2 +Copyright=Copyright (c) 2010 Jan Boecker +ID=xulapp@jboecker.de + +[Gecko] +MinVersion=1.8 + diff --git a/contrib/scripts/staticmathjax/chrome/chrome.manifest b/contrib/scripts/staticmathjax/chrome/chrome.manifest new file mode 100644 index 0000000..a05d8c8 --- /dev/null +++ b/contrib/scripts/staticmathjax/chrome/chrome.manifest @@ -0,0 +1 @@ +content staticmathjax file:content/ diff --git a/contrib/scripts/staticmathjax/chrome/content/main.js b/contrib/scripts/staticmathjax/chrome/content/main.js new file mode 100644 index 0000000..2e71f3b --- /dev/null +++ b/contrib/scripts/staticmathjax/chrome/content/main.js @@ -0,0 +1,198 @@ +var docFrame; +var logtextbox; +var destFile; +var embedFonts = false; +var finalMathJaxURL = null; + +function log(text) +{ + logtextbox.setAttribute("value", logtextbox.getAttribute("value") + "\n" + text); +} + +function init() +{ + try { + docFrame = document.getElementById("docFrame"); + logtextbox = document.getElementById("logtextbox"); + + // parse command line arguments + var cmdLine = window.arguments[0]; + cmdLine = cmdLine.QueryInterface(Components.interfaces.nsICommandLine); + + embedFonts = cmdLine.handleFlag("embed-fonts", false); + finalMathJaxURL = cmdLine.handleFlagWithParam("final-mathjax-url", false); + + if (!embedFonts && !finalMathJaxURL) { + alert("You must eiher specify --embed-fonts or --final-mathjax-url"); + window.close(); + return; + } + + sourceFilePath = cmdLine.getArgument(0); + destFilePath = cmdLine.getArgument(1); + if ( !sourceFilePath || !destFilePath ) { + alert("Not enough parameters, expecting two arguments:\nInput file, output file"); + window.close(); + return; + } + + sourceFile = cmdLine.resolveFile(sourceFilePath); + if (! (sourceFile.exists() && sourceFile.isFile()) ) { + alert("Invalid source file path."); + window.close(); + return; + } + sourceURI = cmdLine.resolveURI(sourceFilePath); + + // create a nsIFile object for the output file + try{ + destFile = cmdLine.resolveURI(destFilePath).QueryInterface(Components.interfaces.nsIFileURL).file; + }catch(e){ + alert("Invalid destination file.\n\nException:\n" + e); + window.close(); + return; + } + + // add iframeLoaded() as an onload event handler, then navigate to the source file + docFrame.addEventListener("DOMContentLoaded", iframeLoaded, true); + docFrame.setAttribute("src", sourceURI.spec); + + } catch (e) { + alert("Error in init():\n\n" + e); + window.close(); + return; + } +} + +function iframeLoaded() +{ + /* + // print every MathJax signal to the log + docFrame.contentWindow.MathJax.Hub.Startup.signal.Interest( + function (message) {log("Startup: "+message)} + ); + docFrame.contentWindow.MathJax.Hub.signal.Interest( + function (message) {log("Hub: "+message)} + ); + */ + + // tell MathJax to call serialize() when finished + docFrame.contentWindow.MathJax.Hub.Register.StartupHook("End", function() {serialize();}); +} + +function fileURLtoDataURI(url) +{ + var ios = Components.classes["@mozilla.org/network/io-service;1"] + .getService(Components.interfaces.nsIIOService); + var url_object = ios.newURI(url, "", null); + var file = url_object.QueryInterface(Components.interfaces.nsIFileURL).file; + + var data = ""; + var fstream = Components.classes["@mozilla.org/network/file-input-stream;1"]. + createInstance(Components.interfaces.nsIFileInputStream); + fstream.init(file, -1, -1, false); + var bstream = Components.classes["@mozilla.org/binaryinputstream;1"]. + createInstance(Components.interfaces.nsIBinaryInputStream); + bstream.setInputStream(fstream); + + var bytes = bstream.readBytes(bstream.available()); + b64bytes = btoa(bytes); + + return "data:;base64," + b64bytes; + +} + +function serialize() +{ + var MathJaxURL = docFrame.contentWindow.MathJax.Hub.config.root; + + var searchURIList = new Array(); + var replacementURIList = new Array(); + + log("serialize: preprocessing"); + + // remove the MathJax status message window + msgdiv = docFrame.contentDocument.getElementById("MathJax_Message"); + msgdiv.parentNode.removeChild(msgdiv); + + /* Loop through all CSS rules to find all @font-face rules. + At this point, they refer to local absolute paths using file:// URLs. + Replace them either with appropriate URLs relative to finalMathJaxURL + or with data URIs. */ + + for (var i = 0; i tag + try{ + var scriptTags = docFrame.contentDocument.getElementsByTagName("script"); + for (var i=0; i + + + + +