summaryrefslogtreecommitdiff
path: root/contrib
diff options
context:
space:
mode:
Diffstat (limited to 'contrib')
-rw-r--r--contrib/README96
-rw-r--r--contrib/babel/langs/ob-fomus.el93
-rw-r--r--contrib/babel/langs/ob-oz.el294
-rw-r--r--contrib/babel/library-of-babel.org584
-rw-r--r--contrib/lisp/htmlize.el1769
-rw-r--r--contrib/lisp/org-annotate-file.el131
-rw-r--r--contrib/lisp/org-bibtex-extras.el155
-rw-r--r--contrib/lisp/org-bookmark.el88
-rw-r--r--contrib/lisp/org-checklist.el140
-rw-r--r--contrib/lisp/org-choose.el542
-rw-r--r--contrib/lisp/org-collector.el229
-rw-r--r--contrib/lisp/org-contacts.el621
-rw-r--r--contrib/lisp/org-contribdir.el38
-rw-r--r--contrib/lisp/org-depend.el420
-rw-r--r--contrib/lisp/org-drill.el3001
-rw-r--r--contrib/lisp/org-e-ascii.el1807
-rw-r--r--contrib/lisp/org-e-beamer.el1069
-rw-r--r--contrib/lisp/org-e-groff.el2090
-rw-r--r--contrib/lisp/org-e-html.el3044
-rw-r--r--contrib/lisp/org-e-latex.el2726
-rw-r--r--contrib/lisp/org-e-man.el1363
-rw-r--r--contrib/lisp/org-e-odt.el3762
-rw-r--r--contrib/lisp/org-e-publish.el1200
-rw-r--r--contrib/lisp/org-e-texinfo.el1844
-rw-r--r--contrib/lisp/org-elisp-symbol.el161
-rw-r--r--contrib/lisp/org-eval-light.el201
-rw-r--r--contrib/lisp/org-eval.el219
-rw-r--r--contrib/lisp/org-exp-bibtex.el148
-rw-r--r--contrib/lisp/org-expiry.el361
-rw-r--r--contrib/lisp/org-export-generic.el1504
-rw-r--r--contrib/lisp/org-export.el4518
-rw-r--r--contrib/lisp/org-git-link.el220
-rw-r--r--contrib/lisp/org-interactive-query.el312
-rw-r--r--contrib/lisp/org-invoice.el401
-rw-r--r--contrib/lisp/org-jira.el65
-rw-r--r--contrib/lisp/org-learn.el177
-rw-r--r--contrib/lisp/org-mac-iCal.el251
-rw-r--r--contrib/lisp/org-mac-link-grabber.el467
-rw-r--r--contrib/lisp/org-mairix.el332
-rw-r--r--contrib/lisp/org-man.el64
-rw-r--r--contrib/lisp/org-md.el461
-rw-r--r--contrib/lisp/org-mime.el336
-rw-r--r--contrib/lisp/org-mtags.el257
-rw-r--r--contrib/lisp/org-notify.el377
-rw-r--r--contrib/lisp/org-notmuch.el105
-rw-r--r--contrib/lisp/org-panel.el641
-rw-r--r--contrib/lisp/org-registry.el271
-rw-r--r--contrib/lisp/org-screen.el108
-rw-r--r--contrib/lisp/org-secretary.el232
-rw-r--r--contrib/lisp/org-static-mathjax.el171
-rw-r--r--contrib/lisp/org-sudoku.el290
-rw-r--r--contrib/lisp/org-toc.el488
-rw-r--r--contrib/lisp/org-track.el219
-rw-r--r--contrib/lisp/org-velocity.el724
-rw-r--r--contrib/lisp/org-wikinodes.el340
-rw-r--r--contrib/lisp/org2rem.el651
-rw-r--r--contrib/lisp/orgtbl-sqlinsert.el116
-rw-r--r--contrib/scripts/.gitignore1
-rw-r--r--contrib/scripts/StartOzServer.oz231
-rwxr-xr-xcontrib/scripts/dir2org.zsh54
-rw-r--r--contrib/scripts/docco.css185
-rw-r--r--contrib/scripts/org-docco.org206
-rwxr-xr-xcontrib/scripts/org2hpda106
-rw-r--r--contrib/scripts/staticmathjax/.gitignore1
-rw-r--r--contrib/scripts/staticmathjax/README.org79
-rw-r--r--contrib/scripts/staticmathjax/application.ini11
-rw-r--r--contrib/scripts/staticmathjax/chrome/chrome.manifest1
-rw-r--r--contrib/scripts/staticmathjax/chrome/content/main.js198
-rw-r--r--contrib/scripts/staticmathjax/chrome/content/main.xul11
-rw-r--r--contrib/scripts/staticmathjax/defaults/preferences/prefs.js1
70 files changed, 43379 insertions, 0 deletions
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 <lisp> 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 <number>, 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 <hniksic@xemacs.org>
+;; 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 <hniksic@xemacs.org> 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 <span
+;; class=FACE>...</span> 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 <font color="...">...</font> 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:
+;;
+;; <http://fly.srk.fer.hr/~hniksic/emacs/htmlize.el>
+;;
+;; You can find a sample of htmlize's output (possibly generated with
+;; an older version) at:
+;;
+;; <http://fly.srk.fer.hr/~hniksic/emacs/htmlize.el.html>
+
+;; 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 <span class=\"FACE\">.
+
+When set to `inline-css', the style will be generated as above, but
+placed directly in the STYLE attribute of the span ELEMENT: <span
+style=\"STYLE\">. This makes it easier to paste the resulting HTML to
+other documents.
+
+When set to `font', the properties will be set using layout tags
+<font>, <b>, <i>, <u>, and <strike>.
+
+`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 <hr> separator. If this
+is a string, it specifies the replacement to use. Note that <pre> is
+temporarily closed before the separator is inserted, so the default
+replacement is effectively \"</pre><hr /><pre>\". If you specify
+another replacement, don't forget to close and reopen the <pre> 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:
+
+ <meta http-equiv=\"Content-Type\" content=\"text/html; charset=CHARSET\">
+
+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,
+\"&#169;\" *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, \"&#169;\" is exactly equivalent to \"&copy;\".
+
+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 ?&) "&amp;"
+ (aref table ?<) "&lt;"
+ (aref table ?>) "&gt;"
+ ;; 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 ?\") "&quot;"
+ )
+ 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 "&#<code>;" or "<char>" (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 &#64;.
+`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 "&#64;" 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
+ "&lt;\\(\\(mailto:\\)?\\([-=+_.a-zA-Z0-9]+@[-_.a-zA-Z0-9]+\\)\\)&gt;"
+ nil t)
+ (let ((address (match-string 3))
+ (link-text (match-string 1)))
+ (delete-region (match-beginning 0) (match-end 0))
+ (insert "&lt;<a href=\"mailto:"
+ (htmlize-despam-address address)
+ "\">"
+ (htmlize-despam-address link-text)
+ "</a>&gt;")))
+ (goto-char (point-min))
+ (while (re-search-forward "&lt;\\(\\(URL:\\)?\\([a-zA-Z]+://[^;]+\\)\\)&gt;"
+ nil t)
+ (let ((url (match-string 3))
+ (link-text (match-string 1)))
+ (delete-region (match-beginning 0) (match-end 0))
+ (insert "&lt;<a href=\"" url "\">" link-text "</a>&gt;"))))
+
+;; Tests for htmlize-make-hyperlinks:
+
+;; <mailto:hniksic@xemacs.org>
+;; <http://fly.srk.fer.hr>
+;; <URL:http://www.xemacs.org>
+;; <http://www.mail-archive.com/bbdb-info@xemacs.org/>
+;; <hniksic@xemacs.org>
+;; <xalan-dev-sc.10148567319.hacuhiucknfgmpfnjcpg-john=doe.com@xml.apache.org>
+
+(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&#58;" 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 <span> tags, and
+;; the other with the use of the old <font> 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
+ ;; <font> in <pre>. This makes sense in general, but is bad for
+ ;; htmlize's intended usage of <font> 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
+ ;; <http://imbolc.ucc.ie/~pflynn/articles/htmlpro.html>.
+
+ ;; 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.
+
+ "<!DOCTYPE html PUBLIC \"-//W3C//DTD HTML 4.01//EN\">"
+
+ ;; Now-abandoned HTML Pro declaration.
+ ;"<!DOCTYPE HTML PUBLIC \"+//Silmaril//DTD HTML Pro v0r11 19970101//EN\">"
+ )
+
+(defun htmlize-default-body-tag (face-map)
+ nil ; no doc-string
+ "<body>")
+
+;;; 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 " <style type=\"text/css\">\n <!--\n")
+ (insert " body {\n "
+ (mapconcat #'identity
+ (htmlize-css-specs (gethash 'default face-map))
+ "\n ")
+ "\n }\n")
+ (dolist (face (sort* (copy-list buffer-faces) #'string-lessp
+ :key (lambda (f)
+ (htmlize-fstruct-css-name (gethash f face-map)))))
+ (let* ((fstruct (gethash face face-map))
+ (cleaned-up-face-name
+ (let ((s
+ ;; Use `prin1-to-string' rather than `symbol-name'
+ ;; to get the face name because the "face" can also
+ ;; be an attrlist, which is not a symbol.
+ (prin1-to-string face)))
+ ;; If the name contains `--' or `*/', remove them.
+ (while (string-match "--" s)
+ (setq s (replace-match "-" t t s)))
+ (while (string-match "\\*/" s)
+ (setq s (replace-match "XX" t t s)))
+ s))
+ (specs (htmlize-css-specs fstruct)))
+ (insert " ." (htmlize-fstruct-css-name fstruct))
+ (if (null specs)
+ (insert " {")
+ (insert " {\n /* " cleaned-up-face-name " */\n "
+ (mapconcat #'identity specs "\n ")))
+ (insert "\n }\n")))
+ (insert htmlize-hyperlink-style
+ " -->\n </style>\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 <span class=...> tag for each
+ ;; face in FSTRUCT-LIST.
+ (dolist (fstruct fstruct-list)
+ (princ "<span class=\"" buffer)
+ (princ (htmlize-fstruct-css-name fstruct) buffer)
+ (princ "\">" buffer))
+ (princ text buffer)
+ (dolist (fstruct fstruct-list)
+ (ignore fstruct) ; shut up the byte-compiler
+ (princ "</span>" buffer)))
+
+;; `inline-css' output support.
+
+(defun htmlize-inline-css-body-tag (face-map)
+ (format "<body style=\"%s\">"
+ (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 "<span style=\"" buffer)
+ (princ style buffer)
+ (princ "\">" buffer))
+ (princ text buffer)
+ (when style
+ (princ "</span>" buffer))))
+
+;;; `font' tag based output support.
+
+(defun htmlize-font-body-tag (face-map)
+ (let ((fstruct (gethash 'default face-map)))
+ (format "<body text=\"%s\" bgcolor=\"%s\">"
+ (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: <font> tag for colors, <b> for bold, <u> for
+ ;; underline, and <strike> for strike-through.
+ (let* ((merged (htmlize-merge-faces fstruct-list))
+ (markup (htmlize-memoize
+ merged
+ (cons (concat
+ (and (htmlize-fstruct-foreground merged)
+ (format "<font color=\"%s\">" (htmlize-fstruct-foreground merged)))
+ (and (htmlize-fstruct-boldp merged) "<b>")
+ (and (htmlize-fstruct-italicp merged) "<i>")
+ (and (htmlize-fstruct-underlinep merged) "<u>")
+ (and (htmlize-fstruct-strikep merged) "<strike>"))
+ (concat
+ (and (htmlize-fstruct-strikep merged) "</strike>")
+ (and (htmlize-fstruct-underlinep merged) "</u>")
+ (and (htmlize-fstruct-italicp merged) "</i>")
+ (and (htmlize-fstruct-boldp merged) "</b>")
+ (and (htmlize-fstruct-foreground merged) "</font>"))))))
+ (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 "<!-- Created by htmlize-%s in %s mode. -->\n"
+ htmlize-version htmlize-output-type)
+ "<html>\n ")
+ (plist-put places 'head-start (point-marker))
+ (insert "<head>\n"
+ " <title>" (htmlize-protect-string title) "</title>\n"
+ (if htmlize-html-charset
+ (format (concat " <meta http-equiv=\"Content-Type\" "
+ "content=\"text/html; charset=%s\">\n")
+ htmlize-html-charset)
+ "")
+ htmlize-head-tags)
+ (htmlize-method insert-head buffer-faces face-map)
+ (insert " </head>")
+ (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 "<pre>\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 "</pre>")
+ (plist-put places 'content-end (point-marker))
+ (insert "\n </body>")
+ (plist-put places 'body-end (point-marker))
+ (insert "\n</html>\n")
+ (when htmlize-generate-hyperlinks
+ (htmlize-make-hyperlinks))
+ (htmlize-defang-local-variables)
+ (when htmlize-replace-form-feeds
+ ;; Change each "\n^L" to "<hr />".
+ (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
+ "</pre><hr /><pre>")))
+ (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. <sigh>
+ (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 <phil@shellarchive.co.uk>
+;; 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 <eric dot schulte at gmx dot com>
+;; 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 <http://www.gnu.org/licenses/>.
+
+;;; 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 <kames AT fa2.so-net.ne.jp>
+;; 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 <schulte dot eric at gmail dot com>
+;; 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 <http://www.gnu.org/licenses/>.
+
+;;; 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 <julien@danjou.info>
+
+;; Author: Julien Danjou <julien@danjou.info>
+;; 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 <http://www.gnu.org/licenses/>.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;; 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 <EMAIL>.
+ 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 <EMAIL>.
+ 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 <carsten at orgmode dot org>
+;; 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 <carsten at orgmode dot org>
+;; 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 <eeeickythump@gmail.com>
+;;; 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 <n.goaziou at gmail dot com>
+;; 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 <http://www.gnu.org/licenses/>.
+
+;;; 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 <num>)
+;; 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 "\\<headlines\\>" 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 <carsten.dominik AT gmail DOT com>
+;; Nicolas Goaziou <n.goaziou AT gmail DOT com>
+;; 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 <http://www.gnu.org/licenses/>.
+
+;;; 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 "\\<headlines\\>" 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 <n.goaziou at gmail dot com>
+;; Author: Luis R Anaya <papoanaya aroba hot mail punto com>
+;; 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 <http://www.gnu.org/licenses/>.
+;;; 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 <kjambunathan at gmail dot com>
+;; 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 <http://www.gnu.org/licenses/>.
+
+;;; 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
+ '(("\\\\-" . "&shy;")
+ ("---\\([^-]\\)" . "&mdash;\\1")
+ ("--\\([^-]\\)" . "&ndash;\\1")
+ ("\\.\\.\\." . "&hellip;"))
+ "Regular expressions for special string conversion.")
+
+
+(defconst org-e-html-scripts
+"<script type=\"text/javascript\">
+<!--/*--><![CDATA[/*><!--*/
+ function CodeHighlightOn(elem, id)
+ {
+ var target = document.getElementById(id);
+ if(null != target) {
+ elem.cacheClassElem = elem.className;
+ elem.cacheClassTarget = target.className;
+ target.className = \"code-highlighted\";
+ elem.className = \"code-highlighted\";
+ }
+ }
+ function CodeHighlightOff(elem, id)
+ {
+ var target = document.getElementById(id);
+ if(elem.cacheClassElem)
+ elem.className = elem.cacheClassElem;
+ if(elem.cacheClassTarget)
+ target.className = elem.cacheClassTarget;
+ }
+/*]]>*///-->
+</script>"
+"Basic JavaScript that is needed by HTML files produced by Org-mode.")
+
+
+(defconst org-e-html-style-default
+"<style type=\"text/css\">
+ <!--/*--><![CDATA[/*><!--*/
+ html { font-family: Times, serif; font-size: 12pt; }
+ .title { text-align: center; }
+ .todo { color: red; }
+ .done { color: green; }
+ .tag { background-color: #add8e6; font-weight:normal }
+ .target { }
+ .timestamp { color: #bebebe; }
+ .timestamp-kwd { color: #5f9ea0; }
+ .right {margin-left:auto; margin-right:0px; text-align:right;}
+ .left {margin-left:0px; margin-right:auto; text-align:left;}
+ .center {margin-left:auto; margin-right:auto; text-align:center;}
+ p.verse { margin-left: 3% }
+ pre {
+ border: 1pt solid #AEBDCC;
+ background-color: #F3F5F7;
+ padding: 5pt;
+ font-family: courier, monospace;
+ font-size: 90%;
+ overflow:auto;
+ }
+ table { border-collapse: collapse; }
+ td, th { vertical-align: top; }
+ th.right { text-align:center; }
+ th.left { text-align:center; }
+ th.center { text-align:center; }
+ td.right { text-align:right; }
+ td.left { text-align:left; }
+ td.center { text-align:center; }
+ dt { font-weight: bold; }
+ div.figure { padding: 0.5em; }
+ div.figure p { text-align: center; }
+ div.inlinetask {
+ padding:10px;
+ border:2px solid gray;
+ margin:10px;
+ background: #ffffcc;
+ }
+ textarea { overflow-x: auto; }
+ .linenr { font-size:smaller }
+ .code-highlighted {background-color:#ffff00;}
+ .org-info-js_info-navigation { border-style:none; }
+ #org-info-js_console-label { font-size:10px; font-weight:bold;
+ white-space:nowrap; }
+ .org-info-js_search-highlight {background-color:#ffff00; color:#000000;
+ font-weight:bold; }
+ /*]]>*/-->
+</style>"
+ "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 . "<b>%s</b>")
+ (code . "<code>%s</code>")
+ (italic . "<i>%s</i>")
+ (strike-through . "<del>%s</del>")
+ (underline . "<span style=\"text-decoration:underline;\">%s</span>")
+ (verbatim . "<code>%s</code>"))
+ "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 "<div id=\"footnotes\">
+<h2 class=\"footnotes\">%s: </h2>
+<div id=\"text-footnotes\">
+%s
+</div>
+</div>"
+ "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 "<sup>%s</sup>"
+ "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 "<sup>, </sup>"
+ "Text used to separate footnotes."
+ :group 'org-export-e-html
+ :type 'string)
+
+
+;;;; Headline
+
+(defcustom org-e-html-toplevel-hlevel 2
+ "The <H> 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 <h1>, 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 <h1> 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 <img> 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
+ '(("&" . "&amp;")
+ ("<" . "&lt;")
+ (">" . "&gt;"))
+ "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-\\|[[(]\\|^\\)\"" . "&laquo;&nbsp;")
+ ("\\(\\S-\\)\"" . "&nbsp;&raquo;")
+ ("\\(\\s-\\|(\\|^\\)'" . "&rsquo;"))
+ ("en"
+ ("\\(\\s-\\|[[(]\\|^\\)\"" . "&ldquo;")
+ ("\\(\\S-\\)\"" . "&rdquo;")
+ ("\\(\\s-\\|(\\|^\\)'" . "&lsquo;")))
+ "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
+ "<table border=\"2\" cellspacing=\"0\" cellpadding=\"6\" rules=\"groups\" frame=\"hsides\">"
+ "The HTML tag that is used to start a table.
+This must be a <table> 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 '("<th scope=\"%s\"%s>" . "</th>")
+ "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 '("<td%s>" . "</td>")
+ "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 '("<tr>" . "</tr>")
+ "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
+ \"<tr>\"
+ (if (= (mod nline 2) 1)
+ \"<tr class=\\\"tr-odd\\\">\"
+ \"<tr class=\\\"tr-even\\\">\"))
+ \"</tr>\"))
+
+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" . "<?xml version=\"1.0\" encoding=\"%s\"?>")
+ ("php" . "<?php echo \"<?xml version=\\\"1.0\\\" encoding=\\\"%s\\\" ?>\"; ?>"))
+ "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
+ "<script type=\"text/javascript\" src=\"%PATH\">
+<!--/*--><![CDATA[/*><!--*/
+ MathJax.Hub.Config({
+ // Only one of the two following lines, depending on user settings
+ // First allows browser-native MathML display, second forces HTML/CSS
+ :MMLYES: config: [\"MMLorHTML.js\"], jax: [\"input/TeX\"],
+ :MMLNO: jax: [\"input/TeX\", \"output/HTML-CSS\"],
+ extensions: [\"tex2jax.js\",\"TeX/AMSmath.js\",\"TeX/AMSsymbols.js\",
+ \"TeX/noUndefined.js\"],
+ tex2jax: {
+ inlineMath: [ [\"\\\\(\",\"\\\\)\"] ],
+ displayMath: [ ['$$','$$'], [\"\\\\[\",\"\\\\]\"], [\"\\\\begin{displaymath}\",\"\\\\end{displaymath}\"] ],
+ skipTags: [\"script\",\"noscript\",\"style\",\"textarea\",\"pre\",\"code\"],
+ ignoreClass: \"tex2jax_ignore\",
+ processEscapes: false,
+ processEnvironments: true,
+ preview: \"TeX\"
+ },
+ showProcessingMessages: true,
+ displayAlign: \"%ALIGN\",
+ displayIndent: \"%INDENT\",
+
+ \"HTML-CSS\": {
+ scale: %SCALE,
+ availableFonts: [\"STIX\",\"TeX\"],
+ preferredFont: \"TeX\",
+ webFont: \"TeX\",
+ imageFont: \"TeX\",
+ showMathMenu: true,
+ },
+ MMLorHTML: {
+ prefer: {
+ MSIE: \"MML\",
+ Firefox: \"MML\",
+ Opera: \"HTML\",
+ other: \"HTML\"
+ }
+ }
+ });
+/*]]>*///-->
+</script>"
+ "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" "<p class=\"author\">Author: %a (%e)</p>
+<p class=\"date\">Date: %d</p>
+<p class=\"creator\">Generated by %c</p>
+<p class=\"xhtml-validation\">%v</p>
+"))
+ "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
+ "<a href=\"http://validator.w3.org/check?uri=referer\">Validate XHTML 1.0</a>"
+ "Link to HTML validation service."
+ :group 'org-export-e-html
+ :type 'string)
+
+(defcustom org-e-html-creator-string
+ (format "Generated by <a href=\"http://orgmode.org\">Org</a> mode %s in <a href=\"http://www.gnu.org/software/emacs/\">Emacs</a> %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
+ "<div id=\"org-div-home-and-up\" style=\"text-align:right;font-size:70%%;white-space:nowrap;\">
+ <a accesskey=\"h\" href=\"%s\"> UP </a>
+ |
+ <a accesskey=\"H\" href=\"%s\"> HOME </a>
+</div>"
+ "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:
+
+ <style type=\"text/css\">
+ <![CDATA[
+ p { font-weight: normal; color: gray; }
+ h1 { color: black; }
+ .title { text-align: center; }
+ .todo, .timestamp-kwd { color: red; }
+ .done { color: green; }
+ ]]>
+ </style>
+
+If you'd like to refer to an external style file, use something like
+
+ <link rel=\"stylesheet\" type=\"text/css\" href=\"mystyles.css\">
+
+As the value of this option simply gets inserted into the HTML <head> 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 <style>...</style> 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 "\\<alt=" (or attr "")) "")
+ ((string-match "^ltxpng/" src)
+ (format " alt=\"%s\""
+ (org-e-html-encode-plain-text
+ (org-find-text-property-in-string
+ 'org-latex-src src))))
+ (t (format " alt=\"%s\""
+ (file-name-nondirectory src)))))))
+ (cond
+ (standalone-p
+ (let ((img (format "<img src=\"%s\" %s/>" src attr)))
+ (format "\n<div%s class=\"figure\">%s%s\n</div>"
+ id (format "\n<p>%s</p>" img)
+ (when caption (format "\n<p>%s</p>" caption)))))
+ (t (format "<img src=\"%s\" %s/>" 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]*<div \\(id\\|class\\)=\"bibliography\"" nil t)
+ (setq beg (match-beginning 0))
+ (while (re-search-forward "</?div\\>" nil t)
+ (setq cnt (+ cnt (if (string= (match-string 0) "<div") +1 -1)))
+ (when (= cnt 0)
+ (and (looking-at ">") (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 \"</style>\"."
+ (if (and (stringp extra)
+ (string-match "\\S-" extra)
+ (string-match "</style>" 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 "<style" nil t)
+ (delete-region (point-min) (match-beginning 0)))
+ (if (re-search-forward "</style>" 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<ul>\n<li>")
+ ((< cnt 0) "</li>\n</ul>\n")))
+ (if (> cnt 0) "\n<ul>\n<li>" "</li>\n<li>")))
+ headline)))
+ toc-entries "")
+ (org-e-html-make-string
+ (- prev-level start-level) "</li>\n</ul>\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 "&nbsp;&nbsp;&nbsp;") (org-e-html--tags tags))))
+ (format "<a href=\"#%s\">%s</a>"
+ (org-export-solidify-link-text headline-label)
+ (if (not nil) headline
+ (format "<span class=\"%s\">%s</span>" 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
+ "<div id=\"table-of-contents\">\n"
+ (format "<h%d>%s</h%d>\n"
+ org-e-html-toplevel-hlevel
+ (org-e-html--translate "Table of Contents" info)
+ org-e-html-toplevel-hlevel)
+ "<div id=\"text-table-of-contents\">"
+ (org-e-html-toc-text toc-entries)
+ "</div>\n"
+ "</div>\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
+ "<tr>\n<td>%s</td>\n<td>%s</td>\n</tr>\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 "<p>%s</p>"
+ (org-trim (org-export-data raw info))))))))
+ (when fn-alist
+ (org-e-html-format-footnotes-section
+ (org-e-html--translate "Footnotes" info)
+ (format
+ "<table>\n%s\n</table>\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<title>%s</title>\n" title)
+ (format
+ "\n<meta http-equiv=\"Content-Type\" content=\"text/html;charset=%s\"/>"
+ (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<meta name=\"title\" content=\"%s\"/>" title)
+ (format "\n<meta name=\"generator\" content=\"Org-mode\"/>")
+ (format "\n<meta name=\"generated\" content=\"%s\"/>"
+ (org-e-html-format-date info))
+ (format "\n<meta name=\"author\" content=\"%s\"/>" author)
+ (format "\n<meta name=\"description\" content=\"%s\"/>" description)
+ (format "\n<meta name=\"keywords\" content=\"%s\"/>" 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 "\\<mathml:") in-buffer)
+ (setq val (car (read-from-string
+ (substring in-buffer (match-end 0))))))
+ ;; Exchange prefixes depending on mathml setting
+ (if (not val) (setq x yes yes no no x))
+ ;; Replace cookies to turn on or off the config/jax lines
+ (if (string-match ":MMLYES:" template)
+ (setq template (replace-match yes t t template)))
+ (if (string-match ":MMLNO:" template)
+ (setq template (replace-match no t t template)))
+ ;; Return the modified template
+ template)))
+
+(defun org-e-html-preamble (info)
+ (when (plist-get info :html-preamble)
+ (let* ((title (org-export-data (plist-get info :title) info))
+ (date (org-e-html-format-date info))
+ (author (org-export-data (plist-get info :author) info))
+ (email (plist-get info :email))
+ (html-pre-real-contents
+ (cond
+ ((functionp (plist-get info :html-preamble))
+ (with-temp-buffer
+ (funcall (plist-get info :html-preamble))
+ (buffer-string)))
+ ((stringp (plist-get info :html-preamble))
+ (format-spec (plist-get info :html-preamble)
+ `((?t . ,title) (?a . ,author)
+ (?d . ,date) (?e . ,email))))
+ (t
+ (format-spec
+ (or (cadr (assoc (plist-get info :language)
+ org-e-html-preamble-format))
+ (cadr (assoc "en" org-e-html-preamble-format)))
+ `((?t . ,title) (?a . ,author)
+ (?d . ,date) (?e . ,email)))))))
+ (when (not (equal html-pre-real-contents ""))
+ (concat
+ (format "
+<div id=\"%s\"> " (nth 0 org-e-html-divs))
+ "
+"
+ html-pre-real-contents
+ "
+</div>")))))
+
+(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 "<a href=\"mailto:%s\">%s</a>" 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
+ "
+<div id=\"" (nth 2 org-e-html-divs) "\">"
+ (cond
+ ;; auto postamble
+ ((eq (plist-get info :html-postamble) 'auto)
+ (concat
+ (when (plist-get info :time-stamp-file)
+ (format "
+<p class=\"date\"> %s: %s </p> " (org-e-html--translate "Date" info) date))
+ (when (and (plist-get info :with-author) author)
+ (format "
+<p class=\"author\"> %s : %s</p>" (org-e-html--translate "Author" info) author))
+ (when (and (plist-get info :with-email) email)
+ (format "
+<p class=\"email\"> %s </p>" email))
+ (when (plist-get info :with-creator)
+ (format "
+<p class=\"creator\"> %s </p>" 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)))))
+ "
+</div>")))
+ ;; 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"))
+ "
+<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\"
+ \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">"
+ (format "
+<html xmlns=\"http://www.w3.org/1999/xhtml\" lang=\"%s\" xml:lang=\"%s\"> "
+ (plist-get info :language) (plist-get info :language))
+ "
+<head>"
+ (org-e-html-meta-info info) ; meta
+ (org-e-html-style info) ; style
+ (org-e-html-mathjax-config info) ; mathjax
+ "
+</head>"
+
+ "
+<body>"
+ (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 "
+<div id=\"%s\">" (or org-e-html-content-div
+ (nth 1 org-e-html-divs)))
+ ;; document title
+ (format "
+<h1 class=\"title\">%s</h1>\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
+ "
+</div>")
+
+ ;; postamble
+ (org-e-html-postamble info)
+
+ (unless body-only
+ "
+</body>")
+ "
+</html>"))
+
+(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 "<a%s>%s</a>" attributes (or desc ""))))
+
+;;;; Todo
+
+(defun org-e-html--todo (todo)
+ (when todo
+ (format "<span class=\"%s %s%s\">%s</span>"
+ (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 "<span class=\"tag\">%s</span>"
+ (mapconcat
+ (lambda (tag)
+ (format "<span class=\"%s\">%s</span>"
+ (concat org-e-html-tag-class-prefix
+ (org-e-html-fix-class-name tag))
+ tag))
+ tags "&nbsp;"))))
+
+;;;; 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 "<span class=\"section-number-%d\">%s</span> "
+ level section-number)))
+ (todo (org-e-html--todo todo))
+ (tags (org-e-html--tags tags)))
+ (concat section-number todo (and todo " ") text
+ (and tags "&nbsp;&nbsp;&nbsp;") 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 <pre></pre> tags.
+ (if (string-match "<pre[^>]*>\n*\\([^\000]*\\)</pre>" 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 "<span class=\"linenr\">%s</span>"
+ (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 "<span id=\"coderef-%s\" class=\"coderef-off\">%s</span>"
+ 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 "<div style=\"text-align: center\">\n%s</div>" 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 "<p>
+<span class=\"timestamp-wrapper\">
+<span class=\"timestamp-kwd\">%s</span> <span class=\"timestamp\">%s</span>%s
+</span>
+</p>"
+ org-clock-string
+ (org-translate-time (org-element-property :value clock))
+ (let ((time (org-element-property :time clock)))
+ (and time (format " <span class=\"timestamp\">(%s)</span>" 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
+ "<p>\n<textarea cols=\"%d\" rows=\"%d\">\n%s</textarea>\n</p>"
+ cols rows code)))
+ (t (format "<pre class=\"example\">\n%s</pre>" 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 "<pre class=\"example\">\n%s</pre>"
+ (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 "<div id=\"%s\" class=\"%s\">%s%s</div>\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<h%d id=\"%s\">%s%s</h%d>\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 "<hr/>")))
+
+
+;;;; 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 "<div class=\"%s\"%s>\n" class extra) text "</div>\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
+ "<div class=\"inlinetask\">\n<b>%s</b><br/>\n%s</div>"
+ (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 "<code>[X]</code>")
+ (off "<code>[&nbsp;]</code>")
+ (trans "<code>[-]</code>")
+ (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 "<li%s>" extra)))
+ (unordered
+ (let* ((id term-counter-id)
+ (extra (if id (format " id=\"%s\"" id) "")))
+ (concat
+ (format "<li%s>" extra)
+ (when headline (concat headline "<br/>")))))
+ (descriptive
+ (let* ((term term-counter-id))
+ (setq term (or term "(no term)"))
+ ;; Check-boxes in descriptive lists are associated to tag.
+ (concat (format "<dt> %s </dt>"
+ (concat checkbox term))
+ "<dd>"))))
+ (unless (eq type 'descriptive) checkbox)
+ contents
+ (case type
+ (ordered "</li>")
+ (unordered "</li>")
+ (descriptive "</dd>")))))
+
+(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 "\\<headlines\\>" 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."
+ "<br/>")
+
+
+;;;; 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 "<a href=\"#%s\"%s>%s</a>"
+ (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 "<a href=\"%s#%s\"%s>%s</a>"
+ path fragment attributes (or desc destination))))
+ ;; Fuzzy link points nowhere.
+ ((nil)
+ (format "<i>%s</i>"
+ (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 "<a href=\"#%s\"%s>%s</a>"
+ (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 "<a href=\"#%s\"%s>%s</a>"
+ 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 "<a href=\"#%s\" %s%s>%s</a>"
+ 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 "<a href=\"%s\"%s>%s</a>" path attributes desc))
+ ;; External link without a description part.
+ (path (format "<a href=\"%s\"%s>%s</a>" path attributes path))
+ ;; No path, only description. Try to do something useful.
+ (t (format "<i>%s</i>" 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 "<p%s>\n%s</p>" extra contents)))))
+
+
+;;;; Plain List
+
+(defun org-e-html-begin-plain-list (type &optional arg1)
+ (case type
+ (ordered
+ (format "<ol%s>" (if arg1 ; FIXME
+ (format " start=\"%d\"" arg1)
+ "")))
+ (unordered "<ul>")
+ (descriptive "<dl>")))
+
+(defun org-e-html-end-plain-list (type)
+ (case type
+ (ordered "</ol>")
+ (unordered "</ul>")
+ (descriptive "</dl>")))
+
+(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 "<span class=\"timestamp-kwd\">%s</span> <span class=\"timestamp\">%s</span>"))
+ (format
+ "<p><span class=\"timestamp-wrapper\">%s</span></p>"
+ (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 "<blockquote>\n%s</blockquote>" 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 "<pre>\n%s</pre>" 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 "<div class=\"outline-text-%d\" id=\"text-%s\">\n%s</div>"
+ 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 "<div class=\"%s\">\n%s\n</div>" 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
+ "<div class=\"org-src-container\">\n%s%s\n</div>"
+ (if (not caption) ""
+ (format "<label class=\"org-src-name\">%s</label>" caption-str))
+ (format "\n<pre class=\"src src-%s\">%s</pre>" 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
+ "<p>\n<textarea cols=\"%d\" rows=\"%d\">\n%s</textarea>\n</p>"
+ cols rows code)))
+ (t (format "<pre class=\"example\">\n%s</pre>" 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 "<code>%s</code>" 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 "<sub>%s</sub>" 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 "<sup>%s</sup>" 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 "&nbsp;"))
+ (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)))
+ '("<tbody>" . "\n</tbody>"))
+ ;; 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)
+ '("<thead>" . "\n</thead>"))
+ ;; Case 2: Row is from first and only row group.
+ (t '("<tbody>" . "\n</tbody>")))))
+ (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<colgroup>")
+ ;; Add a column. Also specify it's alignment.
+ (format "\n<col %s/>" (format alignspec alignment))
+ ;; End a colgroup?
+ (when (org-export-table-cell-ends-colgroup-p
+ table-cell info)
+ "\n</colgroup>"))))
+ (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\\(.*\\)>" 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 "<table%s>\n%s\n%s\n%s\n</table>"
+ table-attributes
+ (if (not caption) "" (format "<caption>%s</caption>" 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 "<span class=\"timestamp-wrapper\"><span class=\"timestamp\">%s</span></span>"
+ (if (not range-end) value
+ (concat value "&ndash;" (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
+ "^ *\\\\\\\\$" "<br/>\n"
+ (replace-regexp-in-string
+ "\\(\\\\\\\\\\)?[ \t]*\n" " <br/>\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 "&nbsp;"))))))
+ (setq contents (replace-match ws nil t contents))))
+ (org-e-html--wrap-label
+ verse-block (format "<p class=\"verse\">\n%s</p>" 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 \"<body>\" and \"</body>\" 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 \"<body>\" and \"</body>\" 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 <n.goaziou at gmail dot com>
+;; 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 <http://www.gnu.org/licenses/>.
+
+;;; 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")))